pax_global_header00006660000000000000000000000064120373614640014520gustar00rootroot0000000000000052 comment=24325e9b1054447dbacacd21b495570f546d1df5 scheme2c-2012.10.14/000077500000000000000000000000001203736146400136015ustar00rootroot00000000000000scheme2c-2012.10.14/.gitignore000066400000000000000000000003671203736146400155770ustar00rootroot00000000000000/AMD64/ /AOSF/ /DECMIPS/ /FREEBSD/ /HP300/ /HP700/ /LINUX/ /MAC/ /SGIMIPS/ /SONYMIPS/ /SUNOS4/ /SUNOS5/ /VAX/ /doc/*.aux /doc/*.dvi /doc/*.idx /doc/*.log /doc/*.toc /doc/embedded.pdf /doc/index.pdf /doc/intro.pdf /doc/r4rs.pdf /doc/smithnotes.pdf scheme2c-2012.10.14/CHANGES000066400000000000000000000157471203736146400146120ustar00rootroot00000000000000The 15mar93jfb release moves Scheme->C to additional platforms that differ from the previous platforms in that they may not have UNIX-like operating systems nor assume that sizeof(int) and sizeof( int* ) is 32. Users on existing platforms will see a few bugs fixed, but otherwise the system looks pretty much the same. If you were one of the few users of SAVE-HEAP or OPEN-PROCESS, you'll be disappointed as those procedures have been dropped as too operating system dependent. Users who have done ports to other platforms will find mixed news. While the source has been reorganized to centralize machine specific items and provide a system independent interface layer between Scheme->C and the host system, you're old patches won't drop right in to the new source. However, new ports should be a lot easier, and ports to non-UNIX like systems are now much easier. Finally, the system may now be configured as a Scheme interpreter (perhaps with your extensions) that can be safely embedded inside an event driven system. The embedded server does not require operating system signals nor an I/O system. It supports time slicing and checks for stack overflow so it is safe to evaluate: (let loop () (loop)) or (let loop () (loop) #t) within the server. N.B. Making Scheme->C more portable has required changes in the runtime environment. It is not possible to mix code compiled by earlier versions of the compiler with code compiled by this compiler. Documentation changes since the 01nov91jfb release: 1. Added PostScript for R4RS. 2. Updated index to reflect changes. 3. Added the document "Embedded Scheme->C" explaining how to embed Scheme in an event sensative server. Compiler changes since the 01nov91jfb release: 1. Added the syntax (define-external variable TOP-LEVEL module) to define a variable that is addressed via the top level that lives in a known module. 2. Change LETREC macro expansion to enclose the body in a BEGIN to prevent incorrect evaluation of internal defines. 3. Change LISTIFY-OPTIONAL-ARGUMENTS to not allocate a temporary when the list is composed of a single item. 4. Constants defined by DEFINE-CONSTANT are now defined for use in compile time expressions. 5. When a module form is not supplied, the module name defaults to the source file name (less the .sc suffix). 6. Forms like: (let () (define x 1) (set! foo 2) ) (let () (define x 3) (set! bar 4) ) containging let's whose only purpose is to introduce a new lexical scope are now correctly compiled when they appear at the top level. 7. Lambda expressions containing arguments that are not symbols now result in an error message rather than a compiler error. 8. Compiled code now supports optional stack overflow checks and timeslicing. 9. A number of changes were made in the emitted C code to handle architecture and C compiler differences across the platforms now supported. For example, 32-bit int's are no longer assumed, nor are 32-bit pointers. 10. External procedure declarations now declare the type of their arguments when the C compiler allows it. 11. The compiler no longer uses a saved heap image. This was eliminated to make the compiler more portable and allow one compiler to compile for a variety of configurations. 12. The compiler no longer has any direct calls to the C runtime environment. 13. When a module name is not defined, the module name defaults to the source file name (less the ".sc" suffix). Runtime changes since the 01nov91jfb release: 1. If the string passed to SYMBOL->STRING and SYMBOL->UNINTERNED-STRING is later mutated, it does not effect the symbol. 2. Zero argument values no longer cause GCD to trap. 3. NUMBER->STRING does not return radix prefix in the string. 4. Change the expansion of LETREC to correctly handle internal defines. Previously: (letrec ((x 1)) (define x 2) x) = ((LAMBDA (X) ((LAMBDA (X) (SET! X 2) (SET! X 1) X) 0)) 0) => 1 Now: (expand '(letrec ((x 1)) (define x 2) x)) = ((LAMBDA (X) (SET! X 1) (BEGIN ((LAMBDA (X) (SET! X 2) X) 0))) 0) => 2 5. LOAD, LOADE, and LOADQ no longer cause READ-EVAL-PRINT to assume Scheme is interactive. 6. Correct token size computation when output to a port is being pretty printed. 7. Correct comment on getmem in scinit.c. 8. EVAL now verifies that the optional environment is an a-list. 9. Added DEBUG-OUTPUT-PORT, TRACE-OUTPUT-PORT, WEAK-CONS, RENAME-FILE, REMOVE-FILE, additional C and Scheme structure access procedures, procedures to set/get the time slice, stack size, and garbage collector parameters, and TIME-OF-DAY. 10. Deleted OPEN-PROCESS, OPEN-INPUT-PROCESS, OPEN-OUTPUT-PROCESS, SAVE-HEAP, and MY-RUSAGE as they were too system specific. 11. The system may be easily compiled to build an interpreter that can be embedded inside an event driven server. When compiled this way, it does not require access to operating system signals or an I/O system. The embedded server supports time slicing and checks for stack overflow so it is safe to evaluate the following: (let loop () (loop)) and (let loop () (loop) #t). 12. The bulk of the operating system specific interfaces were moved into cio.c. This has resulted to significant changes to heap.c and scinit.c. There are now no direct calls to the C runtime environment from Scheme code. All access is via routines in cio.c. 13. The default maximum heap size is now five times the initial heap size. 14. The file names scexpand1.sc and scexpand2.sc were changed to scexpnd1.sc and scexpnd2.sc to be compatible with MS-DOS. 15. WHEN-UNREFERENCED has been recoded to reduce the amount of debris left on the stack that used to cause objects to be unnecessarily retained. 16. Code moved from scrt5.sc to scrt6.sc to fit in MS Windows' code segment limitations. 17. Added a dummy module scrtuser.sc to as an aid to inserting additional user code. 18. The compiler no longer generates direct calls to call-with-current-continuation. As a result, user code may redefine it without having to change the underlying Scheme->C system. 19. Added a primitive record type, %record, that users can use to implement their desired record system. 20. Control-C during a system file task is now correctly handled. C declaration compiler changes since the 01nov91jfb release: 1. Added a new declaration type "sizeof" that defines the size and alignment characteristics of the base C types. Alignment information is used to generate correct access procedures. 2. Added the C program "sizeof" that creates sizeof declarations for a the host system. Xlib changes since the 01nov91jfb release: 1. Add support for some procedures added in X11R4. 2. Module initialization problems for a few structure access modules were corrected. 3. Do not assume that long int's and int's are the same size. 4. Remove assumptions about base C type sizes from xwss.sc. 4/28/2008: Changed to MIT license and HP Copyright. scheme2c-2012.10.14/INSTALL000077500000000000000000000022171203736146400146370ustar00rootroot00000000000000#!/bin/sh # QUICK BUILD/INSTALLATION GUIDE # Quick instructions for building s2c on Debian amd64, including the # X11-enabled libraries etc. All lines including "-C doc" can be # omitted to skip the manuals. Switch AMD64 to LINUX (for i386) or ARM # (for arm). Change prefix to /usr or /home/username, and other # locations, as appropriate. # required development libraries: libsigsegv-dev, libx11-dev # required to build documentation: # texlive-latex-base, texlive-latex-extra, latex209-bin, # texlive-fonts-recommended, ghostscript # In the root of the unpacked sources run: set -e set -x A=AMD64 P="prefix=/usr/local MANDIR=\$(prefix)/share/man DOCDIR=\$(prefix)/share/doc/scheme2c" D=~/tmp/s2c I="$P DESTDIR=$D" T=~/tmp/scheme2c-binary.tar.gz MAKE=make ${MAKE} $P for$A ${MAKE} $P -C $A ${MAKE} $P -C $A/cdecl all ${MAKE} $P -C $A/xlib sizeof.cdecl libs2cxl.a s2cixl ${MAKE} $P -C doc ${MAKE} $I -C $A/scrt install ${MAKE} $I -C $A/scsc install ${MAKE} $I -C $A/cdecl install ${MAKE} $I -C $A/xlib install ${MAKE} $I -C doc install tar -zcf $T -C $D . # The result is a tarball which can be installed with, e.g., # sudo tar -C / -zxf $T scheme2c-2012.10.14/README000066400000000000000000000134751203736146400144730ustar00rootroot00000000000000Overview of the DEC Scheme->C Compiler. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (Copyright was changed 4/28/08. Note that I did not change the copyright messages included in various examples, in spite of the fact that the copyright holder was changed from DEC to HP. If someone wants to fix the initial prompt in various examples in the documentation, feel free ... Hans Boehm) This is the root directory for the Scheme-to-C compiler which was done at Digital Equipment Corporation's Western Research Laboratory. Changes from the previous release are noted in the file CHANGES found in this directory. The compiler distribution consists of several directories: doc contains documentation. ports contains implementation specific files. scrt contains the runtime system. scsc contains the compiler. test contains compiler and runtime test programs. cdecl a C declaration compiler written in Scheme. xlib X11 Xlib stubs for Scheme->C. In order to install the compiler and interpreter on a system, the following steps must be done. These instructions assume you're working on a workstation with a "unix-like" operating system such as a DECstation 5000 running ULTRIX. 1. Verify that this directory contains the previously mentioned directories. 2. Create directories for the processor(s) desired: For Alpha AXP OSF/1: 1 > make forAOSF For Apple Macintosh system 7.1 with Think-C 5.0: 1 > make forMAC For ULTRIX DECstations: 1 > make forDECMIPS For SGI systems based on Rx000 MIPS processors: 1 > make forSGIMIPS For ULTRIX VAX systems: 1 > make forVAX For Microsoft Windows 3.1 with Microsoft C 7.0: 1 > make forWIN16 3. Build Scheme->C for a specific processor: For Alpha AXP OSF/1: 2 > cd AOSF;make port N.B.: During the compilation, uopt warnings of the form "this procedure not optimized because it exceeds size threshold" may occur. These warnings may be ignored. For Apple Macintosh system 7.1 with Think-C 5.0: No further steps are done on the workstation. Follow the instructions in MAC/README to transfer files to a Macintosh and complete the build. For ULTRIX DECstations: 2 > cd DECMIPS;make port N.B.: During the compilation, uopt warnings of the form "this procedure not optimized because it exceeds size threshold" may occur. These warnings may be ignored. For SGI systems: 2 > cd SGIMIPS;make port N.B.: During the compilation, uopt warnings of the form "this procedure not optimized because it exceeds size threshold" may occur. These warnings may be ignored. For VAX systems: 2 > cd VAX;make port N.B.: During the compilation of scrt/scinit.c, one will get the warnings: "scinit.c", line 314: warning: illegal pointer combination "scinit.c", line 316: warning: illegal pointer combination "scinit.c", line 318: warning: illegal pointer combination They may be ignored. During the compilation of scrt/objects.c, one will get the following warnings: "objects.c", line 605: warning: illegal pointer combination "objects.c", line 611: warning: illegal pointer combination "objects.c", line 614: warning: illegal pointer combination "objects.c", line 619: warning: illegal pointer combination "objects.c", line 622: warning: illegal pointer combination They may be ignored. For Microsoft Windows 3.1 with Microsoft C 7.0: No further steps are done on the workstation. Follow the instructions in WIN16/README to transfer files to a PC and complete the build. 4. Verify that the interpreter and compiler were correctly built: 4 >cd test 5 >../scrt/s2ci SCHEME->C -- ... > (load "test51.sc") MODULE form ignored TEST51 "test51.sc" > (test51 '()) Hello world! #F > ^D 6 >make test51 ../scsc/s2ccomp -schf ../scsc/s2ccomp.heap -C test51.sc test51.sc: ../scsc/s2ccomp -schf ../scsc/s2ccomp.heap -c -g test51.c cc -o test51 -g test51.o ../scrt/libs2c.a -lm 7 >test51 Hello world! 5. Install the libraries, compiler, and interpreter in some directory such as ~/bin: 8 >cd .. 9 >make prefix=$HOME/s2c BINDIR=. LIBDIR=. LIBSUBDIR=. install 10 >rehash Given that this directory in the current search path, the compiler can now be accessed by "s2cc" and the interpreter by "s2ci". N.B. Some users will see two or three sequences of error messages ending with "*** Error code 1 (ignored)." These errors may be ignored. 6. At this point, the source in cdecl and xlib can now be compiled if desired: 11 > cd cdecl 12 > make all 13 > cd ../xlib 14 > make all Documentation for cdecl and xlib is contained in files found in their respective directories. 7. If desired, the embedded server sample program and library is constructed as follows: 15 > cd ../server 16 > make embedded libs2csrv.a scheme2c-2012.10.14/cdecl/000077500000000000000000000000001203736146400146535ustar00rootroot00000000000000scheme2c-2012.10.14/cdecl/README000066400000000000000000000000521203736146400155300ustar00rootroot00000000000000C stub declaration compiler for Scheme->C scheme2c-2012.10.14/cdecl/cdecl.sc000066400000000000000000000124041203736146400162550ustar00rootroot00000000000000;;; C declaration compiler. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. ;;; This module is the main driver. Expressions in the files names in the ;;; command line will be compiled and the stub module will be written to ;;; the standard output port. (module cdecl (main main) (with const extern typedef screp)) ;;; The following global variables hold lists of C declared items. (define CDECL-CONSTANTS '()) ;;; List of constants (define CDECL-TYPES '()) ;;; List of types (define CDECL-READ-ONLY '()) ;;; List of read-only objects (define CDECL-DEFINE-ONLY '()) ;;; List of internal definitions (define CDECL-EXTERNS '()) ;;; List of external functions ;;; Main program: ;;; ;;; cdecl class command cdecl-files... ;;; ;;; where "class" is the name of this set of declarations and "command" is ;;; one of the following: ;;; ;;; -const Emits constant definitions to the files ;;; classCONSTANTS.sc and classCONSTANTS.sch. ;;; ;;; -extern Emits external procedures for each cdecl-file ;;; containing extern definitions to files named ;;; .sc and .sch. ;;; ;;; -stubs Emits stubs of form * for all ;;; C procedures to the file classSTUBS.sc. This ;;; allows the files produceded by -typedef to be ;;; interpreted. ;;; ;;; -typedef Emits type definitions for structures to the ;;; files .sc and .sch. ;;; Emits all type checking functions and type ;;; definitions for objects other than structs or ;;; unions to classTYPES.sc and classTYPES.sch. ;;; ;;; The command is then followed by one or more files containing declarations. ;;; The declaration files normally have the file extension ".cdecl". (define (MAIN clargs) (let* ((class (if (>= (length clargs) 4) (cadr clargs) (error 'MAIN "cdecl class {-const|-extern|-typedef} cdecl-files..."))) (const-file-root (string-append class "CONSTANTS")) (stubs-file-root (string-append class "STUBS")) (type-file-root (string-append class "TYPES")) (cdecl-stubs '()) (command (if (member (caddr clargs) '("-const" "-extern" "-stubs" "-typedef")) (caddr clargs) (error 'MAIN "Unrecognized command: ~s" (cddr clargs))))) (let loop ((files (cdddr clargs))) (when files (load-cdecl (car files)) (if (and (equal? command "-extern") cdecl-externs) (emit-externs (reverse cdecl-externs) (file-root (car files)) type-file-root)) (if (equal? command "-stubs") (set! cdecl-stubs (append cdecl-externs cdecl-stubs))) (loop (cdr files)))) (if (equal? command "-const") (emit-consts (reverse cdecl-constants) cdecl-define-only const-file-root)) (if (equal? command "-stubs") (emit-stubs (reverse cdecl-stubs) stubs-file-root)) (if (equal? command "-typedef") (emit-typedefs (reverse cdecl-types) cdecl-define-only cdecl-read-only type-file-root)))) ;;; Returns a string that is the root of the file name. (define (FILE-ROOT file) (let loop ((fl (string->list file))) (let ((x (member #\/ fl))) (if x (loop (cdr x)) (list->string (let loop ((x fl)) (if (or (null? x) (equal? (car x) #\.)) '() (cons (car x) (loop (cdr x)))))))))) ;;; A declaration is loaded into the system by the following function. (define (LOAD-CDECL file) (set! cdecl-externs '()) (with-input-from-file file (lambda () (let loop ((exp (read))) (unless (eof-object? exp) (case (and (pair? exp) (car exp)) ((sizeof) (input-sizeof exp)) ((const) (set! cdecl-constants (cons (input-const exp) cdecl-constants))) ((typedef) (set! cdecl-types (cons (input-typedef exp) cdecl-types))) ((extern) (set! cdecl-externs (cons (input-extern exp) cdecl-externs))) ((read-only) (set! cdecl-read-only (append (cdr exp) cdecl-read-only))) ((define-only) (set! cdecl-define-only (append (cdr exp) cdecl-define-only))) (else (error 'input-expressions "Unrecognized expression ~s" exp))) (loop (read))))))) scheme2c-2012.10.14/cdecl/const.sc000066400000000000000000000064371203736146400163420ustar00rootroot00000000000000;;; C declaration compiler. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. ;;; This module compiles constant expressions. ;;; ;;; (const ) ;;; ;;; which defines a constant. The expression is evaluated at compile time ;;; and is defined as the following: ;;; ;;; ::= ;;; Scheme-constant ;;; ( Scheme-procedure [ ... ] ) ;;; ;;; When stubs are being generated, this will result in: ;;; ;;; (define ) ;;; ;;; and when an include file is being generated, it will generate: ;;; ;;; (define-constant ) (module const) ;;; During the input phase, the following function is called to process ;;; constant expressions. It will return either the constant or call error ;;; on an error. (define (INPUT-CONST exp) (if (and (= (length exp) 3) (symbol? (cadr exp))) (let ((id (cadr exp))) (putprop id 'const (cddr exp)) id) (error 'input-const "Illegal syntax: ~s" exp))) ;;; A constant value is computed by the following expression. Any errors will ;;; be reported by calling error. (define (CONST-VALUE const) (cond ((symbol? const) (let ((value (getprop const 'const))) (if value (const-value (car value)) (error 'const-value "Undefined constant: ~s" const)))) ((pair? const) (let ((proc (top-level-value (car const)))) (if (procedure? proc) (apply proc (map const-value (cdr const))) (error 'const-value "Undefined function: ~s" (car const))))) (else const))) ;;; Stub declarations are generated by the following function. (define (EMIT-CONSTS constants define-only const-file-root) (with-output-to-file (string-append const-file-root ".sc") (lambda () (format #t "(module ~a)~%~%" const-file-root) (for-each (lambda (const) (unless (memq const define-only) (format #t "(define ~s ~s)~%" const (const-value const)))) constants))) (with-output-to-file (string-append const-file-root ".sch") (lambda () (for-each (lambda (const) (unless (memq const define-only) (format #t "(define-constant ~s ~s)~%" const (const-value const)))) constants)))) scheme2c-2012.10.14/cdecl/document000066400000000000000000000130301203736146400164110ustar00rootroot00000000000000An Introduction to the Scheme->C C Declaration Compiler ------------------------------------------------------- The C declaration compiler is a tool for generating stub procedures to access C structures and library functions. It was designed to allow Scheme->C to access the X11 Xlib. This document is intended to be an introduction to the language. For complete understanding of its use, the reader should examine the Xlib declaration files and the declaration compiler. The declaration compiler is invoked by: cdecl class command cdecl-files... where "class" is the name of the set of declarations and "command" is one of the following: -const Emits constant definitions to the files classCONSTANTS.sc and classCONSTANTS.sch. -extern Emits external procedures for each cdecl-file containing extern definitions to files named .sc and .sch. -typedef Emits type definitions for structures to the files .sc and .sch. Emits all type checking functions and type definitions for objects other than structs or unions to classTYPES.sc and classTYPES.sch. The command is then followed by one or more files containing declarations. The declaration files normally have the file extension ".cdecl". Declaration Language -------------------- The declaration files contain size, constant, type, and external procedure definitions. The sizes of the basic C types are defined by expressions of the form: (sizeof ) The program "sizeof" produces the architecture dependent size declarations for a system. For example, on a DECstation 5000, the declarations are: (sizeof char 1 1 c-byte-ref c-byte-set!) (sizeof shortint 2 2 c-shortint-ref c-shortint-set!) (sizeof shortunsigned 2 2 c-shortunsigned-ref c-shortunsigned-set!) (sizeof int 4 4 c-int-ref c-int-set!) (sizeof unsigned 4 4 c-unsigned-ref c-unsigned-set!) (sizeof longint 4 4 c-longint-ref c-longint-set!) (sizeof longunsigned 4 4 c-longunsigned-ref c-longunsigned-set!) (sizeof float 4 4 c-float-ref c-float-set!) (sizeof double 8 8 c-double-ref c-double-set!) (sizeof pointer 4 4 c-unsigned-ref c-unsigned-set!) (sizeof procedure 4 4 c-unsigned-ref c-unsigned-set!) These declarations should always be in the first declaration file to cdecl. A constant is defined by expressions of the form: (const ) where the expression is evaluated at compile time and is defined as the following: ::= Scheme-constant ( Scheme-procedure [ ... ] ) Types are defined by expressions of the following form: (typedef ) where: ::= ( *) ( *proc) ::= ( integer) ::= char shortint shortunsigned int unsigned long longunsigned float double ::= denoting another type ::= ( struct [ ...] ) ( union [ ...] ) ::= ( ) The final form of expression is used to define external procedures: ( EXTERN [ ... ] ) where: ::= a Scheme string ::= ( ) ( IN ) ( OUT ) ( IN_OUT ) ::= a Scheme symbol Since the declaration source file is a file of Scheme expressions, it is case insensative and it may contain Scheme comments. An Example ---------- The use of the declaration language is best shown by example. A few C declarations from X11's Xlib are: #define DoRed (1<<0) #define DoGreen (1<<1) #define DoBlue (1<<2) typedef struct { unsigned long pixel; unsigned short red, green, blue; char flags; char pad; } XColor; typedef struct _XDisplay{ . . . } Display; typedef int Status; typedef unsignedlong XID; typedef XID Colormap; extern Status XLookupColor(); Converted to the declaration language, they become: (const dored 1) (const dogreen 2) (const doblue 4) (typedef (struct (unsigned pixel) (shortunsigned red) (shortunsigned green) (shortunsigned blue) (char flags) (char pad) ) xcolor) (typedef (xcolor *) xcolorp) (typedef (xcolor 0) xcolora) (typedef (xcolora *) xcolorap) (typedef (struct) display) (typedef (display *) displayp) (typedef int status) (typedef unsigned xid) (typedef xid colormap) (extern status "XLookupColor" (displayp dpy) (colormap cmap) (string spec) (out xcolor def) (out xcolor scr)) The constants are converted in a straight-forward manner, only noting that case does not count in Scheme. When the struct XColor is converted, declaration lists must be broken up into multiple statements. In addition, types are added to define a pointer to an XColor struct, xcolorp, an array of indeterminate size of the XColor structs, xcolora, and a pointer to such an array, xcolorap. The struct, Display, is defined an an "opaque" type, display, with a pointer to one defined as displayp. Unlike C, procedure interfaces have the type of each argument specified. Since Scheme has automatic storage management, functions may return new instances of structured objects. This is noted in the declarations, where def and scr are noted as "out" arguments. The reader should now consult the Scheme->C Xlib documentation for the Scheme programmer's view of the resulting interface. scheme2c-2012.10.14/cdecl/extern.sc000066400000000000000000000172771203736146400165250ustar00rootroot00000000000000;;; C declaration compiler. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. ;;; This module compiles "extern" forms which define C library procedures. ;;; ;;; ::= ( EXTERN [ ... ] ) ;;; ;;; ::= a Scheme string ;;; ;;; ::= ( ) ;;; ( IN ) ;;; ( OUT ) ;;; ( IN_OUT ) ;;; ;;; ::= a Scheme symbol (module extern) ;;; The following function syntax checks an extern expression. It will either ;;; report an error, or return the expression as its value. (define (INPUT-EXTERN exp) (if (and (>= (length exp) 3) (parse-type (cadr exp)) (string? (caddr exp))) (begin (for-each parse-arg (cdddr exp)) exp) (error 'input-extern "Illegal EXTERN syntax: ~s" exp))) ;;; 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))) ;;; Code is generated by the following function. (define (EMIT-EXTERNS externs extern-file-root type-file-root) (let ((module (uis extern-file-root))) (with-output-to-file (string-append extern-file-root ".sc") (lambda () (write `(module ,module)) (newline) (write `(include ,(string-append type-file-root ".sch"))) (newline) (for-each (lambda (x) (emit-extern x 'define)) externs))) (with-output-to-file (string-append extern-file-root ".sch") (lambda () (for-each (lambda (x) (emit-define-external x module)) externs))))) ;;; The definition for the interface procedure for an extern is created by ;;; the following procedure. (define (EMIT-EXTERN extern defform) (let ((xname (uis (caddr extern) "*")) (rettype (cadr extern)) (args (cdddr extern))) (define (EMIT-CALL) `(,xname ,@(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)))) '())) (pp `(define-c-external (,xname ,@(map simple-type args)) ,(simple-type (list rettype 'returned)) ,(caddr extern))) (newline) (pp `(,defform (,(uis (caddr extern)) ,@(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))) ((isa-pointer? rettype) `(cons ',(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 in_out) (cond ((eq? (base-type type) 'int) `(,var (let ((_buf (make-string ,(size-of 'int)))) (c-int-set! _buf 0 ,var) _buf))) (else `(,var (in->c ,var))))) ((out) `(,var (make-string ,(if (eq? type 'string) (size-of 'pointer) (aligned-size-of type))))) (else (cond ((eq? type 'string) `(,var (if (string? ,var) ,var (error 'chk-string "Argument is incorrect type: ~s" ,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 out) (cond ((eq? type 'string) `(c-string->string (c-unsigned-ref ,var 0))) ((isa-pointer? type) `(cons ',(base-type type) (c-unsigned-ref ,var 0))) ((or (isa-union? type) (isa-struct? type) (isa-array? type)) `(cons ',(pointed-to-by type) ,var)) (else `(,(getprop (base-type type) '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) 'void) 'void) ((isa-pointer? (car type)) 'pointer) ((isa-procp? (car type)) 'pointer) (else (base-type (car type))))) ;;; 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)))))))) (pp `(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))) '())))) (pp `(define-c-external (,c-name ,@(map simple-type args)) ,(simple-type (list rettype 'returned)) ,(caddr extern))) (newline) (pp `(define (,stub-name ,@formals) (,c-name ,@formals) ,@(if (eq? rettype 'void) '(#f) '()))) (newline))) scheme2c-2012.10.14/cdecl/load.sc000066400000000000000000000001131203736146400161140ustar00rootroot00000000000000(load "cdecl.sc") (load "const.sc") (load "extern.sc") (load "typedef.sc") scheme2c-2012.10.14/cdecl/makefile000066400000000000000000000021371203736146400163560ustar00rootroot00000000000000prefix=/usr/local LIBDIR=${prefix}/lib BINDIR=${prefix}/bin LIBSUBDIR=scheme2c DOCDIR=$(prefix)/doc/scheme2c MANDIR=$(prefix)/man INSTALL = install INSTALL_DATA = ${INSTALL} -m 644 INSTALL_PROGRAM = ${INSTALL} INSTALL_SCRIPT = ${INSTALL} .SUFFIXES: .SUFFIXES: .sc .c SCSRC = cdecl.sc const.sc extern.sc typedef.sc CSRC = cdecl.c const.c extern.c typedef.c MISC = sizeof.c sch.sc README document load.sc SRCDIR = ../../cdecl SCC = ../scsc/Xs2cc .sc.c: ${SCC} ${CFLAGS} ${LDFLAGS} -C $*.sc all: $(MAKE) "SCC=${SCC}" "SRCDIR=${SRCDIR}" s2cdecl s2csizeof s2ch s2cdecl: ${CSRC} ${SCC} ${CFLAGS} ${LDFLAGS} -o $@ $^ s2csizeof: sizeof.c ${CC} ${CFLAGS} ${LDFLAGS} -o $@ $^ s2ch: sch.sc ${SCC} ${CFLAGS} ${LDFLAGS} -o $@ $^ install: s2ch s2cdecl ${INSTALL} -d ${DESTDIR}${BINDIR} ${INSTALL_PROGRAM} s2ch s2cdecl ${DESTDIR}${BINDIR}/ ln -sf s2ch ${DESTDIR}${BINDIR}/sch clean: rm -f *.o *.CKP *.BAK *.S2C core clean-sc-to-c: rm -f ${CSRC} noprogs: rm -f s2cdecl s2csizeof s2ch srclinks: for x in ${SCSRC} ${MISC}; \ do ln -s ${SRCDIR}/$$x $$x; \ done .PHONY: all noprogs clean-sc-to-c scrlinks scheme2c-2012.10.14/cdecl/sch.sc000066400000000000000000000431521203736146400157640ustar00rootroot00000000000000;;; LaHaShem HaAretz U'Mloah ;;; Copyright 1993, 1994, and 1995 University of Toronto. All rights reserved. ;;; Copyright 1996 Technion. All rights reserved. ;;; Copyright 1996 and 1997 University of Vermont. All rights reserved. ;;; Copyright 1997, 1998, 1999, 2000, and 2001 NEC Research Institute, Inc. All ;;; rights reserved. ;;; Copyright 2002, 2003, 2004, 2005, and 2006 Purdue University. All rights ;;; reserved. (module sch (main main)) (define-external (fopen name access) sc) (define-external (fclose file) sc) (define *panic?* #t) (define *program* #f) (define (panic format-string . &rest) (cond (*panic?* (format stderr-port "~a: ~a~%" *program* (apply format #f format-string &rest)) (exit -1)) (else (apply error 'panic format-string &rest)))) (define (replace-extension pathname extension) (when (string=? pathname "-") (panic "Invalid pathname")) (string-append (strip-extension pathname) "." extension)) (define (can-open-file-for-input? pathname) (or (string=? pathname "-") (let ((file (fopen pathname "r"))) (unless (string? file) (fclose file)) (not (string? file))))) (eval-when (compile load eval) (define (first x) (car x)) (define (second x) (cadr x)) (define (third x) (caddr x)) (define (fourth x) (cadddr x)) (define (fifth x) (car (cddddr x))) (define (sixth x) (cadr (cddddr x))) (define (seventh x) (caddr (cddddr x))) (define (eighth x) (cadddr (cddddr x))) (define (ninth x) (car (cddddr (cddddr x)))) (define (tenth x) (cadr (cddddr (cddddr x)))) (define (eleventh x) (caddr (cddddr (cddddr x)))) (define (twelfth x) (cadddr (cddddr (cddddr x)))) (define (rest x) (cdr x))) (define (last x) (if (null? (rest x)) (first x) (last (rest x)))) (eval-when (compile load eval) (define (every p l . &rest) (let loop ((l l) (&rest &rest)) (or (null? l) (and (apply p (first l) (map first &rest)) (loop (rest l) (map rest &rest))))))) (eval-when (compile load eval) (define (map-reduce g i f l . ls) (if (null? l) i (apply map-reduce g (g i (apply f (car l) (map car ls))) f (cdr l) (map cdr ls))))) (eval-when (compile load eval) (define (reduce f l i) (cond ((null? l) i) ((null? (rest l)) (first l)) (else (let loop ((l (rest l)) (c (first l))) (if (null? l) c (loop (rest l) (f c (first l))))))))) (define (some p l . &rest) (let loop ((l l) (&rest &rest)) (and (not (null? l)) (or (apply p (first l) (map first &rest)) (loop (rest l) (map rest &rest)))))) (define (read-line . port) (if (null? port) (set! port (current-input-port)) (set! port (first port))) (let loop ((chars '())) (let ((char (read-char port))) (if (eof-object? char) (if (null? chars) char (list->string (reverse chars))) (if (char=? char #\newline) (list->string (reverse chars)) (loop (cons char chars))))))) (define (default-extension pathname extension) (when (string=? pathname "-") (panic "Invalid pathname")) (if (has-extension? pathname) pathname (string-append pathname "." extension))) (define (strip-directory pathname) (when (string=? pathname "-") (panic "Invalid pathname")) (if (has-directory? pathname) (let ((l (string->list pathname))) (substring pathname (- (length l) (positionv #\/ (reverse l))) (length l))) pathname)) (define (string-upcase string) (list->string (map char-upcase (string->list string)))) (define (positionv x l) (let loop ((l l) (i 0)) (cond ((null? l) #f) ((eqv? x (first l)) i) (else (loop (rest l) (+ i 1)))))) (define (has-directory? pathname) (when (string=? pathname "-") (panic "Invalid pathname")) (let loop ((l (reverse (string->list pathname)))) (and (not (null? l)) (or (char=? (first l) #\/) (loop (rest l)))))) (define (strip-extension pathname) (when (string=? pathname "-") (panic "Invalid pathname")) (let loop ((l (reverse (string->list pathname)))) (cond ((or (null? l) (char=? (first l) #\/)) pathname) ((char=? (first l) #\.) (list->string (reverse (rest l)))) (else (loop (rest l)))))) (define (has-extension? pathname) (when (string=? pathname "-") (panic "Invalid pathname")) (let loop ((l (reverse (string->list pathname)))) (and (not (null? l)) (not (char=? (first l) #\/)) (or (char=? (first l) #\.) (loop (rest l)))))) (define-macro define-command (lambda (form expander) (unless (and (list? form) (>= (length form) 2) (valid-command-arguments? (second form))) (error 'define-command "Improper DEFINE-COMMAND: ~s" form)) (define (valid-command-arguments? l) (define (valid-optional-parameter? l) (and (list? l) (= (length l) 4) (symbol? (first l)) (string? (second l)))) (define (valid-required-parameter? l) (and (list? l) (= (length l) 3) (symbol? (first l)) (string? (second l)))) (define (order-ok-optional? l) (or (null? l) (and (eq? (first (first l)) 'optional) (order-ok-optional? (rest l))) (and (eq? (first (first l)) 'rest) (null? (rest l))))) (define (order-ok-required? l) (or (null? l) (and (eq? (first (first l)) 'required) (order-ok-required? (rest l))) (and (eq? (first (first l)) 'optional) (order-ok-optional? (rest l))) (and (eq? (first (first l)) 'rest) (null? (rest l))))) (define (order-ok? l) (or (null? l) (and (or (eq? (first (first l)) 'any-number) (eq? (first (first l)) 'at-least-one) (eq? (first (first l)) 'at-most-one) (eq? (first (first l)) 'exactly-one)) (order-ok? (rest l))) (and (eq? (first (first l)) 'required) (order-ok-required? (rest l))) (and (eq? (first (first l)) 'optional) (order-ok-optional? (rest l))) (and (eq? (first (first l)) 'rest) (null? (rest l))))) (and (list? l) (>= (length l) 1) (symbol? (first l)) (every (lambda (l) (and (list? l) (>= (length l) 1) (or (and (or (eq? (first l) 'exactly-one) (eq? (first l) 'at-most-one)) (>= (length l) 2) (every (lambda (l) (and (list? l) (>= (length l) 2) (string? (first l)) (symbol? (second l)) (every valid-optional-parameter? (rest (rest l))))) (rest l))) (and (or (eq? (first l) 'at-least-one) (eq? (first l) 'any-number)) (>= (length l) 2) (every (lambda (l) (and (list? l) (>= (length l) 2) (string? (first l)) (symbol? (second l)) (every valid-required-parameter? (rest (rest l))))) (rest l))) (and (or (eq? (first l) 'required) (eq? (first l) 'rest)) (= (length l) 2) (valid-required-parameter? (second l))) (and (eq? (first l) 'optional) (= (length l) 2) (valid-optional-parameter? (second l)))))) (rest l)) (order-ok? (rest l)))) (define (command-usage l) (define (command-usage1 l) (let ((s (let loop ((l l)) (define (command-usage l) (string-append "-" (first l) (let loop ((l (rest (rest l)))) (cond ((null? l) "") ((null? (rest l)) (string-append " " (second (first l)))) (else (string-append " " (second (first l)) (loop (rest l)))))))) (if (null? (rest l)) (command-usage (first l)) (string-append (command-usage (first l)) "|" (loop (rest l))))))) (if (= (length l) 1) s (string-append "[" s "]")))) (if (null? l) "" (case (first (first l)) ((any-number) (string-append " [" (command-usage1 (rest (first l))) "]*" (command-usage (rest l)))) ((at-least-one) (string-append " [" (command-usage1 (rest (first l))) "]+" (command-usage (rest l)))) ((at-most-one) (string-append " [" (command-usage1 (rest (first l))) "]" (command-usage (rest l)))) ((exactly-one) (string-append " " (command-usage1 (rest (first l))) (command-usage (rest l)))) ((required) (string-append " " (second (second (first l))) (command-usage (rest l)))) ((optional) (string-append " [" (second (second (first l))) (command-usage (rest l)) "]")) ((rest) (string-append " [" (second (second (first l))) "]*")) (else (fuck-up))))) (define (command-bindings l) (if (null? l) '() (case (first (first l)) ((any-number at-least-one) (append (map-reduce append '() (lambda (l) (cons (list (second l) #f) (map (lambda (l) (list (first l) ''())) (rest (rest l))))) (rest (first l))) (command-bindings (rest l)))) ((at-most-one exactly-one) (append (map-reduce append '() (lambda (l) (cons (list (second l) #f) (map (lambda (l) (list (first l) (fourth l))) (rest (rest l))))) (rest (first l))) (command-bindings (rest l)))) ((required) (cons (list (first (second (first l))) #f) (command-bindings (rest l)))) ((optional) (cons (list (first (second (first l))) (fourth (second (first l)))) (command-bindings (rest l)))) ((rest) (cons (list (first (second (first l))) ''()) (command-bindings (rest l)))) (else (fuck-up))))) (define (command-keyword-argument-parser l) (cons `(let loop () (unless (null? arguments) (cond ,@(let loop ((l l)) (if (null? l) '(((string=? (first arguments) "-usage") (usage))) (case (first (first l)) ((any-number at-least-one) (append (map (lambda (l) `((string=? (first arguments) ,(string-append "-" (first l))) (set! arguments (rest arguments)) (set! ,(second l) #t) ,@(map-reduce append '() (lambda (l) `((when (null? arguments) (usage)) (set! ,(first l) (cons (,(third l) (first arguments) usage) ,(first l))) (set! arguments (rest arguments)))) (rest (rest l))) (loop))) (rest (first l))) (loop (rest l)))) ((at-most-one exactly-one) (append (map (lambda (l1) `((string=? (first arguments) ,(string-append "-" (first l1))) (set! arguments (rest arguments)) (when (or ,@(map second (rest (first l)))) (usage)) (set! ,(second l1) #t) ,@(map-reduce append '() (lambda (l) `((when (null? arguments) (usage)) (set! ,(first l) (,(third l) (first arguments) usage)) (set! arguments (rest arguments)))) (rest (rest l1))) (loop))) (rest (first l))) (loop (rest l)))) ((required optional rest) (loop (rest l))) (else (fuck-up)))))))) (let loop ((l l)) (if (null? l) '() (case (first (first l)) ((at-least-one exactly-one) (cons `(unless (or ,@(map second (rest (first l)))) (usage)) (loop (rest l)))) ((at-most-one any-number required optional rest) (loop (rest l))) (else (fuck-up))))))) (define (command-positional-argument-parser l) (let loop ((l l)) (if (null? l) '((unless (null? arguments) (usage))) (case (first (first l)) ((any-number at-least-one at-most-one exactly-one) (loop (rest l))) ((required) (append `((when (null? arguments) (usage)) (set! ,(first (second (first l))) (,(third (second (first l))) (first arguments) usage)) (set! arguments (rest arguments))) (loop (rest l)))) ((optional) (cons `(unless (null? arguments) (set! ,(first (second (first l))) (,(third (second (first l))) (first arguments) usage)) (set! arguments (rest arguments))) (loop (rest l)))) ((rest) `((let loop () (unless (null? arguments) (set! ,(first (second (first l))) (cons (,(third (second (first l))) (first arguments) usage) ,(first (second (first l))))) (set! arguments (rest arguments)) (loop))))) (else (fuck-up)))))) (expander `(define (,(first (second form)) arguments) (define (string-argument string usage) string) (define (integer-argument string usage) (let ((integer (string->number string))) (unless (integer? integer) (usage)) integer)) (define (real-argument string usage) (let ((real (string->number string))) (unless (real? real) (usage)) real)) (let ((program (first arguments))) (define (usage) (format stderr-port ,(string-append "usage: ~a" (command-usage (rest (second form))) "~%") program) (exit -1)) (set! arguments (rest arguments)) (let ,(command-bindings (rest (second form))) ,@(command-keyword-argument-parser (rest (second form))) ,@(command-positional-argument-parser (rest (second form))) ,@(rest (rest form))))) expander))) (set! *program* "sch") (set! *panic?* #t) ;;; Procedures (define (proper-module-declaration main? pathname pathnames) (if main? `(module ,(string->symbol (string-upcase (strip-directory (strip-extension pathname)))) (with ,@(append '(QobiScheme xlib) (map (lambda (pathname) (string->symbol (string-upcase (strip-directory (strip-extension pathname))))) pathnames))) (main main)) `(module ,(string->symbol (string-upcase (strip-directory (strip-extension pathname))))))) (define (module-declaration pathname) (call-with-input-file (default-extension pathname "sc") (lambda (input-port) (let ((expression (read input-port))) (and (not (eof-object? expression)) (list? expression) (>= (length expression) 1) (eq? (first expression) 'module) expression))))) (define (enforce-proper-module-declaration main? pathname pathnames) (let ((module-declaration (module-declaration pathname))) (unless (and module-declaration (equal? module-declaration (proper-module-declaration main? pathname pathnames))) (let ((lines (call-with-input-file (default-extension pathname "sc") (lambda (input-port) (when module-declaration (read input-port) ;; To get rid of the newline at the end of the module ;; declaration. (read-line input-port)) (let loop ((lines '()) (line (read-line input-port))) (if (eof-object? line) (reverse lines) (loop (cons line lines) (read-line input-port)))))))) (call-with-output-file (default-extension pathname "sc") (lambda (output-port) (pp (proper-module-declaration main? pathname pathnames) output-port) (newline output-port) (for-each (lambda (line) (display line output-port) (newline output-port)) lines))))))) (define (symbols-in-file pathname) (let ((symbols '())) (define (walk expression) (cond ((symbol? expression) (unless (memq expression symbols) (set! symbols (cons expression symbols)))) ((pair? expression) (walk (first expression)) (walk (rest expression))))) (call-with-input-file (default-extension pathname "sc") (lambda (input-port) (let loop () (let ((expression (read input-port))) (unless (eof-object? expression) (walk expression) (loop)))))) symbols)) (define (needed-definitions-in-file pathname symbols) (unless (equal? (module-declaration pathname) (proper-module-declaration #f pathname '())) (panic "~a contains a missing or improper MODULE declaration" pathname)) (call-with-input-file (default-extension pathname "sc") (lambda (input-port) (let ((module (second (read input-port)))) (let loop () (let ((definition (read input-port))) (if (eof-object? definition) '() (cond ((and (pair? definition) (eq? (first definition) 'define) (pair? (rest definition)) (memq (if (pair? (second definition)) (first (second definition)) (second definition)) symbols)) (cons `(define-external ,(second definition) ,module) (loop))) ((and (pair? definition) (eq? (first definition) 'define-structure) (or (memq (string->symbol (string-append "MAKE-" (symbol->string (second definition)))) symbols) (memq (string->symbol (string-append (symbol->string (second definition)) "?")) symbols) (some (lambda (slot) (or (memq (string->symbol (string-append (symbol->string (second definition)) "-" (symbol->string slot))) symbols) (memq (string->symbol (string-append "SET-" (symbol->string (second definition)) "-" (symbol->string slot) "!")) symbols) (memq (string->symbol (string-append "LOCAL-SET-" (symbol->string (second definition)) "-" (symbol->string slot) "!")) symbols))) (rest (rest definition))))) (cons `(define-structure-external ,module ,@(rest definition)) (loop))) (else (loop)))))))))) (define (needed-definitions-in-files pathnames symbols) (reduce append (map (lambda (pathname) (needed-definitions-in-file pathname symbols)) pathnames) '())) (define (read-target pathname) (call-with-input-file pathname (lambda (input-port) (let loop () (let ((definition (read input-port))) (if (eof-object? definition) '() (cons definition (loop)))))))) ;;; Top Level (define-command (main (at-most-one ("main" main?)) (required (pathname "pathname" string-argument)) (rest (pathnames "pathname" string-argument))) ;; needs work: This is needed because of a bug in QobiScheme. (let ((pathnames (reverse pathnames))) (enforce-proper-module-declaration main? pathname pathnames) (for-each (lambda (pathname) (enforce-proper-module-declaration #f pathname '())) pathnames) (let* ((symbols (symbols-in-file pathname)) (target-pathname (replace-extension pathname "sch")) (new-definitions (needed-definitions-in-files pathnames symbols))) (when (or (not (can-open-file-for-input? target-pathname)) (not (equal? new-definitions (read-target target-pathname)))) (call-with-output-file target-pathname (lambda (output-port) (for-each (lambda (definition) (write definition output-port) (newline output-port)) new-definitions))))))) ;;; Tam V'Nishlam Shevah L'El Borei Olam scheme2c-2012.10.14/cdecl/sizeof.c000066400000000000000000000051151203736146400163200ustar00rootroot00000000000000/* Generate the structure offset and type information required by the cdecl compiler. */ #include typedef (*pp)(); struct {char dummy; char x; char dummy2;} c1; struct {char dummy; short x; char dummy2;} s1; struct {char dummy; unsigned short x; char dummy2;} us1; struct {char dummy; int x; char dummy2;} i1; struct {char dummy; unsigned x; char dummy2;} u1; struct {char dummy; long x; char dummy2;} l1; struct {char dummy; unsigned long x; char dummy2;} ul1; struct {char dummy; float x; char dummy2;} f1; struct {char dummy; double x; char dummy2;} d1; struct {char dummy; char* x; char dummy2;} cp1; struct {char dummy; pp x; char dummy2;} pp1; int main() { char *toref, *toset; printf( "(sizeof char %i %li c-byte-ref c-byte-set!)\n", sizeof( char ), ((long)&c1.x)-((long)&c1) ); printf( "(sizeof shortint %i %li c-shortint-ref c-shortint-set!)\n", sizeof( short ), ((long)&s1.x)-((long)&s1) ); printf( "(sizeof shortunsigned %i %li c-shortunsigned-ref c-shortunsigned-set!)\n", sizeof( unsigned short ), ((long)&us1.x)-((long)&us1) ); printf( "(sizeof int %i %li c-int-ref c-int-set!)\n", sizeof( int ), ((long)&i1.x)-((long)&i1) ); printf( "(sizeof unsigned %i %li c-unsigned-ref c-unsigned-set!)\n", sizeof( unsigned ), ((long)&u1.x)-((long)&u1) ); printf( "(sizeof longint %i %li c-longint-ref c-longint-set!)\n", sizeof( long ), ((long)&l1.x)-((long)&l1) ); printf( "(sizeof longunsigned %i %li c-longunsigned-ref c-longunsigned-set!)\n", sizeof( long ), ((long)&ul1.x)-((long)&ul1) ); printf( "(sizeof float %i %li c-float-ref c-float-set!)\n", sizeof( float ), ((long)&f1.x)-((long)&f1) ); printf( "(sizeof double %i %li c-double-ref c-double-set!)\n", sizeof( double ), ((long)&d1.x)-((long)&d1) ); if (sizeof( char* ) == sizeof( unsigned short )) { toref = "c-shortunsigned-ref"; toset = "c-shortunsigned-set!"; } else if (sizeof( char* ) == sizeof( unsigned )) { toref = "c-unsigned-ref"; toset = "c-unsigned-set!"; } else { toref = "c-longunsigned-ref"; toset = "c-longunsigned-set!"; } printf( "(sizeof pointer %i %li %s %s)\n", sizeof( char* ), ((long)&cp1.x)-((long)&cp1), toref, toset ); if (sizeof( pp ) == sizeof( unsigned short )) { toref = "c-shortunsigned-ref"; toset = "c-shortunsigned-set!"; } else if (sizeof( pp ) == sizeof( unsigned )) { toref = "c-unsigned-ref"; toset = "c-unsigned-set!"; } else { toref = "c-longunsigned-ref"; toset = "c-longunsigned-set!"; } printf( "(sizeof procedure %i %li %s %s)\n", sizeof( pp ), ((long)&pp1.x)-((long)&pp1), toref, toset ); return 0; } scheme2c-2012.10.14/cdecl/typedef.sc000066400000000000000000000421431203736146400166460ustar00rootroot00000000000000;;; C Declaration Language ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. ;;; This module compiles type and sizeof 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 ;;; longint ;;; longunsigned ;;; float ;;; double ;;; ;;; ;;; ::= denoting another type ;;; ;;; ::= ( struct [ ...] ) ;;; ( union [ ...] ) ;;; ;;; ::= ( ) ;;; ;;; Sizeof declarations define the basic C types. They are automatically ;;; produced by the program "sizeof". (module typedef) ;;; Type definition expressions from the input file are parsed by the ;;; following expression. It will return the type name on success, or ;;; call error on an error. (define (INPUT-TYPEDEF exp) (if (and (= (length exp) 3) (eq? (car exp) 'typedef) (symbol? (caddr exp))) (let ((id (caddr exp)) (parse (parse-type (cadr exp)))) (putprop id 'base-type #f) (putprop id 'type parse) (if (and (pair? parse) (symbol? (car parse)) (eq? (cadr parse) '*)) (putprop (car parse) 'pointed-to-by id)) id) (error 'input-typedef "Illegal syntax: ~s" exp))) ;;; 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)) ((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 'base-type #f) (putprop symbol 'type parse) symbol)))))) ;;; MACHINE DEPENDENT SIZEOF declarations are processed here. (define (INPUT-SIZEOF exp) (let ((type (list-ref exp 1)) (size (list-ref exp 2)) (align (list-ref exp 3)) (to-get (list-ref exp 4)) (to-set! (list-ref exp 5))) (putprop type 'type #t) (putprop type 'base-type type) (putprop type 'size size) (putprop type 'align align) (putprop type 'to-get to-get) (putprop type 'to-set! to-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 'base-type) (let loop ((type start-type) (count 20)) (let ((typeinfo (getprop type '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 'base-type type)))))) ;;; Basic information about a type is returned by: (define (ISA-UNION? type) (let ((typeinfo (getprop (base-type type) 'type))) (and (pair? typeinfo) (eq? (car typeinfo) 'union)))) (define (ISA-STRUCT? type) (let ((typeinfo (getprop (base-type type) 'type))) (and (pair? typeinfo) (eq? (car typeinfo) 'struct)))) (define (UORS-SLOTS type) (cadr (getprop (base-type type) 'type))) (define (ISA-PROCP? type) (let ((typeinfo (getprop (base-type type) 'type))) (and (pair? typeinfo) (eq? (cadr typeinfo) '*proc)))) (define (PROCP-RETURNS type) (base-type (car (getprop (base-type type) 'type)))) (define (ISA-POINTER? type) (let ((typeinfo (getprop (base-type type) 'type))) (and (pair? typeinfo) (eq? (cadr typeinfo) '*)))) (define (POINTER-TO type) (base-type (car (getprop (base-type type) 'type)))) (define (ISA-ARRAY? type) (let ((typeinfo (getprop (base-type type) 'type))) (and (pair? typeinfo) (number? (cadr typeinfo))))) (define (ARRAY-SIZE type) (cadr (getprop (base-type type) 'type))) (define (ARRAY-TYPE type) (base-type (car (getprop (base-type type) 'type)))) (define (POINTED-TO-BY type) (base-type (getprop (base-type type) 'pointed-to-by))) ;;; Given this information, we can now compute sizes of things. (define (ALIGNED-SIZE-OF type) (let* ((size-align (size-alignment-of type)) (size (car size-align)) (align (cadr size-align))) (* align (quotient (+ size align -1) align)))) (define (SIZE-OF type) (car (size-alignment-of type))) (define (ALIGNMENT-OF type) (cadr (size-alignment-of type))) (define (SIZE-ALIGNMENT-OF type) (let ((base (base-type type))) (cond ((getprop base 'size) `(,(getprop base 'size) ,(getprop base 'align))) ((isa-union? type) (let ((size 0) (align 0)) (for-each (lambda (slot) (let ((size-align (size-alignment-of (car slot)))) (set! size (max size (car size-align))) (set! align (max align (cadr size-align))))) (uors-slots type)) `(,size ,align))) ((isa-struct? type) (let ((size 0) (align 0)) (for-each (lambda (slot) (let* ((size-align (size-alignment-of (car slot))) (ssize (car size-align)) (salign (cadr size-align))) (if (not (zero? (remainder size salign))) (set! size (+ size (- salign (remainder size salign))))) (set! size (+ size ssize)) (set! align (max align salign)))) (uors-slots type)) `(,size ,align))) ((isa-procp? type) (size-alignment-of 'procedure)) ((isa-pointer? type) (size-alignment-of 'pointer)) ((isa-array? type) (let ((size-align (size-alignment-of (array-type type)))) `(,(* (array-size type) (car size-align)) ,(cadr size-align)))) (else (error 'size-alignment-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 'to-get)) ((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) (cons ',base (,(to-get-type 'pointer) x y)))) ((isa-procp? base) `(lambda (x y) (cons ',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 'to-set!)) ((isa-array? base) `(lambda (x y i z) (,(to-set!-type (array-type base)) x (+ y (* ,(size-of (array-type base)) i)) 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 uninterned symbol. (define (UIS . syms) (string->uninterned-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 type-file-root) (let ((check (open-output-file (string-append type-file-root ".sc"))) (external (open-output-file (string-append type-file-root ".sch"))) (type-module (uis type-file-root))) (define (EMIT-TYPE type read-only) (cond ((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 type-file-root)) ((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) (pp exp check) (newline check) (pp `(define-external ,(cadr exp) ,type-module) external) (newline external)) (format check "(module ~a)~%~%" type-module) (for-each (lambda (type) (unless (or (memq type define-only) (not (eq? type (base-type type)))) (emit-type type (memq type read-only)))) types) (close-port check) (close-port external))) ;;; 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) (def-print `(define (,(uis "CHK-" (type-tag type)) x) (if (and (pair? x) (eq? (car x) ',(type-tag type))) (cdr x) (error ',(uis "CHK-" (type-tag type)) "Argument is incorrect type: ~s" x)))) (def-print `(define (,(uis "ISA-" (type-tag type) "?") x) (and (pair? x) (eq? (car 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))) (def-print `(define (,(uis type "-LENGTH") x) (quotient (string-length (,chk x)) ,(size-of entry-type)))) (cond ((or (isa-struct? entry-type) (isa-union? entry-type)) (def-print `(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 (cons ',(pointed-to-by entry-type) (substring array x (+ x esize))) (loop (+ x esize)))))))) (def-print `(define (,(uis entry-type "-LIST->" type) x) (cons ',pointer (apply string-append (map ,(to-check-type (pointed-to-by entry-type)) x)))))) (else (def-print `(define (,type x i) (,(to-get-type type) (,chk x) 0 i))) (def-print `(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)))))) (def-print `(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)))) (def-print `(define (,(uis type "!") x i z) (,(to-set!-type type) (,chk x) 0 i z))) (def-print `(define (,(uis "MAKE-" type) ,@(if (eq? size 0) '(x) '())) (cons ',pointer (make-string (* ,(size-of entry-type) ,(if (eq? size 0) 'x size)) (integer->char 0))))))))) ;;; Write the source file containing the struct definition. (define (EMIT-STRUCT-PROCS pointer read-only type-file-root) (let* ((type (pointer-to pointer)) (slots (uors-slots type))) (if slots (let* ((type-module (list->string (map char-downcase (string->list (symbol->string type))))) (code-port (open-output-file (string-append type-module ".sc"))) (extern-port (open-output-file (string-append type-module ".sch")))) (define (DEF-PRINT exp) (pp exp code-port) (newline code-port) (format extern-port "(define-external ~s ~a)~%" (cadr exp) type-module)) (format code-port "(module ~a)~%" type-module) (format code-port "(include ~s)~%" (string-append type-file-root ".sch")) (def-print `(define (,(uis "MAKE-" type)) (cons ',pointer (make-string ,(aligned-size-of type) (integer->char 0))))) (slot-getset type type 0 pointer read-only def-print) (close-port code-port) (close-port extern-port))))) ;;; 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) '()))) (def-print `(define (,(uis preamble "-" name) x ,@index) (,(to-get-type type) (,(to-check-type base-type) x) ,offset ,@index))) (unless read-only (def-print `(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)) (size-align (size-alignment-of slot-type)) (size (car size-align)) (align (cadr size-align))) (unless (zero? (remainder offset align)) (set! offset (+ offset (- align (remainder offset align))))) (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))))))) scheme2c-2012.10.14/doc/000077500000000000000000000000001203736146400143465ustar00rootroot00000000000000scheme2c-2012.10.14/doc/README000066400000000000000000000010521203736146400152240ustar00rootroot00000000000000This directory contains documentation for Scheme->C. embedded.tex LaTeX document describing embedding Scheme->C inside an application. index.tex a LaTeX reference document for the language which is in the form of an annoted index to the Revised**4 Scheme standard. intro.tex a LaTeX document introducing Scheme->C. r4rs/ the R4RS scheme standard in LaTeX. scc.l UNIX man page for the Scheme->C compiler. sci.l UNIX man page for the Scheme->C interpreter. smithnotes.tex notes to accompany "An Introduction to Scheme" by Jerry D. Smith. scheme2c-2012.10.14/doc/embedded.tex000066400000000000000000000234351203736146400166300ustar00rootroot00000000000000\documentclass[12pt]{article} \usepackage{fullpage} \usepackage{parskip} \usepackage{newcent} \usepackage{s2c} \title{Embedded \StoC\ --- 1 February 1993} \date{} \author{Joel F. Bartlett} \begin{document} \maketitle One of the major goals of \StoC\ was to build a Scheme compiler and runtime system that could coexist with other programming languages. While this effort has been quite successful, \StoC\ has not offered everything needed by applications that wish to embed a Scheme server, feed it arbitrary expressions for evaluation, yet remain responsive to additional requests. For example, a database server might want to to evaluate arbitrary Scheme expressions to verify record update operations, record access rights, or provide data that is computed rather than being resident in the database. Or, an event driven application for a PC or a Macintosh might like to embed Scheme. In order to safely execute in such a variety of environments, the Scheme system must allow the application to handle external events on a timely basis and place minimum requirements on the available system services. In order to solve these problems, the 01feb93 release of \StoC\ has been modified in the following areas. \begin{description} \item[Explicit Time Slicing:] In order to return to the caller at regular intervals, \StoC\ can be compiled with explicit time slicing. On each procedure entry or backwards branch, a counter is decremented. When the counter goes to 0, Scheme returns control to the application program at the point where it was called. At a later time, the application has the option of continuing the previous computation or starting a new computation. \item[Explicit Stack Overflow Checks:] \StoC\ may be compiled with explicit stack overflow checks. This is necessary as many environments have no other means for detecting a stack overflow which could damage the embedding application or crash the personal computer. \item[Request-response interaction:] When used as an embedded server, all interaction with Scheme is via one interface procedure. Errors and breakpoints are handled across this interface like any other type of request. \item[Operating System independence:] Unlike previous releases, \StoC\ does not assume the existence of a UNIX-like I/O system. Rather than directly calling the host I/O system, all requests are via implementation specific routines in scrt/cio.c. In fact, an embedded \StoC\ server doesn't assume that the client even has an I/O system. Instead the stdout and stderr ports are string output ports. \item[Traps:] Previous releases of \StoC\ used operating system traps to detect division by zero and keyboard interrupts. Division by zero errors are now explicitly tested for, and keyboard interrupt signals are not used by embedded \StoC\ systems. \end{description} \subsection*{Application interface} Applications evaluate a Scheme expression by calling the procedure \texttt{scheme2c}: \begin{quote} \begin{verbatim} void scheme2c( char *expression, int *status, char **result, char **error ) \end{verbatim} \end{quote} where \texttt{expression} is a pointer to a null terminated string of ASCII characters that is the Scheme expression to evaluate. When the procedure returns, the result is stored in \texttt{status}, \texttt{result}, and \texttt{error}. The value returned in \texttt{status} is interpreted as follows: \begin{itemize} \item[\texttt{0}:] expression evaluated normally. The value is saved in \texttt{*SCHEME2C-RESULT*} within the Scheme system and it is also written to Scheme's stdout-port. \item[\texttt{1}:] an error occurred. The error message is written to Scheme's stderr-port. If no previous error is being examined, the stack trace is written to Scheme's stderr-port and the associated environments are in the list \texttt{*ERROR-ENV*}. The client should evaluate \texttt{(RESET-ERROR)} when done examining the error state. Note that if additional errors occur before \texttt{(RESET-ERROR)} is evaluated, they will not cause a stack dump, nor have the error environment saved. \item[\texttt{2}:] an internal error in \StoC\ occurred. The error message is reported via Scheme's stderr-port. No further execution is possible. \item[\texttt{3}:] the computation timed out. Evaluate \texttt{(PROCEED)} to continue execution. Evaluate \texttt{(PROCEED?)} to cause a breakpoint when execution resumes. \item[\texttt{4}:] a procedure entry breakpoint occurred. The call arguments are written to Scheme's stderr-port and the associated environments are in the list \texttt{*BPT-ENV*}. The procedure stack trace can be viewed by evaluating \texttt{(BACKTRACE)}. The procedure arguments are in \texttt{*ARGS*}. Evaluate \texttt{(PROCEED)} to continue execution, or \texttt{(RESET-BPT)} to abort. \item[\texttt{5}:] a procedure exit breakpoint occurred. The result is written to Scheme's stderr-port and saved in \texttt{*RESULT*}. The environments are in the list \texttt{*BPT-ENV*}. Evaluate \texttt{(PROCEED)} to continue execution, \texttt{(PROCEED \textnormal{\emph{expression}})} to continue returning a new value, or \texttt{(RESET-BPT)} to abort. Note that additional breakpoints will not occur while examining the state of a breakpoint. \end{itemize} The value returned in \texttt{result} is pointer to a null terminated string of ASCII characters that is the contents of Scheme's stdout-port, i.e. the standard output port. The value retirned in \texttt{error} is a pointer to a null terminated string of ASCII characters that is the contents of Scheme's stderr-port, i.e. the error output port. The stack size which is used by an embedded Scheme system is set by evaluating \texttt{(set-stack-size!\ \textnormal{\emph{expression}})}, where \emph{expression} is the size in bytes. The current stack size can be obtained by evaluating \texttt{(stack-size)}. Scheme reserves a portion of this stack for error recovery, but this may be exceeded on some implementations. An application should verify that it has set the stack correctly by evaluating an expression that forces a stack overflow error and then verifying that the Scheme stack has not overflowed into the application. The Scheme time slice is set by evaluating \texttt{(set-time-slice!\ \textnormal{\emph{expression}})}, where \emph{expression} is the number of Scheme procedure calls that should be made in a time slice. Experiment to find the right value for your application. The current time slice value is obtained by evaluating \texttt{(time-slice)}. \subsection*{Sample embedded application} A sample embedded Scheme application, \texttt{embedded}, is found in the directory \texttt{scrt}. A typescript of its execution shows how an application should interact with an embedded Scheme system. \begin{quote} \begin{verbatim} $ embedded Embedded Scheme->C Test Bed 0- (+ 1 2) 3 0- \end{verbatim} \end{quote} The program prompts the user for a Scheme expression which is then evaluated using \texttt{scheme2c}. The \texttt{result} and \texttt{error} messages are then printed, followed by a prompt (incorporating the value of \texttt{status}) for the next expression. \begin{quote} \begin{verbatim} 0- (time-slice) 100000 0- (stack-size) 57000 0- (let loop ((i 0)) (loop (+ i 1))) 3- (proceed) 3- (proceed) 3- (proceed?) (+ I 1) in ENV-0 (LOOP (+ I 1)) in ENV-1 (EVAL ...) (EXECUTE [inside SCHEME2C] ...) (SCREP_SCHEME2C ...) 4- \end{verbatim} \end{quote} After obtaining the current time slice and stack size values, a looping expression was entered. Twice it timed out and was continued by evaluating the expression \texttt{(proceed)}. The third time it timed out, \texttt{(proceed?)} was entered to force a breakpoint. \begin{quote} \begin{verbatim} 4- (list-ref *bpt-env* 0) ((I . 21345) (LOOP . #*PROCEDURE*) ($_0 . 0)) 0- (proceed) 3- (proceed?) (LOOP (+ I 1)) in ENV-0 (EVAL ...) (EXECUTE [inside SCHEME2C] ...) (SCREP_SCHEME2C ...) 4- (list-ref *bpt-env* 0) ((I . 28476) (LOOP . #*PROCEDURE*) ($_0 . 0)) 0- (reset-bpt) #F 0- \end{verbatim} \end{quote} The environment at the time of the breakpoint was examined to find the value of \texttt{i} by looking at element 0, corresponding to \texttt{env-0}, of the list \texttt{*bpt-env*}. The program was then contined by \texttt{(proceed)} and then \texttt{i} was examined at the end of the next time slice to find out how much work was done. \begin{quote} \begin{verbatim} 0- (let ((x 1) (y 2)) (+ x y z)) ***** Z Top-level symbol is undefined (+ X Y Z) in ENV-0 (EVAL ...) (EXECUTE [inside SCHEME2C] ...) (SCREP_SCHEME2C ...) 1- *bptenv* ***** *BPTENV* Top-level symbol is undefined 0- *error-env* (((Y . 2) (X . 1))) 0- (reset-error) #F 0- \end{verbatim} \end{quote} An error occurred and then error environment was examined. While examining the error environment, another error occurred. This simply resulted in an error message. \begin{quote} \begin{verbatim} 0- (define (f x) (* 2 x)) F 0- (bpt f) F 0- (f 23) 0 -calls - (F 23) 4- (proceed) 0 -returns- 46 5- (proceed) 46 0- (f 40) 0 -calls - (F 40) 4- (f 10) 20 0- (proceed) 0 -returns- 80 5- (proceed 15) 15 0- \end{verbatim} \end{quote} The final example shows the use of procedure breakpoints. One thing to note, is that breakpoints do not nest. \subsection*{Adding Your Code to an Embedded \StoC\ System} There are two ways to do this. The easiest is to replace the module scrtuser (in the files scrtuser.sc and scrtuser.c) and then rebuild the embedded Scheme system. An alternative is to separately compile your modules, link them into your application, and then explicitly initialize your modules after Scheme has been initialized. This is done by calling \texttt{scheme2c} with an expression like \texttt{"\#t"} and then calling your module initialization procedures which have the form \emph{module-name}\texttt{\_\_init}. \end{document} scheme2c-2012.10.14/doc/index.tex000066400000000000000000002641201203736146400162040ustar00rootroot00000000000000\documentclass[10pt,twocolumn]{article} \usepackage{fullpage} \usepackage{parskip} \usepackage{textcomp} \usepackage{newcent} \usepackage{s2c} \title{\StoC\ Index to the\\ Revised$^4$ Report on the Algorithmic Language Scheme} \author{Joel F. Bartlett} \date{15 March 1993} \begin{document} \maketitle \section*{Implementation Notes} \StoC\ is an implementation of the language Scheme as described in the \emph{Revised$^4$ Report on the Algorithmic Language Scheme} (\emph{LISP Pointers}, Volume IV, Number 3, July-September 1991). The implementation is known to not conform to the required portions of the report in the following ways: \begin{itemize} \item The syntax for numbers reflects the underlying C implementation. Scheme programs may not use the numeric prefixes \texttt{\#i} and \texttt{\#e}, and numbers may not contain \texttt{\#} as a digit. \item Numerical input and output uses the facilities of the underlying C implementation. As a result, the constraints of section 6.5.6 may not be satisfied. \item As /, quotient, and remainder depend upon C's behavior for negative fixed arguments (which is undefined), those doing ports must verify their correct operation. \item Implementations that do not handle arithmetic overflow traps may return incorrect results when an overflow occurred during the operation. \item The control flow of compiled programs is constrained by the underlying C implementation. As a result, some tail calls are not compiled as tail calls. \end{itemize} The implementation has been extended beyond the report in the following ways: \begin{itemize} \item Additional procedures: \begin{verbatim} %list->record %record %record->list %record-length %record-lookup-method %record-methods %record-methods-set! %record-ref %record-set! %record? after-collect backtrace bit-and bit-lsh bit-not bit-or bit-rsh bit-xor c-byte-ref c-byte-set! c-double-ref c-double-set! c-float-ref c-float-set! c-int-ref c-int-set! c-longint-ref c-longint-set! c-longunsigned-ref c-longunsigned-set! c-s2cuint-ref c-s2cuint-set! c-shortint-ref c-shortint-set! c-shortunsigned-ref c-shortunsigned-set! c-sizeof-double c-sizeof-float c-sizeof-int c-sizeof-long c-sizeof-s2cuint c-sizeof-short c-sizeof-tscp c-string->string c-tscp-ref c-tscp-set! c-unsigned-ref c-unsigned-set! catch-error close-port collect collect-all collect-info cons* define-system-file-task echo enable-sytem-file-tasks error eval exit expand expand-once fixed->float fixed? float->fixed float? flush-buffer format get-output-string getprop getprop-all implementation-information last-pair open-file open-input-string open-output-string optimize-eval port->stdio-file pp proceed proceed? putprop read-eval-print remove remove! remq remq! remv remv! remove-file rename-file reset reset-bpt reset-error scheme-byte-ref scheme-byte-set! scheme-int-ref scheme-int-set! scheme-s2cuint-ref scheme-s2cuint-set! scheme-tscp-ref scheme-tscp-set! set-gcinfo! set-generation-limit! set-maximum-heap! set-stack-size! set-time-slice! set-top-level-value! set-write-circle! set-write-length! set-write-level! set-write-pretty! set-write-width! signal stack-size string->uninterned-symbol system time-of-day time-slice top-level top-level-value uninterned-symbol? wait-system-file weak-cons when-unreferenced write-circle write-count write-length write-level write-pretty write-width \end{verbatim} \item Additional syntax: \begin{verbatim} bpt define-c-external define-constant define-external define-in-line define-macro include module trace untrace unbpt unless when \end{verbatim} \item Additional variables: \begin{verbatim} %record-prefix-char %record-read *args* *bpt-env* debug-output-port *error-env* *error-handler* *frozen-objects* *obarray* *result* *scheme2c-result* stderr-port stdin-port stdout-port trace-output-port \end{verbatim} \end{itemize} \section*{Index} \texttt{"} delimits strings. Inside a string constant, a \texttt{"} is represented by \texttt{\textbackslash"}, and a \texttt{\textbackslash} is represented by \texttt{\textbackslash\textbackslash}. \RRRRRS~25. \texttt{\#(} denotes the start of a vector. \RRRRRS~26. \texttt{\#\textbackslash}\emph{character} written notation for characters. \RRRRRS~24. \texttt{\#\textbackslash{}formfeed} ASCII form feed character (\#o14). \RRRRRS~24. \texttt{\#\textbackslash{}linefeed} ASCII line feed character (\#o12). \RRRRRS~24. \texttt{\#\textbackslash{}newline} new line character (\#o12). \RRRRRS~24. \texttt{\#\textbackslash{}return} ASCII carriage return character (\#o15). \RRRRRS~24. \texttt{\#\textbackslash{}space} ASCII space character (\#o40). \RRRRRS~24. \texttt{\#\textbackslash{}tab} ASCII tab character (\#o11). \RRRRRS~24. \texttt{\#b} binary radix prefix. \RRRRRS~20. \texttt{\#d} decimal radix prefix. \RRRRRS~20. \texttt{\#f} boolean constant for false. Note that while the empty list \texttt{()} is also treated as a false value in conditional expressions, it is not the same as \texttt{\#f}. \RRRRRS~13. \texttt{\#o} octal radix prefix. \RRRRRS~20. \texttt{\#t} boolean constant for true. \RRRRRS~13. \texttt{\#x} hex radix prefix. \RRRRRS~20. (\texttt{\%list->record} \emph{list}) returns a newly created \emph{record} whose elements are the members of \emph{list}. (\texttt{\%record} \emph{expression} ...)\ returns a newly created \emph{record} whose elements contain the given arguments. (\texttt{\%record->list} \emph{record}) returns a newly created \emph{list} of the objects contained in the elements of \emph{record}. (\texttt{\%record-length} \emph{record}) returns the number of elements in \emph{record}. (\texttt{\%record-lookup-method} \emph{record} \emph{method}) returns either the \emph{record}'s method \emph{procedure} or \texttt{\#f} when no method is defined for the method named \emph{method}. All records have defaults for the following methods: \texttt{\%to-display}, \texttt{to-equal?}, \texttt{\%to-eval}, and \texttt{\%to-write}. (\texttt{\%record-methods} \emph{record}) returns a list of \emph{pairs} that denote the methods for \emph{record}. Each \emph{pair} is composed of a \emph{symbol} denoting the method name and the method \emph{procedure}. (\texttt{\%record-methods-set!}\ \emph{record} \emph{methods}) sets the methods associated with \emph{record} to \emph{methods}, a \emph{list} of method \emph{pairs}. \texttt{\%record-prefix-char} is the character that denotes a \emph{record}. \texttt{\%record-read} is a \emph{procedure} that is called to read a \emph{record}. When \texttt{read} encounters the value of \texttt{\%read-prefix-char} following a \texttt{\#}, it calls \texttt{\%record-read} with the current \emph{input-port} as its argument to input the record. The value read is the value returned by this procedure. (\texttt{\%record-ref} \emph{record} \emph{integer}) returns the contents of element \emph{integer} of \emph{record}. The first element is 0. (\texttt{\%record-set!}\ \emph{record} \emph{integer}) sets element \emph{integer} of \emph{record} to \emph{expression}. (\texttt{\%record?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{record}. \texttt{\%to-display} method to \texttt{display} a \emph{record}. When \texttt{display} encounters a record, it calls the record's \texttt{\%to-display} method with the following arguments: the record, the output port, the number of spaces to indent (or \texttt{\#f}), the number of levels to print (or \texttt{\#f}), the length of lists, vectors, or records to print (or \texttt{\#f}), and a list of pairs, vectors, and records already seen (or \texttt{\#f}). The method returns either \texttt{\#f} indicating no further action is to be taken, or a pair indicating that the car of the pair is to be output. For example, if \texttt{\%record-prefix-char} is \texttt{\#\textbackslash\texttildelow}, the method could be: \texttt{(lambda (r port .\ ignore) (display "\#\texttildelow" port) (list (\%record->list r)))}. \texttt{\%to-equal?}\ method to compare a \emph{record} to any value using \texttt{equal?}. The method \emph{prediate} is called with the \emph{record} and the comparison value as its arguments. The default method is \texttt{eq?}. \texttt{\%to-eval} method to evaluate a \emph{record}. \texttt{Eval} evaluates a \emph{record} by returning the value of calling the \emph{record}'s \texttt{\%to-eval} method with the \emph{record} as the argument. The default method is \texttt{(lambda (x) x)}. \texttt{\%to-write} method to \texttt{write} a \emph{record}. When \texttt{write} encounters a record, it calls the record's \texttt{\%to-write} method with the following arguments: the record, the output port, the number of spaces to indent (or \texttt{\#f}), the number of levels to print (or \texttt{\#f}), the length of lists, vectors, or records to print (or \texttt{\#f}), and a list of pairs, vectors, and records already seen (or \texttt{\#f}). The method returns either \texttt{\#f} indicating no further action is to be taken, or a pair indicating that the car of the pair is to be output. For example, if \texttt{\%record-prefix-char} is \texttt{\#\textbackslash\texttildelow}, the method could be: \texttt{(lambda (r port .\ ignore) (display "\#\texttildelow" port) (list (\%record->list r)))}. \texttt{'}\emph{expression} abbreviation for (\texttt{quote} \emph{expression}). \RRRRRS~7, 16. (\texttt{*} \emph{number} ...)\ returns the product of its arguments. \RRRRRS~21. \texttt{*args*} arguments of the \emph{procedure} when a breakpoint has been hit. The value of this symbol will be used as the arguments when the user continues from the breakpoint. See \texttt{bpt}, \texttt{proceed}. \texttt{*bpt-env*} list of environments when a breakpoint is encountered in an embedded \StoC\ system. \texttt{*error-env*} list of environments when an error occurs in an embedded \StoC\ system. \texttt{*error-handler*} the error handling \emph{procedure}. See \texttt{error}. \texttt{*frozen-objects*} list of objects that are never moved by the garbage collector. Scheme programs can use this to ``lock down'' objects in memory before passing them to programs written in other languages. \texttt{*obarray*} is a vector of lists of symbols. It is used by \texttt{read} to assure that symbols written and then read back in are \texttt{eqv?}. See \emph{interned}, \RRRRRS~18. \texttt{*result*} result of the \emph{procedure} when a breakpoint has been hit. The value of this symbol be returned as the value of the \emph{procedure} after the user continues from the breakpoint. See \texttt{bpt}, \texttt{proceed}. \texttt{*scheme2c-result*} normal result of computation in an embedded \StoC\ system. \texttt{`}\emph{back-quote-template} abbreviation for (\texttt{quasiquote} \emph{back-quote template}). \RRRRRS~11. \texttt{(} used to group and notate lists. \RRRRRS~5. \texttt{()} the empty list. \RRRRRS~15. \texttt{)} used to group and notate lists. \RRRRRS~5. (\texttt{+} \emph{number} ...)\ returns the sum of its arguments. \RRRRRS~21. \texttt{,}\emph{expression} abbreviation for (\texttt{unquote} \emph{expression}) that causes the expression to be replaced by its value in the \emph{back-quote-template}. \RRRRRS~11. \texttt{,@}\emph{expression} abbreviation for (\texttt{unquote-splicing} \emph{expression}) that causes the expression to be evaluated and ``spliced'' into the \emph{back-quote-template}. \RRRRRS~11. (\texttt{-} \emph{number} \emph{number} ...)\ with two or more arguments, this returns the difference of its arguments, associating to the left. With one argument it returns the additive inverse of the argument. \RRRRRS~21. \texttt{-C} command line flag to \texttt{s2cc} that will cause the compiler to compile the Scheme files \emph{source}\texttt{.sc} to C source in \emph{source}\texttt{.c}. No further processing is performed. \texttt{-I} \emph{directory} command line flag to \texttt{s2cc} to supply a directory to be searched by \texttt{include} when it is looking for a source file. When multiple flags are supplied, the directories are searched in the order that the flags are specified. \texttt{-LIBDIR} \emph{directory} command line flag to \texttt{s2cc} to supply the \emph{directory} containing the files: predef.sc, objects.h, libs2c.a, and optionally libs2c\_p.a. \texttt{-Ob} command line flag to \texttt{s2cc} that controls bounds checking. When it is supplied to the compiler, no bounds checking code for \emph{vector} or \emph{string} accesses will be generated. Supplying this flag is equivalent to supplying the flags \texttt{-f '*bounds-check*' '\#f'}. \texttt{-Og} command line flag to \texttt{s2cc} that controls the generation of stack-trace debugging code. When it is supplied to the compiler, stack-trace code will not be generated. \texttt{-On} command line flag to \texttt{s2cc} that controls number representation. When it is supplied to the compiler, all numbers will be assumed to be \emph{fixed} integers. Supplying this flag is equivalent to supplying the flags \texttt{-f '*fixed-only*' '\#t'}. \texttt{-Ot} command line flag to \texttt{s2cc} that controls type error checking. When it is supplied, no error checking code will be generated. Supplying this flag is equivalent to supplying the flags \texttt{-f '*type-check*' '\#f'}. \texttt{-e} command line flag to \texttt{s2ci}. When it is supplied, all text read on the standard input file will be echoed on the standard output file. \texttt{-emacs} command line flag to \texttt{s2ci}. When supplied, the interpreter assumes that it is being run by GNU emacs. \texttt{-i} command line flag to \texttt{s2cc} that will combine the source and object files into a Scheme interpreter. Module names for files other than Scheme source files must be supplied using the \texttt{-m} command line flag. \texttt{-log} command line flag to \texttt{s2cc} to log information internal to the compiler. Each type of compiler information is denoted by one of the flags: \texttt{-source}, \texttt{-macro}, \texttt{-expand}, \texttt{-closed}, \texttt{-transform}, \texttt{-lambda}, \texttt{-tree}, \texttt{-lap}, \texttt{-peep}. The flag \texttt{-log} is equivalent to specifying the flags: \texttt{-source}, \texttt{-macro}, \texttt{-expand}, \texttt{-closed}, \texttt{-transform}, \texttt{-lambda}, and \texttt{-tree}. \texttt{-m} \emph{module} command line flag to \texttt{s2cc} to specify the name of a module that must be initialized by calling the procedure \emph{module\_\_init}. Note that the Scheme compiler will downshift the alphabetic characters in module names supplied in the \texttt{module} directive. Modules are initialized in the order that the \texttt{-m} command flags are specified. \texttt{-nh} command line flag to \texttt{s2ci}. When it is supplied, the interpreter version header will not be printed on the standard output file. \texttt{-np} command line flag to \texttt{s2ci}. When it is supplied, prompts for input from standard input will not be printed on standard output. \texttt{-q} command line flag to \texttt{s2ci}. When it is supplied, the result of each expression evaluation will not be printed on standard output. \texttt{-pg} command line flag to \texttt{s2cc} that will cause it to produce profiled code for run-time measurement using \emph{gprof}. The profiled library will be used in lieu of the standard Scheme library. \texttt{-scgc} \emph{flag} command line flag to any Scheme program that controls the reporting of garbage collection statistics. If \emph{flag} is set to 1, then garbage collection statistics will be printed on stderr. This flag will override \texttt{SCGCINFO}. \texttt{-sch} \emph{integer} command line flag to any Scheme program to set the initial heap size in megabytes. If it is not supplied, and the \texttt{SCHEAP} environment variable was not set, and the program did not have a default, then the implementation dependent default is used. This flag will override \texttt{SCHEAP}. \texttt{-scl} \emph{integer} command line flag to any Scheme program to set the full collection limit. When more than this percent of the heap is allocated following a generational garbage collection, then a full garbage collection will be done. The default value is 40. This flag will override \texttt{SCLIMIT}. \texttt{-scm} \emph{symbol} command line flag to any Scheme program to cause execution to start at the procedure that is the value of \emph{symbol}, rather than at the main program. Note that the Scheme \texttt{read} procedure typically upshifts alphabetic characters. Thus, to start execution in the Scheme interpreter, one would enter \texttt{-scm READ-EVAL-PRINT} on the command line. \texttt{-scmh} \emph{integer} command line flag to any Scheme program to set the maximum heap size in megabytes. If it is not supplied, and the \texttt{SCMAXHEAP} environment variable was not set, then the maximum heap size is five times the initial heap size. This flag will override \texttt{SCMAXHEAP}. \texttt{.}\ denotes a dotted-pair: (\emph{obj} \texttt{.}\ \emph{obj}). \RRRRRS~15. \texttt{.sc} file name extension for \StoC\ source files. (\texttt{/} \emph{number} ...)\ with two or more arguments, this returns the quotient of its arguments, associating to the left. With one argument it returns the multiplicative inverse of the argument. \RRRRRS~21. \texttt{;} indicates the start of a comment. The comment continues until the end of the line. \RRRRRS~5. (\texttt{<} \emph{number} \emph{number} \emph{number} ...)\ \emph{predicate} that returns \texttt{\#t} when the arguments are monotonically increasing. \RRRRRS~21. (\texttt{<=} \emph{number} \emph{number} \emph{number} ...)\ \emph{predicate} that returns \texttt{\#t} when the arguments are monotonically nondecreasing. \RRRRRS~21. (\texttt{=} \emph{number} \emph{number} \emph{number} ...)\ \emph{predicate} that returns \texttt{\#t} when the arguments are equal. \RRRRRS~21. \texttt{=>} used in a \texttt{cond} conditional clause. \RRRRRS~9. (\texttt{>} \emph{number} \emph{number} \emph{number} ...)\ \emph{predicate} that returns \texttt{\#t} when the arguments are monotonically decreasing. \RRRRRS~21. (\texttt{>=} \emph{number} \emph{number} \emph{number} ...)\ \emph{predicate} that returns \texttt{\#t} when the arguments are monotonically nonincreasing. \RRRRRS~21. \texttt{\textbackslash} tells \texttt{read} to treat the character that follows it as a letter when reading a symbol. If the character is a lower-case alphabetic character, it will not be upshifted. \RRRRRS~18. \texttt{\textbackslash"} represents a \texttt{"} inside a string constant. \RRRRRS~25. \texttt{\textbackslash\textbackslash} represents a \texttt{\textbackslash} inside a string constant. \RRRRRS~25. (\texttt{abs} \emph{number}) returns the magnitude of its argument. \RRRRRS~21. (\texttt{acos} \emph{number}) returns the arccosine of its argument. \RRRRRS~23. \texttt{after-collect} is a variable in the top level environment. Following each garbage collection, if its value is not \texttt{\#f}, then it is assumed to be a procedure and is called with three arguments: the heap size in bytes, the currently allocated storage in bytes, and the allocation percentage that will cause a full garbage collection. The value returned by the procedure is ignored. \emph{alist} a list of \emph{pairs}. \RRRRRS~17. (\texttt{and} \emph{expression} ...)\ \emph{syntax} for a conditional expression. \RRRRRS~9. (\texttt{append} \emph{list} ...)\ returns a list consisting of the elements of the first \emph{list} followed by the elements of the other \emph{lists}. \RRRRRS~17. (\texttt{apply} \emph{procedure} \emph{arg-list}) calls the \emph{procedure} with the elements of \emph{arg-list} as the actual arguments. \RRRRRS~27. (\texttt{apply} \emph{procedure} \emph{obj} ...\ \emph{arg-list}) calls the \emph{procedure} with the list (\texttt{append} (\texttt{list} \emph{obj} ...)\ \emph{arg-list}) as the actual arguments. \RRRRRS~27. (\texttt{asin} \emph{number}) returns the arcsine of its argument. \RRRRRS~23. (\texttt{assoc} \emph{obj} \emph{alist}) finds the first \emph{pair} in \emph{alist} whose \texttt{car} field is \texttt{equal?}\ to \emph{obj}. If no such \emph{pair} exists, then \texttt{\#f} is returned. \RRRRRS~17. (\texttt{assq} \emph{obj} \emph{alist}) finds the first \emph{pair} in \emph{alist} whose \texttt{car} field is \texttt{eq?}\ to \emph{obj}. If no such \emph{pair} exists, then \texttt{\#f} is returned. \RRRRRS~17. (\texttt{assv} \emph{obj} \emph{alist}) finds the first \emph{pair} in \emph{alist} whose \texttt{car} field is \texttt{eqv?}\ to \emph{obj}. If no such \emph{pair} exists, then \texttt{\#f} is returned. \RRRRRS~17. (\texttt{atan} \emph{number}) returns the arctangent of its argument. \RRRRRS~23. (\texttt{atan} \emph{number} \emph{number}) returns the arctangent of its arguments. \RRRRRS~23. (\texttt{backtrace}) displays the call stack where a breakpoint occurred. \emph{back-quote-template} list or vector structure that may contain \texttt{,}\emph{expression} and \texttt{,@}\emph{expression} forms. \RRRRRS~11. (\texttt{begin} \emph{expression} ...)\ \emph{syntax} where \emph{expression}'s are evaluated left to right and the value of the last \emph{expression} is returned. \RRRRRS~10. \emph{bindings} a \emph{list} whose elements are of the form: (\emph{symbol} \emph{expression}), where the \emph{expression} is the initial value to place in the location bound to the \emph{symbol}. \RRRRRS~10. (\texttt{bit-and} \emph{number} ...)\ returns an unsigned number representing the bitwise and of its 32-bit arguments. (\texttt{bit-lsh} \emph{number} \emph{integer}) returns an unsigned number representing the 32-bit value \emph{number} shifted left \emph{integer} bits. (\texttt{bit-not} \emph{number} ...)\ returns an unsigned number representing the bitwise not of its 32-bit argument. (\texttt{bit-or} \emph{number} ...)\ returns an unsigned number representing the bitwise inclusive or of its 32-bit arguments. (\texttt{bit-rsh} \emph{number} \emph{integer}) returns an unsigned number representing the 32-bit value \emph{number} shifted right \emph{integer} bits. (\texttt{bit-xor} \emph{number} ...)\ returns an unsigned number representing the bitwise exclusive or of its 32-bit arguments. \emph{body} one or more \emph{expressions} that are be executed in sequence. \RRRRRS~10. (\texttt{boolean?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} if \emph{expression} is \texttt{\#t} or \texttt{\#f}. \RRRRRS~13. (\texttt{bpt}) \emph{syntax} to return a list of the procedures that have been breakpointed. (\texttt{bpt} \emph{symbol}) \emph{syntax} to set a breakpoint on the \emph{procedure} that is the value of \emph{symbol}. Each entry and exit of the \emph{procedure} will provide the user with an opportunity to examine and alter the current state of the computation. For interactive \StoC\ systems, the computation is continued by entering control-D. The computation may be terminated and a return made to the top level of the interpreter by entering \texttt{(top-level)}. In embedded \StoC\ systems, \texttt{(proceed)} is used to continue the computation, and the computation is abandoned by evaluating \texttt{(reset-error)}.See \texttt{*args*}, \texttt{*result*}, \texttt{top-level}, \texttt{unbpt}. (\texttt{bpt} \emph{symbol} \emph{procedure}) \emph{syntax} to set a conditional breakpoint on the \emph{procedure} that is the value of \emph{symbol}. A breakpoint occurs when (\texttt{apply} \emph{procedure} \emph{arguments}) returns a true value. (\texttt{c-byte-ref} \emph{c-pointer} \emph{integer}) returns the byte at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-byte-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the byte at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. (\texttt{c-double-ref} \emph{c-pointer} \emph{integer}) returns the double at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-double-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the double at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. (\texttt{c-float-ref} \emph{c-pointer} \emph{integer}) returns the float at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-float-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the float at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. (\texttt{c-int-ref} \emph{c-pointer} \emph{integer}) returns the int at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-int-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the int at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. (\texttt{c-longint-ref} \emph{c-pointer} \emph{integer}) returns the long int at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-longint-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the long int at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. (\texttt{c-longunsigned-ref} \emph{c-pointer} \emph{integer}) returns the unsigned long at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-longunsigned-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the unsigned long at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. \emph{c-pointer} a \emph{number} that is the address of a structure outside the Scheme heap, or a \emph{string} that is a C-structure within the Scheme heap. (\texttt{c-s2cuint-ref} \emph{c-pointer} \emph{integer}) returns the S2CUINT at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-s2cuint-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the S2CUINT at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. (\texttt{c-shortint-ref} \emph{c-pointer} \emph{integer}) returns the short int at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-shortint-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the short int at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. (\texttt{c-shortunsigned-ref} \emph{c-pointer} \emph{integer}) returns the unsigned short at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-shortunsigned-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the unsigned short at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. \texttt{c-sizeof-double} size (in bytes) of the C type double. \texttt{c-sizeof-float} size (in bytes) of the C type float. \texttt{c-sizeof-int} size (in bytes) of the C type int. \texttt{c-sizeof-long} size (in bytes) of the C type long. \texttt{c-sizeof-s2cuint} size (in bytes) of the C type S2CUINT that is defined by \StoC\ to be an unsigned integer the same size as a pointer. \texttt{c-sizeof-short} size (in bytes) of the C type short. \texttt{c-sizeof-tscp} size (in bytes) of the C type TSCP that is defined by \StoC\ to represent tagged Scheme pointers. (\texttt{c-string->string} \emph{c-pointer}) returns a Scheme \emph{string} that is a copy of the null-terminated string \emph{c-pointer}. (\texttt{c-tscp-ref} \emph{c-pointer} \emph{integer}) returns the TSCP at the \emph{integer} byte of \emph{c-pointer}. (\texttt{c-tscp-set!}\ \emph{c-pointer} \emph{integer} \emph{expression}) sets the TSCP at the \emph{integer} byte of \emph{c-pointer} to \emph{expression} and returns \emph{expression} as its value. (\texttt{c-unsigned-ref} \emph{c-pointer} \emph{integer}) returns the unsigned at the \emph{integer} byte of \emph{c-pointer} as a \emph{number}. (\texttt{c-unsigned-set!}\ \emph{c-pointer} \emph{integer} \emph{number}) sets the unsigned at the \emph{integer} byte of \emph{c-pointer} to \emph{number} and returns \emph{number} as its value. \emph{c-type} \emph{syntax} for declaring the type of a non-Scheme procedure, procedure argument, or global. The allowed types are: \texttt{pointer}, \texttt{array}, \texttt{char}, \texttt{int}, \texttt{shortint}, \texttt{longint}, \texttt{unsigned}, \texttt{shortunsigned}, \texttt{longunsigned}, \texttt{float}, \texttt{double}, \texttt{tscp}, or \texttt{void}. (\texttt{car} \emph{pair}) returns the contents of the \texttt{car} field of the \emph{pair}. \RRRRRS~16. (\texttt{caar} \emph{pair}) returns (\texttt{car} (\texttt{car} \emph{pair})). \RRRRRS~16. (\texttt{ca...r} \emph{pair}) compositions of \texttt{car} and \texttt{cdr}. \RRRRRS~16. (\texttt{call-with-current-continuation} \emph{procedure}) calls \emph{procedure} with the current continuation as its argument. \RRRRRS~28. (\texttt{call-with-input-file} \emph{string} \emph{procedure}) calls \emph{procedure} with the \emph{port} that is the result of opening the file \emph{string} for input. \RRRRRS~29. (\texttt{call-with-output-file} \emph{string} \emph{procedure}) calls \emph{procedure} with the \emph{port} that is the result of opening the file \emph{string} for output. \RRRRRS~29. (\texttt{case} \emph{key} \emph{clause} \emph{clause} ...)\ \emph{syntax} for a conditional expression where \emph{key} is any expression, and each \emph{clause} is of the form ((\emph{datum} ...)\ \emph{expression} \emph{expression} ...). The last clause may be an ``else clause'' of the form (\texttt{else} \emph{expression} \emph{expression} ...). \RRRRRS~9. (\texttt{catch-error} \emph{procedure}) calls \emph{procedure} with no arguments. If an error occurs while executing \emph{procedure}, return a string containing the error message. Otherwise return a \emph{pair} whose \texttt{car} contains the procedure's value. (\texttt{cdr} \emph{pair}) returns the contents of the \texttt{cdr} field of the \emph{pair}. \RRRRRS~16. (\texttt{cd...r} \emph{pair}) compositions of \texttt{car} and \texttt{cdr}. \RRRRRS~16. (\texttt{cddddr} \emph{pair}) returns (\texttt{cdr} (\texttt{cdr} (\texttt{cdr} (\texttt{cdr} \emph{pair})))). \RRRRRS~16. (\texttt{ceiling} \emph{number}) returns the smallest integer that is not smaller than its arguments. \RRRRRS~22. \texttt{char} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{char}. When a \texttt{char} value must be supplied, an expression of type \emph{character} must be supplied. When a \texttt{char} value is returned, a value of type \emph{character} will be returned. (\texttt{char->integer} \emph{character}) returns an \emph{integer} whose value is the ASCII character code of \emph{character}. \RRRRRS~25. (\texttt{char-alphabetic?}\ \emph{character}) \emph{predicate} that returns \texttt{\#t} when \emph{character} is alphabetic. \RRRRRS~25. (\texttt{char-ci<=?}\ \emph{character} \emph{character}) \emph{predicate} that returns \texttt{\#t} when the first \emph{character} is less than or equal to the second \emph{character}. Upper case and lower case letters are treated as though they were the same character. \RRRRRS~25. (\texttt{char-ci=?}\ \emph{character} \emph{character}) \emph{predicate} that returns \texttt{\#t} when the first \emph{character} is greater than or equal to the second \emph{character}. Upper case and lower case letters are treated as though they were the same character. \RRRRRS~25. (\texttt{char-ci>?}\ \emph{character} \emph{character}) \emph{predicate} that returns \texttt{\#t} when the first \emph{character} is greater than the second \emph{character}. Upper case and lower case letters are treated as though they were the same character. \RRRRRS~25. (\texttt{char-downcase} \emph{character}) returns the lower case value of \emph{character}. \RRRRRS~25. (\texttt{char-lower-case?}\ \emph{letter}) \emph{predicate} that returns \texttt{\#t} when \emph{letter} is lower-case. \RRRRRS~25. (\texttt{char-numeric?}\ \emph{character}) \emph{predicate} that returns \texttt{\#t} when \emph{character} is numeric. \RRRRRS~25. (\texttt{char-ready?}\ \emph{optional-input-port}) \emph{predicate} that returns \texttt{\#t} when a character is ready on the \emph{optional-input-port}. \RRRRRS~30. (\texttt{char-upcase} \emph{character}) returns the upper case value of the \emph{character}. \RRRRRS~25. (\texttt{char-upper-case?}\ \emph{letter}) \emph{predicate} that returns \texttt{\#t} when \emph{letter} is upper-case. \RRRRRS~25. (\texttt{char-whitespace?}\ \emph{character}) \emph{predicate} that returns \texttt{\#t} when \emph{character} is a whitespace character. \RRRRRS~25. (\texttt{char<=?}\ \emph{character} \emph{character}) \emph{predicate} that returns \texttt{\#t} when the first \emph{character} is less than or equal to the second \emph{character}. \RRRRRS~24. (\texttt{char=?}\ \emph{character} \emph{character}) \emph{predicate} that returns \texttt{\#t} when the first \emph{character} is greater than or equal to the second \emph{character}. \RRRRRS~24. (\texttt{char>?}\ \emph{character} \emph{character}) \emph{predicate} that returns \texttt{\#t} when the first \emph{character} is greater than the second \emph{character}. \RRRRRS~24. (\texttt{char?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{character}. \RRRRRS~24. \emph{character} Scheme object that represents printed characters. See \texttt{\#\textbackslash}\emph{character}, \texttt{\#\textbackslash}\emph{character-name}, \RRRRRS~24. (\texttt{close-input-port} \emph{input-port}) closes the file associated with \emph{input-port}. \RRRRRS~30. (\texttt{close-output-port} \emph{output-port}) closes the file associated with \emph{output-port}. \RRRRRS~30. (\texttt{close-port} \emph{port}) closes the file associated with \emph{port}. (\texttt{collect}) invokes the garbage collector to perform a generational collection. Normally, garbage collection is invoked automatically by the Scheme system. (\texttt{collect-all}) invokes the garbage collector to perform a full collection. Normally, garbage collection is invoked automatically by the Scheme system. (\texttt{collect-info}) returns a \emph{list} containing information about heap and prcessor usage. The items in the list (and their position) are: number of bytes currently allocated (0), current heap size in bytes (1), application processor seconds (2), garbage collection processor seconds (3), maximum heap size in bytes (4), full collection limit percent (5). \emph{complex number} complex numbers are not supported in \StoC. \RRRRRS~18. (\texttt{complex?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{complex number}. All \StoC\ \emph{numbers} are complex. \RRRRRS~20. (\texttt{cond} \emph{clause} \emph{clause} ...)\ \emph{syntax} for a conditional expression where each \emph{clause} is of the form (\emph{test} \emph{expression} ...)\ or (\emph{test} \texttt{=>} \emph{procedure}). The last \emph{clause} may be of the form (\texttt{else} \emph{expression} \emph{expression} ...). \RRRRRS~9. (\texttt{cons} \emph{expression}$_1$ \emph{expression}$_2$) returns a newly allocated \emph{pair} that has \emph{expression}$_1$ as its \texttt{car}, and \emph{expression}$_2$ as its \texttt{cdr}. \RRRRRS~16. (\texttt{cons*} \emph{expression} \emph{expression} ...)\ returns an object formed by consing the \emph{expressions} together from right to left. If only one \emph{expression} is supplied, then that \emph{expression} is returned. (\texttt{cos} \emph{number}) returns the cosine of its argument. \RRRRRS~23. (\texttt{current-input-port}) returns the current default input \emph{port}. \RRRRRS~30. (\texttt{current-output-port}) returns the current default output \emph{port}. \RRRRRS~30. \texttt{debug-output-port} \emph{port} used for interactive debugging output. The default value is the same as \texttt{stderr-port}. (\texttt{define} \emph{symbol} \emph{expression}) \emph{syntax} that defines the value of \emph{expression} as the value of either a top-level symbol or a local variable. \RRRRRS~12. (\texttt{define} (\emph{symbol} \emph{formals}) \emph{body}) \emph{syntax} that defines a \emph{procedure} that is either the value of a top-level symbol or a local variable. \RRRRRS~12. (\texttt{define} (\emph{symbol} \texttt{.}\ \emph{formal}) \emph{body}) \emph{syntax} that defines a \emph{procedure} that is either the value of a top-level symbol or a local variable. \RRRRRS~12. (\texttt{define-c-external} \emph{symbol} \emph{c-type} \emph{string}) \emph{syntax} for a compiler declaration that defines \emph{symbol} as a non-Scheme global variable with the name \emph{string} and the type \emph{c-type}. (\texttt{define-c-external} (\emph{symbol} \emph{c-type}$_1$...)\ \emph{c-type}$_2$ \emph{string}) \emph{syntax} for a compiler declaration that defines \emph{symbol} as a non-Scheme procedure with arguments of the type specified in the list \emph{c-type}$_1$. The procedure's name is \emph{string} and it returns a value of type \emph{c-type}$_2$. (\texttt{define-c-external} (\emph{symbol} \emph{c-type}$_1$...\ . \emph{c-type}$_2$) \emph{c-type}$_3$ \emph{string}) \emph{syntax} for a compiler declaration that defines \emph{symbol} as a non-Scheme procedure that takes a variable number of arguments. The types of the initial arguments are specified by the list \emph{c-type}$_1$. Any additional arguments must be of the type \emph{c-type}$_2$. The procedure's name is \emph{string} and it returns a value of type \emph{c-type}$_3$. (\texttt{define-constant} \emph{symbol} \emph{expression}) \emph{syntax} that defines a macro that replaces all occurences of \emph{symbol} with the value of \emph{expression}, evaluated at the time of the definition. (\texttt{define-external} \emph{symbol}$_1$ \emph{symbol}$_2$) \emph{syntax} for a compiler declaration that \emph{symbol}$_1$ is defined in \emph{module} \emph{symbol}$_2$. (\texttt{define-external} \emph{symbol} \texttt{TOP-LEVEL}) \emph{syntax} for a compiler declaration that \emph{symbol} is a top-level symbol. Its value is to be found via the \texttt{*obarray*}. (\texttt{define-external} \emph{symbol}$_1$ \texttt{TOP-LEVEL} \emph{symbol}$_2$) \emph{syntax} for a compiler declaration that \emph{symbol}$_1$ is a top-level symbol that is known to be defined in \emph{module} \emph{symbol}$_2$. Its value is to be found via the \texttt{*obarray*}. (\texttt{define-external} \emph{symbol} \texttt{""} \emph{string}) \emph{syntax} for a compiler declaration that \emph{symbol} has the external name \emph{string}. (\texttt{define-external} \emph{symbol} \emph{string}$_1$ \emph{string}$_2$) \emph{syntax} for a compiler declaration that \emph{symbol} is in the \emph{module} \emph{string}$_1$ and has the external name \emph{string}$_1$\_\emph{string}$_2$. (\texttt{define-external} (\emph{symbol}$_1$ \emph{formals}) \emph{symbol}$_2$) \emph{syntax} for a compiler declaration that \emph{symbol}$_1$ is a Scheme \emph{procedure} defined in \emph{module} \emph{symbol}$_2$. (\texttt{define-external} (\emph{symbol}$_1$ \texttt{.}\ \emph{formal}) \emph{symbol}$_2$) \emph{syntax} for a compiler declaration that \emph{symbol}$_1$ is a Scheme \emph{procedure} defined in \emph{module} \emph{symbol}$_2$. (\texttt{define-external} (\emph{symbol} \emph{formals}) \texttt{""} \emph{string}) \emph{syntax} for a compiler declaration that \emph{symbol} is a \emph{procedure} that has the external name \emph{string}. (\texttt{define-external} (\emph{symbol} \texttt{.}\ \emph{formal}) \texttt{""} \emph{string}) \emph{syntax} for a compiler declaration that \emph{symbol} is a \emph{procedure} that takes a variable number of arguments and has the external name \emph{string}. (\texttt{define-external} (\emph{symbol} \emph{formals}) \emph{string}$_1$ \emph{string}$_2$) \emph{syntax} for a compiler declaration that \emph{symbol} is a \emph{procedure} in the \emph{module} \emph{string}$_1$ that has the external name \emph{string}$_1$\_\emph{string}$_2$. (\texttt{define-external} (\emph{symbol} \texttt{.}\ \emph{formal}) \emph{string}$_1$ \emph{string}$_2$) \emph{syntax} for a compiler declaration that \emph{symbol} is a \emph{procedure} in the \emph{module} \emph{string}$_1$ that has the external name \emph{string}$_1$\_\emph{string}$_2$. (\texttt{define-in-line} (\emph{symbol} \emph{formals}) \emph{body}) \emph{syntax} that defines a \emph{procedure} that is to be compiled ``in-line''. (\texttt{define-in-line} (\emph{symbol} \texttt{.}\ \emph{formal}) \emph{body}) \emph{syntax} that defines a \emph{procedure} that is to be compiled ``in-line''. (\texttt{define-macro} \emph{symbol} (\texttt{lambda} (\emph{form expander}) \emph{expression} ...))\ \emph{syntax} that defines a macro expansion procedure. Macro expansion is done using the ideas expressed in \emph{Expansion-Passing Style: Beyond Conventional Macros}, 1986 ACM Conference on Lisp and Functional Programming, 143-150. (\texttt{define-system-file-task} \emph{file} \emph{idle-task} \emph{file-task}) installs the \emph{idle-task} and \emph{file-task} \emph{procedures} for system file number \emph{file}. When a Scheme program reads from a port and no characters are internally buffered, the \emph{idle-task} for each system file is called. Then, the \emph{file-task} for each system file that has input pending is called. As long as no characters are available on the Scheme port, the Scheme system will idle, calling the \emph{file-task} for each system file as input becomes available. A system file task is removed by supplying \texttt{\#f} as the \emph{idle-task} and \emph{file-task}. (\texttt{delay} \emph{expression}) \emph{syntax} used together with the procedure \texttt{force} to implement call by need. \RRRRRS~11. (\texttt{display} \emph{expression} \emph{optional-output-port}) writes a human-readable representation of \emph{expression} to \emph{optional-output-port}. \RRRRRS~31. (\texttt{do} (\emph{var} ...)\ (\emph{test} \emph{expression} ...)\ \emph{command} ...)\ \emph{syntax} for an iteration construct. Each \emph{var} defines a local variable and is of the form (\emph{symbol} \emph{init} \emph{step}) or (\emph{symbol} \emph{init}). \RRRRRS~11. \texttt{double} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{double}. When a \texttt{double} value must be supplied, an expression of type \emph{number} must be supplied. When a \texttt{double} value is returned, a value of type \emph{number} is returned. (\texttt{echo} \emph{port}) turns off echoing on \emph{port}. (\texttt{echo} \emph{port} \emph{output-port}) echos \emph{port} on \emph{output-port}. All characters read from or written to \emph{port} are also written to \emph{output-port}. \texttt{else} keyword in last \emph{clause} of \texttt{cond} or \texttt{case} form. \emph{environment} the set of all variable bindings in effect at some point in the program. \RRRRRS~6. (\texttt{eof-object?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} if \emph{expression} is equal to the end of file object. \RRRRRS~30. (\texttt{enable-system-file-tasks} \emph{flag}) enables (\emph{flag} is \texttt{\#t}) or disables (\emph{flag} is \texttt{\#f}) system file tasking and returns the previous system file tasking state. When the value of flag is the symbol \texttt{wait}, system file tasking is enabled and the Scheme program is blocked until there are no system file tasks. (\texttt{eq?}\ \emph{expression}$_1$ \emph{expression}$_2$) \emph{predicate} that is the finest test for equivalence between \emph{expression}$_1$ and \emph{expression}$_2$. \RRRRRS~15. (\texttt{equal?}\ \emph{expression}$_1$ \emph{expression}$_2$) \emph{predicate} that is the coarsest test for equivalence between \emph{expression}$_1$ and \emph{expression}$_2$. \RRRRRS~15. (\texttt{eqv?}\ \emph{expression}$_1$ \emph{expression}$_2$) \emph{predicate} that is the medium test for equivalence between \emph{expression}$_1$ and \emph{expression}$_2$. \RRRRRS~13. (\texttt{error} \emph{symbol} \emph{format-template} \emph{expression} ...)\ reports an error. The procedure name is \emph{symbol} and the error message is produced by the \emph{format-template} and optional \emph{expressions}. The \emph{procedure} error is equivalent to \texttt{(lambda x (apply *error-handler* x))}. See \texttt{*error-handler*}. (\texttt{eval} \emph{expression}) evaluates \emph{expression}. Any macros in \emph{expression} are expanded before evaluation. (\texttt{eval-when} \emph{list} \emph{expression} ...)\ \emph{syntax} to evaluate \emph{expressions} when the current situation is in \emph{list}. When this form is evaluated by the Scheme interpreter and \texttt{eval} is a member of the situation \emph{list}, then the expressions will be evaluated. When this form is evaluated by the Scheme compiler and \texttt{compile} is a member of the situation \emph{list}, then the expressions will be evaluated within the compiler. When this form is evaluated by the Scheme compiler, and \texttt{load} is a member of the situation \emph{list}, then the compiler will compile the form (\texttt{begin} \emph{expression} ...)). (\texttt{even?}\ \emph{integer}) \emph{predicate} that returns \texttt{\#t} if \emph{integer} is even. \RRRRRS~21. \emph{exact} \qquad \emph{fixed} numbers are exact, all other numbers are not. \RRRRRS~14. (\texttt{exact->inexact} \emph{number}) returns the \emph{inexact} representation of \emph{number}. \RRRRRS~23. (\texttt{exact?}\ \emph{number}) \emph{predicate} that returns \texttt{\#t} if \emph{number} is \emph{exact}. \RRRRRS~21. (\texttt{exit}) returns from the current \texttt{read-eval-print} procedure. (\texttt{exp} \emph{number}) returns exponential function of \emph{number}. \RRRRRS~22. (\texttt{expand} \emph{expression}) returns the value of \emph{expression} after all macro expansions. See \texttt{define-macro}. (\texttt{expand-once} \emph{expression}) returns the value of \emph{expression} after one macro expansion. See \texttt{define-macro}. \emph{expression} a Scheme construct that returns a value. \RRRRRS~7. (\texttt{expt} \emph{number}$_1$ \emph{number}$_2$) returns \emph{number}$_1$ raised to the power \emph{number}$_2$. \RRRRRS~23. \texttt{fix} \emph{format descriptor} for compatibility with \RRRRS. \emph{fixed} \StoC\ internal representation for small \emph{integer}s. A \emph{fixed} value is represented in a ``pointer size'' word with two bits used by the tag. With 32-bit pointers, this yields a maximum value of $2^{29}-1$ or 536,870,911 and a minimum value of $-2^{29}$ or $-$536,870,912. With 64-bit pointers, this yields a maximum value of $2^{61}-1$ or 2,305,843,009,213,693,951 and a minimum value of $-2^{61}$ or $-$2,305,843,009,213,693,952. (\texttt{fixed->float} \emph{fixed}) returns the \emph{float} representation of \emph{fixed}. (\texttt{fixed?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{fixed}. \texttt{float} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{float}. When a \texttt{float} value must be supplied, an expression of type \emph{number} must be supplied. When a \texttt{float} value is returned, a value of type \emph{number} is returned. \emph{float} \StoC\ internal floating point representation. This is typically 64-bits. (\texttt{float->fixed} \emph{float}) returns the \emph{fixed} \emph{number} that best represents the value of \emph{float}. (\texttt{float?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} if \emph{expression} is a \emph{float} value. (\texttt{floor} \emph{number}) returns the largest \emph{integer} not larger than \emph{number}. \RRRRRS~22. (\texttt{flush-buffer} \emph{optional-output-port}) forces output of all characters buffered in \emph{optional-output-port}. (\texttt{for-each} \emph{procedure} \emph{list} \emph{list} ...)\ applies \emph{procedure} to each element of the \emph{lists} in order. \RRRRRS~28. (\texttt{force} \emph{promise}) returns the forced value of a promise. \RRRRRS~28. \emph{formals} a \emph{symbol} or a \emph{list} of \emph{symbols} that are the arguments. \RRRRRS~8. (\texttt{format} \texttt{\#f} \emph{format-template} \emph{expression} ...)\ returns a string that is the result of outputting the \emph{expressions} according to the \emph{format-template}. (\texttt{format} \emph{format-template} \emph{expression} ...)\ returns a string that is the result of outputting the \emph{expressions} according to the \emph{format-template}. (\texttt{format} \emph{output-port} \emph{format-template} \emph{expression} ...)\ output the \emph{expressions} to \emph{output-port} according to the \emph{format-template}. (\texttt{format} \texttt{\#t} \emph{format-template} \emph{expression} ...)\ output the \emph{expressions} to the current output port according to the \emph{format-template}. \emph{format descriptor} a \emph{list} that describes the type of output conversion to be done by \texttt{number->string}. The supported forms are (\texttt{int}), (\texttt{fix} \emph{integer}), and (\texttt{s2ci} \emph{integer}). \RRRRRS~21. \emph{format-template} a \emph{string} consisting of format descriptors and literal characters. A format descriptor is \texttt{\texttildelow} followed by some other character. When one is encountered, it is interpreted. Literal characters are output as is. See \texttt{\texttildelow{}a}, \texttt{\texttildelow{}A}, \texttt{\texttildelow{}c}, \texttt{\texttildelow{}C}, \texttt{\texttildelow{}s}, \texttt{\texttildelow{}S}, \texttt{\texttildelow\%}, \texttt{\texttildelow\texttildelow}. (\texttt{gcd} \emph{number} ...)\ returns the greatest common divisor of its arguments. \RRRRRS~22. (\texttt{get-output-string} \emph{string-output-port}) returns the \emph{string} associated with \emph{string-output-port}. The \emph{string} associated with the \emph{string-output-port} is initially set to \texttt{""}. (\texttt{getprop} \emph{symbol} \emph{expression}) returns the value that has the key \texttt{eq?}\ to \emph{expression} from \emph{symbol's} property list. If there is no value associated with \emph{expression}, then \texttt{\#f} is returned. (\texttt{getprop-all} \emph{symbol}) returns the \emph{symbol's} property list. (\texttt{implementation-information}) returns a list of string or \texttt{\#f} values containing information about the Scheme implementation. The list is of the form (\emph{implementation-name} \emph{version} \emph{machine} \emph{processor} \emph{operating-system} \emph{filesystem} \emph{features} ...). (\texttt{if} \emph{expression}$_1$ \emph{expression}$_2$) \emph{syntax} for a conditional expression. \RRRRRS~8. (\texttt{if} \emph{expression}$_1$ \emph{expression}$_2$ \emph{expression}$_3$) \emph{syntax} for a conditional expression. \RRRRRS~8. (\texttt{include} \emph{string}) \emph{syntax} to include the contents of the file \emph{string} at this point in the Scheme compilation. Search directories may be specified by the \texttt{-I} command flag. \emph{inexact} \qquad \emph{float} numbers are inexact. \RRRRRS~14. (\texttt{inexact->exact} \emph{number}) returns the \emph{exact} representation of \emph{number}. \RRRRRS~23. (\texttt{inexact?}\ \emph{number}) \emph{predicate} that returns \texttt{\#t} when \emph{number} is \emph{inexact}. \RRRRRS~21. \emph{input-port} Scheme object that can deliver characters on command. \RRRRRS~29. (\texttt{input-port?}\ \emph{expression}) \emph{predicate} when returns \texttt{\#t} when \emph{expression} is an \emph{input-port}. \RRRRRS~29. \texttt{int} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{int}. When a \texttt{int} value must be supplied, an expression of type \emph{number} must be supplied. When a \texttt{int} value is returned, a value of type \emph{number} is returned. \texttt{int} \emph{format descriptor} for compatibility with \RRRRS. \emph{integer} integers are represented by both \emph{fixed} and \emph{float} values. \RRRRRS~18. (\texttt{integer->char} \emph{integer}) returns the \emph{character} whose ASCII code is equal to \emph{integer}. \RRRRRS~25. (\texttt{integer?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is an \emph{integer}. \RRRRRS~20. \emph{interned} \qquad \emph{symbols} that are contained in \texttt{*obarray*} are interned. (\texttt{lambda} \emph{formals} \emph{body}) the ultimate imperative, the ultimate declarative. \RRRRRS~8. (\texttt{last-pair} \emph{list}) returns the last \emph{pair} of \emph{list}. (\texttt{lcm} \emph{number} ...)\ returns the least common multiple of its arguments. \RRRRRS~22. (\texttt{length} \emph{list}) returns the length of \emph{list}. \RRRRRS~17. (\texttt{let} \emph{bindings} \emph{body}) \emph{syntax} for a binding construct that computes initial values before any bindings are done. \RRRRRS~10. (\texttt{let} \emph{symbol} \emph{bindings} \emph{body}) \emph{syntax} for a general looping construct. \RRRRRS~11. (\texttt{let*} \emph{bindings} \emph{body}) \emph{syntax} for a binding construct that computes initial values and performs bindings sequentially. \RRRRRS~10. (\texttt{letrec} \emph{bindings} \emph{body}) \emph{syntax} for a binding construct that binds the variables before the initial values are computed. \RRRRRS~10. \emph{letter} an alphabetic \emph{character}. \RRRRRS~25. \emph{list} the empty list, or a \emph{pair} whose \texttt{cdr} is a \emph{list}. \RRRRRS~16. (\texttt{list} \emph{expression} ...)\ returns a \emph{list} of its arguments. \RRRRRS~17. (\texttt{list?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{list}. \RRRRRS~16. (\texttt{list->string} \emph{list}) returns the string formed from the \emph{characters} in \emph{list}. \RRRRRS~26. (\texttt{list->vector} \emph{list}) returns a \emph{vector} whose elements are the members of \emph{list}. \RRRRRS~27. (\texttt{list-ref} \emph{list} \emph{integer}) returns the \emph{integer} element of \emph{list}. Elements are numbered starting at 0. \RRRRRS~17. (\texttt{list-tail} \emph{list} \emph{integer}) returns the sublist of \emph{list} obtained by omitting the first \emph{integer} elements. \RRRRRS~17. (\texttt{load} \emph{string}) loads the expressions in the file \emph{string} into the Scheme interpreter. The results of the expressions are printed on the current output port. \RRRRRS~31. (\texttt{loade} \emph{string}) loads the expressions in the file \emph{string} into the Scheme interpreter. The contents of the file and the results of the expressions are printed on the current output port. (\texttt{loadq} \emph{string}) loads the expressions in the file \emph{string} into the Scheme interpreter. The results of the expressions are not printed. (\texttt{log} \emph{number}) returns the natural logarithm of \emph{number}. \RRRRRS~22. \texttt{longint} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{long int}. When a \texttt{long int} value must be supplied, an expression of type \emph{number} must be supplied. When a \texttt{long int} value is returned, a value of type \emph{number} is returned. \texttt{longunsigned} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{long unsigned}. When a \texttt{long unsigned} value must be supplied, an expression of type \emph{number} must be supplied. When a \texttt{long unsigned} value is returned, a value of type \emph{number} is returned. (\texttt{make-string} \emph{integer}) returns a string of length \emph{integer} with unknown elements. \RRRRRS~25. (\texttt{make-string} \emph{integer} \emph{char}) returns a string of length \emph{integer} with all elements initialized to \emph{char}. \RRRRRS~25. (\texttt{make-vector} \emph{integer}) returns a vector of length \emph{integer} with unknown elements. \RRRRRS~26. (\texttt{make-vector} \emph{integer} \emph{expression}) returns a vector of length \emph{integer} with all elements set to \emph{expression}. \RRRRRS~26. (\texttt{map} \emph{procedure} \emph{list} \emph{list} ...)\ returns a \emph{list} constructed by applying \emph{procedure} to each element of the \emph{lists}. The order of application is not defined. \RRRRRS~27. (\texttt{max} \emph{number} \emph{number} ...)\ returns the maximum of its arguments. \RRRRRS~21. (\texttt{member} \emph{expression} \emph{list}) returns the first \emph{sublist} of \emph{list} such that (\texttt{equal?}\ \emph{expression} (\texttt{car} \emph{sublist})) is true. If no match occurs, then \texttt{\#f} is returned. \RRRRRS~17. (\texttt{memq} \emph{expression} \emph{list}) returns the first \emph{sublist} of \emph{list} such that (\texttt{eq?}\ \emph{expression} (\texttt{car} \emph{sublist})) is true. If no match occurs, then \texttt{\#f} is returned. \RRRRRS~17. (\texttt{memv} \emph{expression} \emph{list}) returns the first \emph{sublist} of \emph{list} such that (\texttt{eqv?}\ \emph{expression} (\texttt{car} \emph{sublist})) is true. If no match occurs, then \texttt{\#f} is returned. \RRRRRS~17. (\texttt{min} \emph{number} \emph{number} ...)\ returns the minimum of its arguments. \RRRRRS~21. (\texttt{module} \emph{symbol} \emph{clause} ...)\ \emph{syntax} to declare module information for the \StoC\ compiler. The \emph{module} form must be the first item in the source file. The module name is a \emph{symbol} that must be a legal C identifier. Using this information, the compiler is able to construct an object module that is similar in structure to a Modula 2 module. Following the module name come optional \emph{clauses}. If the module is to provide the ``main'' program, then a \emph{clause} of the form (\texttt{main} \emph{symbol}) is provided that indicates that \emph{symbol} is the initial \emph{procedure}. It will be invoked with one argument that is a \emph{list} of \emph{strings} that are the arguments that the program was invoked with. A minimum (and default) heap size can be specified by the \emph{clause} (\texttt{HEAP} \emph{integer}), where the size is specified in megabytes. The user may control that top-level \emph{symbols} in this module are visible as top-level \emph{symbols} by including a \emph{clause} of the form (\texttt{top-level} \emph{symbol} ...). If this clause occurs, then only those \emph{symbols} specified will be made top-level. All other top-level \emph{symbols} in the module will appear at the top-level with names of the form: \emph{module}\_\emph{symbol}. If a \texttt{top-level} clause is not provided, then all top-level \emph{symbols} in the module will be made top-level. The final clause, (\texttt{with} \emph{symbol} ...)\ indicates that this module will be linked with other modules. Normally the intermodule linkages are automatically infered by including all \emph{modules} that have external references. However, this mechanism is not sufficient to pick up those objects that are only referenced at runtime. (\texttt{modulo} \emph{integer}$_1$ \emph{integer}$_2$) returns the modulo of its arguments. The sign of the result is the sign of the divisor. \RRRRRS~22. (\texttt{negative?}\ \emph{number}) \emph{predicate} that returns \texttt{\#t} when \emph{number} is negative. \RRRRRS~21. (\texttt{newline} \emph{optional-output-port}) outputs a newline character on the \emph{optional-output-port}. \RRRRRS~31. (\texttt{not} \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is \texttt{\#f} or \texttt{()}. \RRRRRS~13. (\texttt{null?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is \texttt{()}. \RRRRRS~16. \emph{number} \StoC\ has two internal representations for numbers: \emph{fixed} and \emph{float}. When an arithmetic operation is to be performed with a \emph{float} argument, all arguments will be converted to \emph{float} as needed, and then the operation will be performed. Automatic conversion back to \emph{fixed} is never done. \RRRRRS~18. (\texttt{number->string} \emph{number} \emph{format descriptor}) returns a \emph{string} that is the printed representation of \emph{number} as specified by \emph{format descriptor}. For compatibility with \RRRRS. (\texttt{number->string} \emph{number}) returns a string with the printed representation of the number. \RRRRRS~23. (\texttt{number->string} \emph{number} \emph{radix}) returns a string with the printed representation of the number in the given radix. Radix must be 2, 8, 10, or 16. \RRRRRS~23. (\texttt{number?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{number}. \RRRRRS~20. (\texttt{odd?}\ \emph{integer}) \emph{predicate} that returns \texttt{\#t} when \emph{integer} is odd. \RRRRRS~21. (\texttt{open-file} \emph{string}$_1$ \emph{string}$_2$) returns a \emph{port} for file \emph{string}$_1$ that is opened using the operating system's \emph{fopen} option \emph{string}$_2$. (\texttt{open-input-file} \emph{string}) returns an \emph{input port} capable of delivering characters from the file \emph{string}. \RRRRRS~30. (\texttt{open-input-string} \emph{string}) returns an \emph{input port} capable of delivering characters from the \emph{string}. (\texttt{open-output-file} \emph{string}) returns an \emph{output port} capable of delivering characters to the file \emph{string}. \RRRRRS~30. (\texttt{open-output-string}) returns an \emph{output port} capable of delivering characters to a \emph{string}. See \texttt{get-output-string}. (\texttt{optimize-eval} \emph{option...})\ controls the optimization done on interpreted programs. When no \emph{option} is supplied, minimal optimization is done. When \texttt{call} is specified, calls to top-level procedures that are not interpreted are optimized. When \texttt{rewrite} is specified, calls to top-level procedures that take variable number of arguments are rewritten. This option may cause some breakpoints to be missed. Both \texttt{call} and \texttt{rewrite} may be specified. \emph{optional-input-port} if present, it must be an \emph{input-port}. If not present, then it is the value returned by \texttt{current-input-port}. \emph{optional-output-port} if present, it must be an \emph{output-port}. If not present, then it is the value returned by \texttt{current-output-port}. (\texttt{or} \emph{expression} ...)\ \emph{syntax} for a conditional expression. \RRRRRS~9. \emph{pair} record structure with two fields: car and cdr. \RRRRRS~15. (\texttt{pair?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{pair}. \RRRRRS~16. (\texttt{peek-char} \emph{optional-input-port}) returns a copy of the next character available on \emph{optional-input-port}. \RRRRRS~30. \texttt{pointer} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global varible as being some type of C pointer. When a value must be supplied, an expression of the type \emph{string}, \emph{procedure}, or \emph{number} is supplied. This will result in either the address of the first character of the \emph{string}, the address of the code associated with the \emph{procedure}, or the value of the number being used. A \emph{pointer} value is returned as an non-negative \emph{number}. \emph{port} Scheme object that is capable of delivering or accepting characters on demand. \RRRRRS~29. (\texttt{port->stdio-file} \emph{port}) returns the standard I/O FILE pointer for \emph{port}, or \texttt{\#f} if the \emph{port} does not use standard I/O. (\texttt{positive?}\ \emph{number}) \emph{predicate} that returns \texttt{\#t} when \emph{number} is positive. \RRRRRS~21. (\texttt{pp} \emph{expression} \emph{optional-output-port}) pretty-prints \emph{expression} on \emph{optional-output-port}. (\texttt{pp} \emph{expression} \emph{string}) pretty-prints \emph{expression} to the file \emph{string}. \emph{predicate} function that returns \texttt{\#t} when the condition is true, and \texttt{\#f} when the condition is false. \RRRRRS~13. (\texttt{procedure?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{procedure}. \RRRRRS~27. (\texttt{proceed}) return from the innermost \texttt{read-eval-print} loop with an unspecified value. (\texttt{proceed}) resume the computation that previously timed out in an embedded \StoC\ system, or was stopped at a breakpoint. (\texttt{proceed} \emph{expression}) return from the innermost \texttt{read-eval-print} loop with \emph{expression} as the value. At the outermost level, \emph{expression} must be an \emph{integer} as it will be used as the argument for a call to the C library procedure \emph{exit}. (\texttt{proceed} \emph{expression}) return \emph{expression} as the value of a procedure that stopped at a breakpoint. (\texttt{proceed?}) force a breakpoint while resuming the computation that previously timed out in an embedded \StoC\ system. (\texttt{putprop} \emph{symbol} \emph{expression}$_1$ \emph{expression}$_2$) stores \emph{expression}$_2$ using key \emph{expression}$_1$ on \emph{symbol's} property list. See \texttt{getprop}. (\texttt{quasiquote} \emph{back-quote-template}) \emph{syntax} for a \emph{vector} or \emph{list} constructor. \RRRRRS~11. (\texttt{quote} \emph{expression}) \emph{syntax} whose result is \emph{expression}. \RRRRRS~7. (\texttt{quotient} \emph{integer}$_1$ \emph{integer}$_2$) returns the quotient of its arguments. The sign is the sign of the product of its arguments. \RRRRRS~22. (\texttt{rational?}\ \emph{number}) predicate that returns \texttt{\#t} when its argument is a rational \emph{number}. This is true for any number in \StoC. \RRRRRS~20. (\texttt{read} \emph{optional-input-port}) returns the next readable object from \emph{optional-input-port}. Revived$^3$~30. (\texttt{read-char} \emph{optional-input-port}) returns the next character from \emph{optional-input-port}, updating the \emph{port} to point to the next \emph{character}. Revived$^3$~30. (\texttt{read-eval-print} \emph{expression} ...)\ starts a new read-eval-print loop. The optional \emph{expressions} allow one to specify the prompt or the header: \texttt{PROMPT} \emph{string} \texttt{HEADER} \emph{string}. Typing control-D at the prompt will terminate the procedure. See \texttt{reset}, \texttt{exit}, \texttt{eval}, \texttt{proceed}. (\texttt{real?}\ \emph{number}) predicate that returns \texttt{\#t} when its argument is a real \emph{number}. This is true in \StoC\ for any \emph{number}. \RRRRRS~20. \emph{record} a heterogenous mutable structure whose elements are indexed by \emph{integers}. The valid indexes of a record are the exact non-negative integers less than the length of the record. A \emph{record} differs from a \emph{vector} in that a \emph{record} may have method \emph{procedures} that control how it's output, compared, and evaluated. (\texttt{remainder} \emph{integer}$_1$ \emph{integer}$_2$) returns the remainder of its arguments. The sign is the sign of \emph{integer}$_1$. \RRRRRS~22. (\texttt{remove} \emph{expression} \emph{list}) returns a new \emph{list} that is a copy of \emph{list} with all items \texttt{equal?}\ to \emph{expression} removed from it. (\texttt{remove!}\ \emph{expression} \emph{list}) returns \emph{list} having deleted all items \texttt{equal?}\ to \emph{expression} from it. (\texttt{remove-file} \emph{string}) removes the file named \emph{string}. (\texttt{remq} \emph{expression} \emph{list}) returns a new \emph{list} that is a copy of \emph{list} with all items \texttt{eq?}\ to \emph{expression} removed from it. (\texttt{remq!}\ \emph{expression} \emph{list}) returns \emph{list} having deleted all items \texttt{eq?}\ to \emph{expression} from it. (\texttt{remv} \emph{expression} \emph{list}) returns a new \emph{list} that is a copy of \emph{list} with all items \texttt{eqv?}\ to \emph{expression} removed from it. (\texttt{remv!}\ \emph{expression} \emph{list}) returns \emph{list} having deleted all items \texttt{eqv?}\ to \emph{expression} from it. (\texttt{rename-file} \emph{string}$_1$ \emph{string}$_2$) changes the name of the file named \emph{string}$_1$ to \emph{string}$_2$. (\texttt{reset}) returns to the current \texttt{read-eval-print} loop. (\texttt{reset-bpt}) indicates that the caller wishes to cancel the resumption of computation at the point where a breakpoint occurred in an embedded \StoC\ system. (\texttt{reset-error}) indicates that the caller is finished examining the last retained error state in an embedded \StoC\ system. (\texttt{reverse} \emph{list}) returns a new \emph{list} with the elements of \emph{list} in reverse order. \RRRRRS~17. (\texttt{round} \emph{number}) returns \emph{number} rounded to the closest integer. \RRRRRS~22. \texttt{S2CUINT} C type defined by \StoC\ to be an unsigned integer that is the same size as a pointer. \emph{sc-pointer} a Scheme object that is represented by a tagged pointer to one or more words of memory. \texttt{sc...}\ all modules that compose the \StoC\ runtime system have module names begining with the letters \texttt{sc}. All procedures and external variables in these modules have names that begin with \texttt{sc...\_}. \texttt{s2cc} shell command to invoke the \StoC\ Scheme compiler. See the \texttt{man} page. \texttt{SCGCINFO} environment variable that when set to 1 will log garbage collection information on stderr. This variable is overridden by the \texttt{-scgc} command line flag. \texttt{SCHEAP} environment variable that controls the initial heap size. It is set to the desired size in megabytes. If not set, then the default in the main program will be used. If a default size is not supplied, then the implementation default is used. This variable is overridden by the \texttt{-sch} command line flag. \texttt{SCLIMIT} environment variable that controls the amount of heap retained after a generational garbage collection that will force a full collection. It is expressed as a percent of the heap. The default value is 40. This variable is overridden by the \texttt{-scl} command line flag. \texttt{SCMAXHEAP} environment variable that controls the maximum heap size. It is set to the desired size in megabytes. If not set and the \texttt{-scmh} command line flag is not supplied, the maximum heap size is five times the initial heap size. This variable is overridden by the \texttt{-scmh} command line flag. (\texttt{scheme-byte-ref} \emph{sc-pointer} \emph{integer}) returns the byte at the \emph{integer} byte of \emph{sc-pointer} as a \emph{number}. (\texttt{scheme-byte-set!}\ \emph{sc-pointer} \emph{integer} \emph{number}) sets the byte at the \emph{integer} byte of \emph{sc-pointer} to \emph{number}. The procedure returns \emph{number} as its value. (\texttt{scheme-int-ref} \emph{sc-pointer} \emph{integer}) return the int at the \emph{integer} byte of \emph{sc-pointer} as a \emph{number}. (\texttt{scheme-int-set!}\ \emph{sc-pointer} \emph{integer} \emph{number}) sets the int at the \emph{integer} byte of \emph{sc-pointer} to \emph{number}. The procedure returns \emph{number} as its value. (\texttt{scheme-s2cuint-ref} \emph{sc-pointer} \emph{integer}) returns the S2CUINT at the \emph{integer} byte of \emph{sc-pointer}. (\texttt{scheme-s2cuint-set!}\ \emph{sc-pointer} \emph{integer} \emph{expression}) sets the S2CUINT at the \emph{integer} byte of \emph{sc-pointer} to \emph{expression}. The procedure returns \emph{expression} as its value. (\texttt{scheme-tscp-ref} \emph{sc-pointer} \emph{integer}) returns the TSCP at the \emph{integer} byte of \emph{sc-pointer}. (\texttt{scheme-tscp-set!}\ \emph{sc-pointer} \emph{integer} \emph{expression}) sets the TSCP at the \emph{integer} byte of \emph{sc-pointer} to \emph{expression}. The procedure returns \emph{expression} as its value. \texttt{s2ci} shell command to invoke the \StoC\ Scheme interpreter. See the \texttt{man} page. \texttt{s2ci} \emph{format descriptor} for compatibility with \RRRRS. (\texttt{set!}\ \emph{symbol} \emph{expression}) \emph{syntax} to set the location bound to \emph{symbol} to the value of \emph{expression}. \RRRRRS~9. (\texttt{set-car!}\ \emph{pair} \emph{expression}) sets the car field of \emph{pair} to \emph{expression}. \RRRRRS~16. (\texttt{set-cdr!}\ \emph{pair} \emph{expression}) sets the cdr field of \emph{pair} to \emph{expression}. \RRRRRS~16. (\texttt{set-gcinfo!}\ \emph{integer}) sets the flag controlling the printing of garbage collection statistics to \emph{integer}. See \texttt{-scgc}. (\texttt{set-generation-limit!}\ \emph{integer}) sets the full collection limit to \emph{integer}. See \texttt{-scl}. (\texttt{set-maximum-heap!}\ \emph{integer}) sets the maximum heap size to \emph{integer} megabytes. See \texttt{-scmh}. (\texttt{set-stack-size!}\ \emph{expression}) sets the size of the stack used by \StoC\ to \emph{expression} bytes. This value is ignored if the system does not do explicit stack overflow checking. (\texttt{set-time-slice!}\ \emph{expression}) sets the time slice used by the \StoC\ to \emph{expression} ticks. This value is decremented each time a Scheme procedure is called, and the time slice expires when it becomes zero. This value is ignored if the system does not do explicit time slicing. (\texttt{set-top-level-value!}\ \emph{symbol} \emph{expression}) sets the top-level location bound to \emph{symbol} to value. (\texttt{set-write-circle!}\ \emph{boolean} \emph{optional-output-port}) controls circular object detection on output to \emph{optional-output-port}. If \emph{boolean} is \texttt{\#t}, then circular objects are printed as ``...''. If \emph{boolean} is \texttt{\#f}, circular object detection is disabled. (\texttt{set-write-length!}\ \emph{integer} \emph{optional-output-port}) sets the list and vector length limits of \emph{optional-output-port} to \emph{integer}. Vectors and lists longer than \emph{integer} have their remaining elements printed as ``...''. (\texttt{set-write-length!}\ \texttt{\#f} \emph{optional-output-port}) allows arbitrary length list and vector printing on \emph{optional-output-port}. (\texttt{set-write-level!}\ \emph{integer} \emph{optional-output-port}) sets the number of levels that nested vectors and lists are printed on \emph{optional-output-port} to \emph{integer}. Vectors and lists nesting deeper than this level are printed as ``\#''. (\texttt{set-write-level!}\ \texttt{\#f} \emph{optional-output-port}) allows arbitrarily deep nested list and vector printing on \emph{optional-output-port}. (\texttt{set-write-pretty!}\ \emph{boolean} \emph{optional-output-port}) controls ``pretty-printing'' on \emph{optional-output-port}. If \emph{boolean} is \texttt{\#t}, then output is printed in a more readable form in \texttt{write-width} wide lines. A value of \texttt{\#f} enables normal output. (\texttt{set-write-width!}\ \emph{integer} \emph{optional-output-port}) sets the width of \emph{optional-output-port} to \emph{integer}. \texttt{shortint} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{short int}. When a \texttt{short int} value must be supplied, an expression of type \emph{number} must be supplied. When a \texttt{short int} value is returned, a value of type \emph{number} is returned. \texttt{shortunsigned} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{short unsigned}. When a \texttt{unsigned short} value must be supplied, an expression of type \emph{number} must be supplied. When a \texttt{short unsigned} value is returned, a value of type \emph{number} is returned. (\texttt{sin} \emph{number}) returns the sine of its argument. \RRRRRS~23. (\texttt{signal} \emph{number} \emph{expression}) provides a signal handler for the operating system dependent signal \emph{number}. The \emph{expression} is the signal handler and is either a \emph{procedure} or a \emph{number}. When a procedure is supplied, it is called with the signal number when the signal is present. Numeric handler values are interpreted by the underlying operating system. The previous value of the signal handler is returned. (\texttt{sqrt} \emph{number}) returns the square root of its argument. \RRRRRS~23. (\texttt{stack-size}) returns the size in bytes of \StoC's stack. \texttt{stderr-port} \emph{port} to output characters to stderr. \texttt{stdin-port} \emph{port} to input characters from stdin. \texttt{stdout-port} \emph{port} to output characters to stdout. \emph{string} sequence of \emph{characters}. The valid indexes of a \emph{string} are exact non-negative integers less than the length of the string.\RRRRRS~25. (\texttt{string} \emph{char} ...)\ returns a newly allocated \emph{string} whose elements contain the given arguments. \RRRRRS~25. (\texttt{string->list} \emph{string}) returns a newly constructed \emph{list} that contains the elements of \emph{string}. \RRRRRS~25. (\texttt{string->number} \emph{string}) returns a number expressed by \emph{string}. If \emph{string} is not a syntactically valid notation for a number then it returns \texttt{\#f}. \RRRRRS~24. (\texttt{string->number} \emph{string} \emph{number}) returns a number expressed by \emph{string} with \emph{number} the default radix. Radix must be 2, 8, 10, or 16. If \emph{string} is not a syntactically valid notation for a number then it returns \texttt{\#f}. \RRRRRS~24. (\texttt{string->symbol} \emph{string}) returns the interned \emph{symbol} whose name is \emph{string}. \RRRRRS~18. (\texttt{string->uninterned-symbol} \emph{string}) returns an uninterned \emph{symbol} whose name is string. (\texttt{string-append} \emph{string} \emph{string} ...)\ returns a new \emph{string} whose \emph{characters} are the concatenation of the of the given \emph{strings}. Upper and lower case letters are treated as though they were the same character. \RRRRRS~26. (\texttt{string-ci<=?}\ \emph{string}$_1$ \emph{string}$_2$) \emph{predicate} that returns \texttt{\#t} when \emph{string}$_1$ is less than or equal to \emph{string}$_2$. Upper and lower case letters are treated as though they were the same character. \RRRRRS~26. (\texttt{string-ci=?}\ \emph{string}$_1$ \emph{string}$_2$) \emph{predicate} that returns \texttt{\#t} when \emph{string}$_1$ is greater than or equal to \emph{string}$_2$. Upper and lower case letters are treated as though they were the same character. \RRRRRS~26. (\texttt{string-ci>?}\ \emph{string}$_1$ \emph{string}$_2$) \emph{predicate} that returns \texttt{\#t} when \emph{string}$_1$ is greater than \emph{string}$_2$. Upper and lower case letters are treated as though they were the same character. \RRRRRS~26. (\texttt{string-copy} \emph{string}) returns a new \emph{string} whose \emph{characters} are those of the given \emph{string}. \RRRRRS~26. (\texttt{string-fill!}\ \emph{string} \emph{char}) stores \emph{char} in every element of \emph{string}. \RRRRRS~26. (\texttt{string-length} \emph{string}) returns the length of \emph{string}. \RRRRRS~25. (\texttt{string-ref} \emph{string} \emph{integer}) returns \emph{character} that is the \emph{integer} element of \emph{string}. The first element is 0. \RRRRRS~25. (\texttt{string-set!}\ \emph{string} \emph{integer} \emph{character}) sets the \emph{integer} element of \emph{string} to \emph{character}. The first element is 0. \RRRRRS~26. (\texttt{string<=?}\ \emph{string}$_1$ \emph{string}$_2$) \emph{predicate} that returns \texttt{\#t} when \emph{string}$_1$ is less than or equal to \emph{string}$_2$. \RRRRRS~26. (\texttt{string=?}\ \emph{string}$_1$ \emph{string}$_2$) \emph{predicate} that returns \texttt{\#t} when \emph{string}$_1$ is greater than or equal to \emph{string}$_2$. \RRRRRS~26. (\texttt{string>?}\ \emph{string}$_1$ \emph{string}$_2$) \emph{predicate} that returns \texttt{\#t} when \emph{string}$_1$ is greater than \emph{string}$_2$. \RRRRRS~26. (\texttt{string?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{string}. \RRRRRS~25. (\texttt{substring} \emph{string} \emph{integer}$_1$ \emph{integer}$_2$) returns a \emph{string} consisting of \emph{integer}$_2$-\emph{integer}$_1$ elements of \emph{string} starting at element \emph{integer}$_1$. \RRRRRS~26. (\texttt{symbol?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{symbol}. \RRRRRS~18. (\texttt{symbol->string} \emph{symbol}) returns the name of \emph{symbol} as a \emph{string}. \RRRRRS~18. \emph{syntax} indicates a form that is evaluated in a manner that is specific to the form. \RRRRRS~5. (\texttt{system} \emph{string}) issue the shell command contained in \emph{string} and return the result. See the man page for the \texttt{system} procedure for details. (\texttt{tan} \emph{number}) returns the tangent of its argument. \RRRRRS~23. (\texttt{time-of-day}) returns a system dependent \emph{string} representing the current time and date. (\texttt{time-slice}) returns the current time slice value. (\texttt{top-level}) returns control to the ``top-level'' \texttt{read-eval-print} loop. (\texttt{top-level-value} \emph{symbol}) returns the value in the location that is the ``top-level'' binding of \emph{symbol}. (\texttt{trace}) returns a list of the procedures being traced. (\texttt{trace} \emph{symbol} \emph{symbol} ...)\ enables tracing on the \emph{procedures} that are the values of the \emph{symbols}. \texttt{trace-output-port} \emph{port} used for trace output. The default value is the same as \texttt{stdout-port}. (\texttt{transcript-off}) turns off the transcript. \RRRRRS~31. (\texttt{transcript-on} \emph{string}) starts a transcript on the file \emph{string}. \RRRRRS~31. (\texttt{truncate} \emph{number}) returns the truncated value of \emph{number}. \RRRRRS~22. \texttt{tscp} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{TSCP}. The type \texttt{TSCP} is a tagged pointer to a Scheme object. When a \texttt{tscp} value must be supplied, any expression may be supplied. When a \texttt{tscp} value is returned, any type of value may be returned. (\texttt{unbpt}) \emph{syntax} to remove all breakpoints. (\texttt{unbpt} \emph{symbol} \emph{symbol} ...)\ \emph{syntax} to remove breakpoints from the named \emph{procedures}. (\texttt{uninterned-symbol?}\ \emph{symbol}) \emph{predicate} that returns \texttt{\#t} if \emph{symbol} is not \emph{interned}. (\texttt{unless} \emph{expression}$_1$ \emph{expression}$_2$ ...)\ \emph{syntax} for a conditional form that is equivalent to (\texttt{if} (\texttt{not} \emph{expression}$_1$) (\texttt{begin} \emph{expression}$_2$ ...)). (\texttt{unquote} \emph{expression}) \emph{syntax} to evaluate the expression and replaces it in the \emph{back-quote-template}. \RRRRRS~12. (\texttt{unquote-splicing} \emph{expression}) \emph{syntax} to evaluate the expression and splices it into the \emph{back-quote-template}. \RRRRRS~12. \texttt{unsigned} \emph{syntax} for declaring a non-Scheme procedure, procedure argument, or global variable as the C type \texttt{unsigned}. When a \texttt{unsigned} value must be supplied, an expression of type \emph{number} must be supplied. When a \texttt{unsigned} value is returned, a value of type \emph{number} is returned. (\texttt{untrace}) \emph{syntax} to remove tracing from all \emph{procedures}. (\texttt{untrace} \emph{symbol} \emph{symbol} ...)\ \emph{syntax} to remove tracing from the named \emph{procedures}. \emph{variable} \RRRRRS~6. \emph{vector} a heterogenous mutable structure whose elements are indexed by \emph{integers}. The valid indexes of a vector are the exact non-negative integers less than the length of the vector. \RRRRRS~26. (\texttt{vector} \emph{expression} ...)\ returns a newly allocated \emph{vector} whose elements contain the given arguments. \RRRRRS~27. (\texttt{vector-fill!}\ \emph{vector} \emph{expression}) stores \emph{expression} in every element of \emph{vector}. \RRRRRS~27. (\texttt{vector-length} \emph{vector}) returns the number of elements in \emph{vector}. \RRRRRS~27. (\texttt{vector->list} \emph{vector}) returns a newly created \emph{list} of the objects contained in the elements of the \emph{vector}. \RRRRRS~27. (\texttt{vector-ref} \emph{vector} \emph{integer}) returns the contents of element \emph{integer} of \emph{vector}. The first element is 0. \RRRRRS~27. (\texttt{vector-set!}\ \emph{vector} \emph{integer} \emph{expression}) sets element \emph{integer} of \emph{vector} to \emph{expression}. The first element is 0. \RRRRRS~27. (\texttt{vector?}\ \emph{expression}) \emph{predicate} that returns \texttt{\#t} when \emph{expression} is a \emph{vector}. \RRRRRS~26. \texttt{void} \emph{syntax} for declaring a non-Scheme procedure as returning the C type \texttt{void}. The value of such a procedure may not be used. (\texttt{wait-system-file} \emph{expression}) waits for input on the file with the system file number \emph{expression}. When input is available, the procedure returns. If \emph{expression} is equal to \texttt{\#f}, then the procedure will not return until all tasks have been completed. (\texttt{weak-cons} \emph{expression}$_1$ \emph{expression}$_2$) returns a newly allocated \emph{pair} that has \emph{expression}$_1$ as its \texttt{car}, and \emph{expression}$_2$ as its \texttt{cdr}. If the garbage collector discovers that pointers to an object only exist in the \texttt{car}'s of \emph{pair}s created by \texttt{weak-cons}, then it may recover the object and set the \texttt{car}'s in those \emph{pair}s to \texttt{\#f}. (\texttt{when} \emph{expression}$_1$ \emph{expression}$_2$ ...)\ \emph{syntax} for a conditional form that is equivalent to (\texttt{if} \emph{expression}$_1$ (\texttt{begin} \emph{expression}$_2$ ...)). (\texttt{when-unreferenced} \emph{expression} \emph{procedure}) applies the clean-up procedure \emph{procedure} (with the object represented by \emph{expression} as its argument) at some point in the future when the object represented by \emph{expression} is no longer referenced by the program. The procedure returns either the cleanup procedure supplied by an earlier call to \texttt{when-unreferenced}, or \texttt{\#f} when no cleanup procedure was defined. (\texttt{when-unreferenced} \emph{expression} \texttt{\#f}) returns either the cleanup procedure for the object represented by \emph{expression} or \texttt{\#f} when no cleanup procedure was defined. In either case, the Scheme system will take no action when the object represented by \emph{expression} is no longer referenced by the program. (\texttt{with-input-from-file} \emph{string} \emph{procedure}) opens the file \emph{string}, makes its \emph{port} the default \emph{input-port}, then calls \emph{procedure} with no arguments. \RRRRRS~30. (\texttt{with-output-to-file} \emph{string} \emph{procedure}) opens the file \emph{string}, makes its \emph{port} the default \emph{output-port}, then calls \emph{procedure} with no arguments. \RRRRRS~30. (\texttt{write} \emph{expression} \emph{optional-output-port}) outputs \emph{expression} to \emph{optional-output-port} in a machine-readable form. \RRRRRS~31. (\texttt{write-char} \emph{character} \emph{optional-output-port}) outputs \emph{character} to \emph{optional-output-port}. \RRRRRS~31. (\texttt{write-circle} \emph{optional-output-port}) returns a \emph{boolean} indicating whether circular objects are detected when output to \emph{optional-output-port}. (\texttt{write-count} \emph{optional-output-port}) returns the number of characters on the current line in \emph{optional-output-port}. (\texttt{write-length} \emph{optional-output-port}) returns either an \emph{integer} indicating the maximum length vector or list printed on \emph{optional-output-port}, or \texttt{\#f} indicating that arbitrary length objects are printed on \emph{optional-output-port}. (\texttt{write-level} \emph{optional-output-port}) returns either an \emph{integer} indicating the maximum nesting depth of objects that are printed on \emph{optional-output-port}, or \texttt{\#f} indicating that arbitrary depth objects are printed on \emph{optional-output-port}. (\texttt{write-pretty} \emph{optional-output-port}) returns a \emph{boolean} indicating whether pretty-printing is done on \emph{optional-output-port}. (\texttt{write-width} \emph{optional-output-port}) returns the width of \emph{optional-output-port} in \emph{characters}. (\texttt{zero?}\ \emph{number}) predicate that returns \texttt{\#t} when \emph{number} is zero. \RRRRRS~21. \texttt{\texttildelow\%} \emph{format descriptor} to output a newline character. \texttt{\texttildelow\texttildelow} \emph{format descriptor} to output a \texttt{\texttildelow}. \texttt{\texttildelow{}A} \emph{format descriptor} to output the next \emph{expression} using \texttt{display}. \texttt{\texttildelow{}a} \emph{format descriptor} identical to \texttt{\texttildelow{}A}. \texttt{\texttildelow{}C} \emph{format descriptor} to output the next \emph{expression} (that must be a \emph{character}) using \texttt{write-char}. \texttt{\texttildelow{}c} \emph{format descriptor} identical to \texttt{\texttildelow{}C}. \texttt{\texttildelow{}S} \emph{format descriptor} to output the next \emph{expression} using \texttt{write}. \texttt{\texttildelow{}s} \emph{format descriptor} identical to \texttt{\texttildelow{}S}. \end{document} scheme2c-2012.10.14/doc/intro.tex000066400000000000000000000235051203736146400162300ustar00rootroot00000000000000\documentclass[11pt]{article} \usepackage{fullpage} \usepackage{parskip} \usepackage{newcent} \usepackage{s2c} \title{An Introduction to \StoC\ in 19 Prompts} \author{Joel F. Bartlett} \date{12 August 1988} \begin{document} \maketitle \StoC\ is an implementation of the language Scheme. Besides the usual interpreter, the implementation includes an unusual compiler which compiles Scheme to C. This allows stand-alone programs and programs combining Scheme and other programming languages. The implementation is also highly portable and when combined with a good C compiler, fairly efficient. Please consider this annotated typescript an invitation to try it. Questions and comments are encouraged. \begin{small} \begin{quote} \begin{verbatim} alerion 1 >man s2ci S2CI(1) UNIX Programmer's Manual S2CI(1) NAME s2ci - Scheme interpreter SYNTAX s2ci [ option ] DESCRIPTION The s2ci command invokes a Scheme interpreter. The language accepted by ... \end{verbatim} \end{quote} \end{small} Using your favorite editor, create a file containing the Fibonacci function. Scheme code is generally expected to be in files ending with ``.sc''. \begin{small} \begin{quote} \begin{verbatim} alerion 2>more fib.sc ;;; (FIB n) returns the Fibonacci number for n. (module fib) (define (FIB n) (cond ((> n 1) (+ (fib (- n 1)) (fib (- n 2)))) ((= n 1) 1) ((= n 0) 0) (else (error 'FIB "Argument is out of range: ~s" n)))) \end{verbatim} \end{quote} \end{small} A ``;'' indicates that the rest of the line is a comment. The form \texttt{(module fib)}, which must be the first form in the file, indicates that the functions in the file should be part of the module ``fib''. Typically the module name is the file name (less the ``.sc'' extension) of the source file. \begin{small} \begin{quote} \begin{verbatim} alerion 3 >s2ci SCHEME->C -- 08aug88jfb -- Copyright 1988 Digital Equipment Corporation > (load "fib.sc") MODULE form ignored FIB "fib.sc" \end{verbatim} \end{quote} \end{small} \texttt{(load "\textnormal{\emph{file-name}}")} loads a file into the interpreter. Each form in the file is evaluated and the result is printed on the standard output device. Note that the module form is currently ignored by the interpreter. Another way to load the file is to use \texttt{(loade "\textnormal{\emph{file-name}}")} which will also echo the text read from the file onto the standard output file. Since \texttt{FIB} was defined when this function was evaluated, a warning message is printed: \begin{small} \begin{quote} \begin{verbatim} > (loade "fib.sc") ;;; (FIB n) returns the Fibonacci number for n. (module fib) MODULE form ignored (define (FIB n) (cond ((> n 1) (+ (fib (- n 1)) (fib (- n 2)))) ((= n 1) 1) ((= n 0) 0) (else (error 'FIB "Argument is out of range: ~s" n)))) ***** FIB is redefined FIB "fib.sc" > (fib 1) 1 > (fib 2) 1 > (fib 0) 0 > (fib -1) ***** FIB Argument is out of range: -1 \end{verbatim} \end{quote} \end{small} (\texttt{trace} \emph{function} ...) allows one or more functions to be traced. (\texttt{untrace} \emph{function} ...) removes tracing from selected functions, and (\texttt{untrace}) removes tracing from all functions. \begin{small} \begin{quote} \begin{verbatim} > (trace fib) (FIB) > (fib 5) (FIB 5) (FIB 4) (FIB 3) (FIB 2) (FIB 1) ==> 1 (FIB 0) ==> 0 ==> 1 (FIB 1) ==> 1 ==> 2 (FIB 2) (FIB 1) ==> 1 (FIB 0) ==> 0 ==> 1 ==> 3 (FIB 3) (FIB 2) (FIB 1) ==> 1 (FIB 0) ==> 0 ==> 1 (FIB 1) ==> 1 ==> 2 ==> 5 5 > (untrace) (FIB) \end{verbatim} \end{quote} \end{small} \texttt{(bpt \textnormal{\emph{function}})} sets a breakpoint on function entry and exit. At the function call, the arguments are in \texttt{*args*} which may be changed. After completing inspection, type \^D to evaluate the function. On function exit, the result is in \texttt{*result*} and the program stops for inspection. To continue with that result, one types \^D or \texttt{(proceed)}. A different result may be returned by entering \texttt{(proceed \textnormal{\emph{expression}})}. \texttt{(unbpt \textnormal{\emph{function ...}})} removes breakpoints from selected functions, and \texttt{(unbpt)} removes all breakpoints. While at a breakpoint, one may return to the ``top-level'' interpreter by executing the function \texttt{(top-level)}. \begin{small} \begin{quote} \begin{verbatim} > (bpt fib) FIB > (fib 1) 0 -calls - (FIB 1) 0- *args* (1) 0- ^D 0 -returns- 1 0- *result* 1 0- (proceed 23.7) 23.7 0- ^D 23.7 > (unbpt fib) (FIB) \end{verbatim} \end{quote} \end{small} Breakpoints may also have a boolean function supplied which decides whether to take the breakpoint. Needless to say, such a function can also do things like count the number of times the function is called. \begin{small} \begin{quote} \begin{verbatim} > (bpt fib (lambda (n) (set! fibcnt (+ 1 fibcnt)) #f)) FIB > (set! fibcnt 0) 0 > (fib 5) 5 > fibcnt 15 > (unbpt fib) (FIB) > (fib 20) 6765 >^D alerion 4 > \end{verbatim} \end{quote} \end{small} Since \texttt{(fib 20)} took a while to compute, it might be a good idea to compile it, so the interpreter is exited, and an augmented version of the interpreter is created which has a compiled version of FIB. \begin{small} \begin{quote} \begin{verbatim} alerion 4 >man s2cc S2CC(1) UNIX Programmer's Manual S2CC(1) NAME s2cc - Scheme to C compiler SYNTAX s2cc [ option ] ... file ... DESCRIPTION The s2cc command invokes a Scheme compiler which accepts the language ... alerion 5 >s2cc -i -o sc+fib fib.sc fib.sc: fib.c: SC-TO-C.c: alerion 6 >sc+fib SCHEME->C -- 08aug88jfb -- Copyright 1988 Digital Equipment Corporation > fib #*PROCEDURE* > (fib 1) 1 > (fib 0) 0 > (fib 20) 6765 >^D \end{verbatim} \end{quote} \end{small} Now for a little different example, where a Scheme version of the shell command ``echo'' is created as a stand alone program. The module form now has an additional component, \texttt{(main do-echo)}, which indicates that the \texttt{do-echo} function is the program main. As with any other UNIX program, the main is called with the arguments from the shell. This is done in Scheme by providing the main with a list of strings which are the arguments. \begin{small} \begin{quote} \begin{verbatim} alerion 7 >more echo.sc ;;; ECHO - Echo Arguments ;;; ;;; % echo [options] [args] ;;; ;;; Option: ;;; -n newlines are not added to output (module echo (main do-echo)) (define (DO-ECHO clargs) (let ((nonewline (and (cdr clargs) (equal? (cadr clargs) "-n")))) (do ((args (if nonewline (cddr clargs) (cdr clargs)) (cdr args))) ((null? args) (unless nonewline (newline))) (display (car args)) (if (cdr args) (display " "))))) alerion 8> \end{verbatim} \end{quote} \end{small} The program is loaded into the interpreter and tested with a few possible values. Note that the first argument is always the program name. \begin{small} \begin{quote} \begin{verbatim} alerion 8>s2ci SCHEME->C -- 08aug88jfb -- Copyright 1988 Digital Equipment Corporation > (load "echo.sc") MODULE form ignored DO-ECHO "echo.sc" > (do-echo '("echo" "-n" "a")) a#F > (do-echo '("echo" "a" "b" "c")) a b c #F > (do-echo '("echo" "-n" "a" "b" "c")) a b c#F > (do-echo '("echo")) #F > ^D \end{verbatim} \end{quote} \end{small} Now, compile it and build a stand-alone program: \begin{small} \begin{quote} \begin{verbatim} alerion 9 >s2cc -o scheme-echo echo.sc echo.sc: alerion 10 >scheme-echo *.sc counter.sc echo.sc fib.sc fsm2.sc fsmexample.sc hello.sc alerion 11 >scheme-echo -n *.sc counter.sc echo.sc fib.sc fsm2.sc fsmexample.sc hello.scalerion 12 > \end{verbatim} \end{quote} \end{small} The next example shows the interface to routines written in other languages by building a program which uses the routines in the C library (described in the \emph{ULTRX-32 Programmer's Manual}) to print out the current Greenwich mean time. \begin{small} \begin{quote} \begin{verbatim} alerion 12 >more gmt.sc ;;; Print current GMT on standard output. (module gmt (main gmt)) (define-c-external (time pointer) int "time") (define-c-external (gmtime pointer) pointer "gmtime") (define-c-external (asctime pointer) pointer "asctime") (define (GMT clargs) (let ((current-time (make-string 4))) (time current-time) (display (c-string->string (asctime (gmtime current-time)))))) \end{verbatim} \end{quote} \end{small} The procedure \emph{time} stores the number of seconds since GMT. Jan. 1. 1970 in the location referenced by \emph{pointer}. \emph{gmtime} converts that value to a \emph{tm} structure and returns a pointer to it. \emph{asctime} then converts the referenced \emph{tm} structure to a string and returns a pointer to it. In order to display it, \emph{c-string->string} is used to make a Scheme copy of the string. \begin{small} \begin{quote} \begin{verbatim} alerion 13 >s2cc -o gmt gmt.sc gmt.sc: alerion 14 >gmt Thu Aug 11 22:19:08 1988 \end{verbatim} \end{quote} \end{small} To allay any doubts that this implementation might not be Scheme, we conclude with the following ``proof by example'', produced by Eugene Kohlbecker: \begin{small} \begin{quote} \begin{verbatim} alerion 15 >more mondo.sc (module mondo (main call-mondo)) (define (call-mondo clargs) (mondo-bizarro) (newline)) (define (mondo-bizarro) (let ((k (call-with-current-continuation (lambda (c) c)))) (display 1) (call-with-current-continuation (lambda (c) (k c))) (display 2) (call-with-current-continuation (lambda (c) (k c))) (display 3))) alerion 16 >s2ci SCHEME-C -- 08aug88jfb -- Copyright 1988 Digital Equipment Corporation > (load "mondo.sc") MODULE form ignored CALL-MONDO MONDO-BIZARRO "mondo.sc" > (call-mondo '()) 11213 #F > ^D alerion 17 >s2cc -o mondo mondo.sc mondo.sc: alerion 18 >mondo 11213 alerion 19 >logout \end{verbatim} \end{quote} \end{small} \end{document} scheme2c-2012.10.14/doc/makefile000066400000000000000000000021531203736146400160470ustar00rootroot00000000000000# Makes the documentation files. pdfs = embedded.pdf index.pdf intro.pdf smithnotes.pdf # building r4rs.pdf requires latex209 which is not typically available, # so by default do not build/install it. #pdfs += r4rs.pdf all: $(pdfs) prefix=/usr/local DOCDIR=$(prefix)/doc/scheme2c MANDIR=$(prefix)/man INSTALL = install INSTALL_DATA = ${INSTALL} -m 644 INSTALL_PROGRAM = ${INSTALL} INSTALL_SCRIPT = ${INSTALL} .SUFFIXES: .SUFFIXES: .tex .dvi .ps .pdf TEX=latex %.ps: %.dvi; dvips -K -Ppdf -G0 -R0 -q -tletter -o $@ $< %.pdf: %.ps; ps2pdf $< $@ export TEXINPUTS r4rs.dvi: TEXINPUTS=r4rs: r4rs.dvi: TEX=latex209 r4rs.dvi: r4rs/r4rs.tex $(TEX) -output-directory=. $< install: install-pdf install-man install-pdf: $(pdfs) $(INSTALL) -d $(DESTDIR)$(DOCDIR) $(INSTALL_DATA) $(pdfs) $(DESTDIR)$(DOCDIR)/ install-man: $(INSTALL) -d $(DESTDIR)$(MANDIR)/man1 $(INSTALL_DATA) s2cc.l $(DESTDIR)$(MANDIR)/man1/s2cc.1 $(INSTALL_DATA) s2ci.l $(DESTDIR)$(MANDIR)/man1/s2ci.1 ln -sf s2ci.1 $(DESTDIR)$(MANDIR)/man1/sci.1 ln -sf s2cc.1 $(DESTDIR)$(MANDIR)/man1/scc.1 clean: -rm -rf *.pdf *.dvi *.aux *.log *.BAK *.CKP *.toc *.idx scheme2c-2012.10.14/doc/r4rs/000077500000000000000000000000001203736146400152405ustar00rootroot00000000000000scheme2c-2012.10.14/doc/r4rs/NOTES000066400000000000000000000002261203736146400160530ustar00rootroot00000000000000Contents obtained via: wget --mirror --no-parent http://www2.lifl.fr/~routier/debScheme/docs/r4rs/r4rs.tex/. rm *.html* *.LOG dos2unix -o -p * scheme2c-2012.10.14/doc/r4rs/algol60.sty000066400000000000000000001247251203736146400172600ustar00rootroot00000000000000% Document style "algol60" % ALGOL60 DOCUMENT STYLE % for LaTeX version 2.09 % Copyright (C) 1985 by Leslie Lamport % Hacked To Death (H) 1986 by Jonathan Rees from Lamport's REPORT and % REP11 document styles \typeout{Document Style 'algol60'.} % The type size option is handled by reading a different file for each % size, as follows, to define font size-specific commands: % 10pt : REP10, 11pt : REP11, 12pt : REP12 % Implemented by \def'ing \@ptsize to last digit of file name. % \def\@ptsize{0} % Default is REP10.STY \@namedef{ds@11pt}{\def\@ptsize{1}} % 11pt option reads in REP11.STY \@namedef{ds@12pt}{\def\@ptsize{2}} % 12pt option reads in REP12.STY % Two-side or one-side printing. % % \@twosidefalse % Default is one-sided printing. \def\ds@twoside{\@twosidetrue % Defines twoside option. \@mparswitchtrue} % Marginpars go on outside of page. % draft option % % \overfullrule = 0pt % Default is don't mark overfull hboxes. \def\ds@draft{\overfullrule 5pt} % Causes overfull hboxes to be marked. % The \@options command causes the execution of every command \ds@FOO % which is defined and for which the user typed the FOO option in his % \documentstyle command. For every option BAR he typed for which % \ds@BAR is not defined, the file BAR.sty will be read after the present % (main) .STY file is executed. \@options % REPORT DOCUMENT STYLE -- Released 23 September 1985 % for LaTeX version 2.09 % Copyright (C) 1985 by Leslie Lamport % **************************************** % * FONTS * % **************************************** % \lineskip 1pt % \lineskip is 1pt for all font sizes. \normallineskip 1pt \def\baselinestretch{1} % Each size-changing command \SIZE executes the command % \@setsize\SIZE{BASELINESKIP}\FONTSIZE\@FONTSIZE % where: % BASELINESKIP = Normal value of \baselineskip for that size. (Actual % value will be \baselinestretch * BASELINESKIP.) % % \FONTSIZE = Name of font-size command. The currently available % (preloaded) font sizes are: \vpt (5pt), \vipt (6pt), % \viipt (etc.), \viiipt, \ixpt, \xpt, \xipt, \xiipt, % \xivpt, \xviipt, \xxpt, \xxvpt. % \@FONTSIZE = The same as the font-size command except with an % '@' in front---e.g., if \FONTSIZE = \xivpt then % \@FONTSIZE = \@xivpt. % % For reasons of efficiency that needn't concern the designer, % the document style defines \@normalsize instead of \normalsize . This is % done only for \normalsize, not for any other size-changing commands. \def\@normalsize{\@setsize\normalsize{12pt}\xpt\@xpt \abovedisplayskip 4pt plus2pt minus3pt%!! was 10pt plus2pt minus5pt% \belowdisplayskip \abovedisplayskip \abovedisplayshortskip \z@ plus3pt% \belowdisplayshortskip 6pt plus3pt minus3pt} \def\small{\@setsize\small{11pt}\ixpt\@ixpt \abovedisplayskip 8.5pt plus 3pt minus 4pt% \belowdisplayskip \abovedisplayskip \abovedisplayshortskip \z@ plus2pt% \belowdisplayshortskip 4pt plus2pt minus 2pt \def\@listi{\topsep 4pt plus 2pt minus 2pt\parsep 2pt plus 1pt minus 1pt \itemsep \parsep}} \def\footnotesize{\@setsize\footnotesize{9.5pt}\viiipt\@viiipt \abovedisplayskip 6pt plus 2pt minus 4pt% \belowdisplayskip \abovedisplayskip \abovedisplayshortskip \z@ plus 1pt% \belowdisplayshortskip 3pt plus 1pt minus 2pt \def\@listi{\topsep 3pt plus 1pt minus 1pt\parsep 2pt plus 1pt minus 1pt \itemsep \parsep}} \def\sc{\@setsize\scriptsize{8pt}\viipt\@viipt} %!! Small caps \def\scriptsize{\@setsize\scriptsize{8pt}\viipt\@viipt} \def\tiny{\@setsize\tiny{6pt}\vpt\@vpt} \def\large{\@setsize\large{14pt}\xiipt\@xiipt} \def\Large{\@setsize\Large{18pt}\xivpt\@xivpt} \def\LARGE{\@setsize\LARGE{22pt}\xviipt\@xviipt} \def\huge{\@setsize\huge{25pt}\xxpt\@xxpt} \def\Huge{\@setsize\Huge{30pt}\xxvpt\@xxvpt} \normalsize % Choose the normalsize font. % **************************************** % * PAGE LAYOUT * % **************************************** % % All margin dimensions measured from a point one inch from top and side % of page. % Side margin sizes are actually negative (see output routine). % Total of 1.2" of margin available. % .6 / .6 --> .4 / .4 -- split evenly % .5 / .7 --> .5 / .3 -- for even/odd % .43 / .61 --> .57 / .39 -- Tuned for Charmin % SIDE MARGINS: \if@twoside % Values for two-sided printing: \oddsidemargin .25in %will -.6in % 44pt % Left margin on odd-numbered pages. \evensidemargin .25in %will -.6in % 82pt % Left margin on even-numbered pages. \marginparwidth 107pt % Width of marginal notes. \else % Values for one-sided printing: \oddsidemargin -.6in % \evensidemargin -.6in % \marginparwidth 90pt \fi \marginparsep 11pt % Horizontal space between outer margin and % marginal note %%% ----- Clobber outputpage to do a moveleft instead of a moveright. \def\@outputpage{\begingroup\catcode`\ =10 \if@specialpage \global\@specialpagefalse\@nameuse{ps@\@specialstyle}\fi \if@twoside \ifodd\count\z@ \let\@thehead\@oddhead \let\@thefoot\@oddfoot \let\@themargin\oddsidemargin \else \let\@thehead\@evenhead \let\@thefoot\@evenfoot \let\@themargin\evensidemargin \fi\fi \shipout \vbox{\normalsize \baselineskip\z@ \lineskip\z@ \vskip \topmargin \moveleft\@themargin % CLOBBERRED HERE. \vbox{\setbox\@tempboxa \vbox to\headheight{\vfil \hbox to\textwidth{\@thehead}} \dp\@tempboxa\z@ \box\@tempboxa \vskip \headsep \box\@outputbox \baselineskip\footskip \hbox to\textwidth{\@thefoot}}}\global\@colht\textheight \endgroup\stepcounter{page}\let\firstmark\botmark} %%% ----- End clobberage. % VERTICAL SPACING: % Go for .625" margins all around. % (SIGPLAN only needs .5", but let's play it safe.) % Top of page: % (- 1 0.625) \topmargin -.375in %!! 27pt % Nominal distance from top of page to top of % box containing running head. \headheight 12pt % Height of box containing running head. \headsep 15pt %! was 20 % Space between running head and text. % \topskip = 10pt % '\baselineskip' for first line of page. % Bottom of page: \footheight 12pt % Height of box containing running foot. \footskip 23pt % Distance from baseline of box containing foot % to baseline of last line of text. % DIMENSION OF TEXT: % 11 inches minus (2 * .625) inches minus (12 + 15) points % (- (* (- 11 (* 2 0.625)) 72.27) 12 15) = 677 formerly % (- (* (+ (- 11 (+ 0.5 0.625)) 0.15) 72.27) 12 15 12 23) = 662 \textheight 663pt %!! 528pt % Height of text (including footnotes and figures, % excluding running head and foot). % For some reason, the above comment doesn't seem to be correct. % So we add in about 0.15" as a fudge factor. % Experimental method at work. % (* (- 8.5 (* 2 .625)) 72.27) = 523 \textwidth 523pt %!! 345pt % Width of text line. % For two-column mode: \columnsep 15pt %!!10pt % Space between columns \columnseprule 0pt % Width of rule between columns. % A \raggedbottom command causes 'ragged bottom' pages: pages set to % natural height instead of being stretched to exactly \textheight. % FOOTNOTES: \footnotesep 6.65pt % Height of strut placed at the beginning of every % footnote = height of normal \footnotesize strut, % so no extra space between footnotes. \skip\footins 9pt plus 4pt minus 2pt % Space between last line of text and % top of first footnote. % FLOATS: (a float is something like a figure or table) % % FOR FLOATS ON A TEXT PAGE: % % ONE-COLUMN MODE OR SINGLE-COLUMN FLOATS IN TWO-COLUMN MODE: \floatsep 12pt plus 2pt minus 2pt % Space between adjacent floats moved % to top or bottom of text page. \textfloatsep 20pt plus 2pt minus 4pt % Space between main text and floats % at top or bottom of page. \intextsep 12pt plus 2pt minus 2pt % Space between in-text figures and % text. \@maxsep 20pt % The maximum of \floatsep, % \textfloatsep and \intextsep (minus % the stretch and shrink). % TWO-COLUMN FLOATS IN TWO-COLUMN MODE: \dblfloatsep 12pt plus 2pt minus 2pt % Same as \floatsep for double-column % figures in two-column mode. \dbltextfloatsep 20pt plus 2pt minus 4pt % \textfloatsep for double-column % floats. \@dblmaxsep 20pt % The maximum of \dblfloatsep and % \dbltexfloatsep. % FOR FLOATS ON A SEPARATE FLOAT PAGE OR COLUMN: % ONE-COLUMN MODE OR SINGLE-COLUMN FLOATS IN TWO-COLUMN MODE: \@fptop 0pt plus 1fil % Stretch at top of float page/column. (Must be % 0pt plus ...) \@fpsep 8pt plus 2fil % Space between floats on float page/column. \@fpbot 0pt plus 1fil % Stretch at bottom of float page/column. (Must be % 0pt plus ... ) % DOUBLE-COLUMN FLOATS IN TWO-COLUMN MODE. \@dblfptop 0pt plus 1fil % Stretch at top of float page. (Must be 0pt plus ...) \@dblfpsep 8pt plus 2fil % Space between floats on float page. \@dblfpbot 0pt plus 1fil % Stretch at bottom of float page. (Must be % 0pt plus ... ) % MARGINAL NOTES: % \marginparpush 5pt % Minimum vertical separation between two marginal % notes. % **************************************** % * PARAGRAPHING * % **************************************** % \parskip 5pt plus 2pt minus 2pt %!! 0pt plus 1pt % Extra vertical space between paragraphs. \parindent 0pt %!! 15pt % Width of paragraph indentation. \topsep 0pt plus 2pt %!! 8pt plus 2pt minus 4pt % Extra vertical space, in addition to % \parskip, added above and below list and % paragraphing environments. \partopsep 2pt plus 1pt minus 1pt % Extra vertical space, in addition to % \parskip and \topsep, added when user % leaves blank line before environment. \itemsep 4pt plus 2pt minus 1pt % Extra vertical space, in addition to % \parskip, added between list items. % The following page-breaking penalties are defined \@lowpenalty 51 % Produced by \nopagebreak[1] or \nolinebreak[1] \@medpenalty 151 % Produced by \nopagebreak[2] or \nolinebreak[2] \@highpenalty 301 % Produced by \nopagebreak[3] or \nolinebreak[3] \@beginparpenalty -\@lowpenalty % Before a list or paragraph environment. \@endparpenalty -\@lowpenalty % After a list or paragraph environment. \@itempenalty -\@lowpenalty % Between list items. % \clubpenalty % 'Club line' at bottom of page. % \widowpenalty % 'Widow line' at top of page. % \displaywidowpenalty % Math display widow line. % \predisplaypenalty % Breaking before a math display. % \postdisplaypenalty % Breaking after a math display. % \interlinepenalty % Breaking at a line within a paragraph. % \brokenpenalty % Breaking after a hyphenated line. % **************************************** % * CHAPTERS AND SECTIONS * % **************************************** % % %!! [Parts flushed - R^3RS doesn't need] %!! Chapter headings hacked for R^3RS % \@makechapterhead {TEXT} : Makes the heading for the \chapter command. % \def\@makechapterhead#1{ % Heading for \chapter command \vspace{3ex plus 1ex minus 1ex} % Space at top of text page. [NOT *] { \parindent 0pt \raggedright \ifnum \c@secnumdepth >\m@ne % IF secnumdepth > -1 THEN \large\bf \@chapapp{} \thechapter. % Print ['Chapter' and] number. %\par % Space between number and title. %\vskip 3ex \quad \fi \large \bf % Title. #1\par \nobreak % TeX penalty to prevent page break. \vskip 1ex % Space between title and text. } } \def\@chapapp{} % \@makeschapterhead {TEXT} : Makes the heading for the \chapter* command. % % ALGOL 60 report style headings \def\@makeschapterhead#1{ % Heading for \chapter* command \vskip 4ex plus 1ex minus 1ex % Space at top of page. { %\parindent 0pt \raggedright \centerline{\large\bf\uppercase{#1}} %\large \bf % Title. %#1\par \nobreak % TeX penalty to prevent page break. \vskip 1ex %!! % Space between title and text. } } % \secdef{UNSTARCMDS}{STARCMDS} : % When defining a \chapter or \section command without using % \@startsection, you can use \secdef as follows: % \def\chapter { ... \secdef \CMDA \CMDB } % \def\CMDA [#1]#2{ ... } % Command to define \chapter[...]{...} % \def\CMDB #1{ ... } % Command to define \chapter*{...} \def\chapter{ %!!\clearpage % Starts new page. [column] %!! \thispagestyle{plain} % Page style of chapter page is 'plain' \global\@topnum\z@ % Prevents figures from going at top of page. %\@afterindentfalse % Suppresses indent in first paragraph. Change \secdef\@chapter\@schapter} % to \@afterindenttrue to have indent. \def\@chapter[#1]#2{\ifnum \c@secnumdepth >\m@ne \refstepcounter{chapter} \typeout{\@chapapp\space\thechapter.} \addcontentsline{toc}{chapter}{\protect \numberline{\thechapter}#1}\else \addcontentsline{toc}{chapter}{#1}\fi \chaptermark{#1} \addtocontents{lof}{\protect\addvspace{10pt}} % Adds between-chapter space \addtocontents{lot}{\protect\addvspace{10pt}} % to lists of figs & tables. %!!\if@twocolumn % Tests for two-column mode. %!!\@topnewpage[\@makechapterhead{#2}] %\else \@makechapterhead{#2} \@afterheading % Routine called after chapter and %\fi } % section heading. \def\@schapter#1{ %!! \if@twocolumn \@topnewpage[\@makeschapterhead{#1}] %\else \@makeschapterhead{#1} \@afterheading %\fi } % \@startsection {NAME}{LEVEL}{INDENT}{BEFORESKIP}{AFTERSKIP}{STYLE} % optional * [ALTHEADING]{HEADING} % Generic command to start a section. % NAME : e.g., 'subsection' % LEVEL : a number, denoting depth of section -- e.g., chapter=1, % section = 2, etc. A section number will be printed if % and only if LEVEL < or = the value of the secnumdepth % counter. % INDENT : Indentation of heading from left margin % BEFORESKIP : Absolute value = skip to leave above the heading. % If negative, then paragraph indent of text following % heading is suppressed. % AFTERSKIP : if positive, then skip to leave below heading, % else - skip to leave to right of run-in heading. % STYLE : commands to set style % If '*' missing, then increments the counter. If it is present, then % there should be no [ALTHEADING] argument. A sectioning command % is normally defined to \@startsection + its first six arguments. \def\section{\@startsection {section}{1}{\z@}{-2.5ex plus -1ex minus -.2ex}{ 2pt plus .2ex}{\large\bf}} % was 2.3ex \def\subsection{\@startsection{subsection}{2}{\z@}{-2ex plus -1ex minus -.2ex}{1pt plus .2ex}{\normalsize\bf}} % was 1.5 \def\subsubsection{\@startsection{subsubsection}{3}{\z@}{-2ex plus -1ex minus -.2ex}{1pt plus .2ex}{\normalsize}} %!! was \bf % was 1.5ex \def\paragraph{\@startsection {paragraph}{4}{\z@}{2ex plus 1ex minus .2ex}{-1em}{\normalsize\bf}} \def\subparagraph{\@startsection {subparagraph}{4}{\parindent}{2ex plus 1ex minus .2ex}{-1em}{\normalsize\bf}} %!! Mutation to @sect: cause point to come out after section number! %!! The modification is trivial: a "." added in the third line. \def\@sect#1#2#3#4#5#6[#7]#8{\ifnum #2>\c@secnumdepth \def\@svsec{}\else \refstepcounter{#1}\edef\@svsec{\csname the#1\endcsname.\hskip 1em }\fi \@tempskipa #5\relax \ifdim \@tempskipa>\z@ \begingroup #6\relax \@hangfrom{\hskip #3\relax\@svsec}{\interlinepenalty \@M #8\par} \endgroup \csname #1mark\endcsname{#7}\addcontentsline {toc}{#1}{\ifnum #2>\c@secnumdepth \else \protect\numberline{\csname the#1\endcsname}\fi #7}\else \def\@svsechd{#6\hskip #3\@svsec #8\csname #1mark\endcsname {#7}\addcontentsline {toc}{#1}{\ifnum #2>\c@secnumdepth \else \protect\numberline{\csname the#1\endcsname}\fi #7}}\fi \@xsect{#5}} %!! Mutation to the \numberline command, similar to above. \def\numberline#1{\advance\hangindent\@tempdima \hbox to\@tempdima{#1.\hfil}} % Default initializations of \...mark commands. (See below for their % us in defining page styles. % \def\chaptermark#1{} % \def\sectionmark#1{} % Preloaded definitions % \def\subsectionmark#1{} % \def\subsubsectionmark#1{} % \def\paragraphmark#1{} % \def\subparagraphmark#1{} % The value of the counter secnumdepth gives the depth of the % highest-level sectioning command that is to produce section numbers. % \setcounter{secnumdepth}{2} %!!! CLOBBER ARABIC COMMAND TO ALLOW FOR CHAPTER, SECTION, ETC. ZERO \def\@arabic#1{\ifnum #1>\m@ne \number #1\fi} %\def\@definecounter#1{\expandafter\newcount\csname c@#1\endcsname % \setcounter{#1}\m@ne \expandafter\gdef\csname cl@#1\endcsname{}\@addtoreset % {#1}{@ckpt}\expandafter\gdef\csname p@#1\endcsname{}\expandafter % \gdef\csname the#1\endcsname{\arabic{#1}}} %\def\usecounter#1{\@nmbrlisttrue\def\@listctr{#1}\setcounter{#1}\m@ne} % APPENDIX % % The \appendix command must do the following: % -- reset the chapter counter to zero % -- set \@chapapp to Appendix (for messages) % -- redefine the chapter counter to produce appendix numbers % -- reset the section counter to zero % -- redefine the \chapter command if appendix titles and headings are % to look different from chapter titles and headings. \def\appendix{\par \setcounter{chapter}{0} \setcounter{section}{0} \def\@chapapp{Appendix} \def\thechapter{\Alph{chapter}}} % **************************************** % * LISTS * % **************************************** % % The following commands are used to set the default values for the list % environment's parameters. See the LaTeX manual for an explanation of % the meanings of the parameters. Defaults for the list environment are % set as follows. First, \rightmargin, \listparindent and \itemindent % are set to 0pt. Then, for a Kth level list, the command \@listK is % called, where 'K' denotes 'i', 'ii', ... , 'vi'. (I.e., \@listiii is % called for a third-level list.) By convention, \@listK should set % \leftmargin to \leftmarginK. % % For efficiency, level-one list's values are defined at top level, and % \@listi is defined to set only \leftmargin. \leftmargini 25pt \leftmarginii 22pt % > \labelsep + width of '(m)' \leftmarginiii 18.7pt % > \labelsep + width of 'vii.' \leftmarginiv 17pt % > \labelsep + width of 'M.' \leftmarginv 10pt \leftmarginvi 10pt \leftmargin\leftmargini \labelwidth\leftmargini\advance\labelwidth-\labelsep \labelsep 5pt \parsep 4pt plus 2pt minus 1pt \def\@listi{\leftmargin\leftmargini} \def\@listii{\leftmargin\leftmarginii \labelwidth\leftmarginii\advance\labelwidth-\labelsep \topsep 4pt plus 2pt minus 1pt \parsep 2pt plus 1pt minus 1pt \itemsep \parsep} \def\@listiii{\leftmargin\leftmarginiii \labelwidth\leftmarginiii\advance\labelwidth-\labelsep \topsep 2pt plus 1pt minus 1pt \parsep \z@ \partopsep 1pt plus 0pt minus 1pt \itemsep \topsep} \def\@listiv{\leftmargin\leftmarginiv \labelwidth\leftmarginiv\advance\labelwidth-\labelsep} \def\@listv{\leftmargin\leftmarginv \labelwidth\leftmarginv\advance\labelwidth-\labelsep} \def\@listvi{\leftmargin\leftmarginvi \labelwidth\leftmarginvi\advance\labelwidth-\labelsep} % File REPORT.DOC, continued % **************************************** % * LISTS * % **************************************** % % ENUMERATE % Enumeration is done with four counters: enumi, enumii, enumiii % and enumiv, where enumN controls the numbering of the Nth level % enumeration. The label is generated by the commands \labelenumi % ... \labelenumiv. The expansion of \p@enumN\theenumN defines the % output of a \ref command. \def\labelenumi{\arabic{enumi}.} \def\theenumi{\arabic{enumi}} \def\labelenumii{(\alph{enumii})} \def\theenumii{\alph{enumii}} \def\p@enumii{\theenumi} \def\labelenumiii{\roman{enumiii}.} \def\theenumiii{\roman{enumiii}} \def\p@enumiii{\theenumi(\theenumii)} \def\labelenumiv{\Alph{enumiv}.} \def\theenumiv{\Alph{enumiv}} \def\p@enumiv{\p@enumiii\theenumiii} % ITEMIZE % Itemization is controlled by four commands: \labelitemi, \labelitemii, % \labelitemiii, and \labelitemiv, which define the labels of the various % itemization levels. \def\labelitemi{$\bullet$} \def\labelitemii{\bf --} \def\labelitemiii{$\ast$} \def\labelitemiv{$\cdot$} % VERSE % The verse environment is defined by making clever use of the % list environment's parameters. The user types \\ to end a line. % This is implemented by \let'in \\ equal \@centercr. % \def\verse{\let\\=\@centercr \list{}{\itemsep\z@ \itemindent -1.5em\listparindent \itemindent \rightmargin\leftmargin\advance\leftmargin 1.5em}\item[]} \let\endverse\endlist % QUOTATION % Fills lines % Indents paragraph % \def\quotation{\list{}{\listparindent 1.5em \itemindent\listparindent \rightmargin\leftmargin\parsep 0pt plus 1pt}\item[]} \let\endquotation=\endlist % QUOTE -- same as quotation except no paragraph indentation, % \def\quote{\list{}{\rightmargin\leftmargin}\item[]} \let\endquote=\endlist % DESCRIPTION % % To change the formatting of the label, you must redefine % \descriptionlabel. \def\descriptionlabel#1{\hspace\labelsep \bf #1} \def\description{\list{}{\labelwidth\z@ \itemindent-\leftmargin \let\makelabel\descriptionlabel}} \let\enddescription\endlist \newdimen\descriptionmargin \descriptionmargin=3em % **************************************** % * OTHER ENVIRONMENTS * % **************************************** % % % THEOREM % \@begintheorem ... \@endtheorem are the commands executed at the % beginning and end of a (user-defined) theorem-like environment. % Except \@opargbegintheorem is executed when an optional argument is % given. Cf. LATEX.TEX. % % \def\@begintheorem#1#2{\it \trivlist \item[\hskip \labelsep{\bf #1\ #2}]} % \def\@opargbegintheorem#1#2#3{\it \trivlist % \item[\hskip \labelsep{\bf #1\ #2\ (#3)}]} % \def\@endtheorem{\endtrivlist} % TITLEPAGE % In the normal environments, the titlepage environment does nothing but % start and end a page, and inhibit page numbers. It also resets the % page number to zero. In two-column style, it still makes a one-column % page. \def\titlepage{\@restonecolfalse\if@twocolumn\@restonecoltrue\onecolumn \else \newpage \fi \thispagestyle{empty}\c@page\z@} \def\endtitlepage{\if@restonecol\twocolumn \else \newpage \fi} % ARRAY AND TABULAR % \arraycolsep 5pt % Half the space between columns in an array environment. \tabcolsep 6pt % Half the space between columns in a tabular environment. \arrayrulewidth .4pt % Width of rules in array and tabular environment. \doublerulesep 2pt % Space between adjacent rules in array or tabular env. % TABBING % \tabbingsep \labelsep % Space used by the \' command. (See LaTeX manual.) % MINIPAGE % \@minipagerestore is called upon entry to a minipage environment to % set up things that are to be handled differently inside a minipage % environment. In the current styles, it does nothing. % % \skip\@mpfootins : plays same role for footnotes in a minipage as % \skip\footins does for ordinary footnotes \skip\@mpfootins = \skip\footins % FRAMEBOX % \fboxsep = 3pt % Space left between box and text by \fbox and \framebox. \fboxrule = .4pt % Width of rules in box made by \fbox and \framebox. % **************************************** % * CHAPTERS AND SECTIONS * % **************************************** % % DEFINE COUNTERS: % % \newcounter{NEWCTR}[OLDCTR] : Defines NEWCTR to be a counter, which is % reset to zero when counter OLDCTR is stepped. % Counter OLDCTR must already be defined. %\newcounter{part} \newcounter {chapter} \newcounter {section}[chapter] \newcounter {subsection}[section] \newcounter {subsubsection}[subsection] \newcounter {paragraph}[subsubsection] \newcounter {subparagraph}[paragraph] % For any counter CTR, \theCTR is a macro that defines the printed version % of counter CTR. It is defined in terms of the following macros: % % \arabic{COUNTER} : The value of COUNTER printed as an arabic numeral. % \roman{COUNTER} : Its value printed as a lower-case roman numberal. % \Roman{COUNTER} : Its value printed as an upper-case roman numberal. % \alph{COUNTER} : Value of COUNTER printed as a lower-case letter: % 1 = a, 2 = b, etc. % \Alph{COUNTER} : Value of COUNTER printed as an upper-case letter: % 1 = A, 2 = B, etc. % %\def\thepart {\Roman{part}} \def\thechapter {\arabic{chapter}} \def\thesection {\thechapter.\arabic{section}} \def\thesubsection {\thesection.\arabic{subsection}} \def\thesubsubsection {\thesubsection .\arabic{subsubsection}} \def\theparagraph {\thesubsubsection.\arabic{paragraph}} \def\thesubparagraph {\theparagraph.\arabic{subparagraph}} % \@chapapp is initially defined to be 'Chapter'. The \appendix % command redefines it to be 'Appendix'. % \def\@chapapp{} %!! Chapter % **************************************** % * TABLE OF CONTENTS, ETC. * % **************************************** % % A \subsection command writes a % \contentsline{subsection}{TITLE}{PAGE} % command on the .toc file, where TITLE contains the contents of the % entry and PAGE is the page number. If subsections are being numbered, % then TITLE will be of the form % \numberline{NUM}{HEADING} % where NUM is the number produced by \thesubsection. Other sectioning % commands work similarly. % % A \caption command in a 'figure' environment writes % \contentsline{figure}{\numberline{NUM}{CAPTION}}{PAGE} % on the .lof file, where NUM is the number produced by \thefigure and % CAPTION is the figure caption. It works similarly for a 'table' environment. % % The command \contentsline{NAME} expands to \l@NAME. So, to specify % the table of contents, we must define \l@chapter, \l@section, % \l@subsection, ... ; to specify the list of figures, we must define % \l@figure; and so on. Most of these can be defined with the % \@dottedtocline command, which works as follows. % % \@dottedtocline{LEVEL}{INDENT}{NUMWIDTH}{TITLE}{PAGE} % LEVEL : An entry is produced only if LEVEL < or = value of % 'tocdepth' counter. Note, \chapter is level 0, \section % is level 1, etc. % INDENT : The indentation from the outer left margin of the start of % the contents line. % NUMWIDTH : The width of a box in which the section number is to go, % if TITLE includes a \numberline command. % % This command uses the following three parameters, which are set % with a \def (so em's can be used to make them depend upon the font). % \@pnumwidth : The width of a box in which the page number is put. % \@tocrmarg : The right margin for multiple line entries. One % wants \@tocrmarg > or = \@pnumwidth % \@dotsep : Separation between dots, in mu units. Should be \def'd to % a number like 2 or 1.7 \def\@pnumwidth{1.55em} \def\@tocrmarg {2.55em} \def\@dotsep{4.5} \setcounter{tocdepth}{1} %!! was 2 % TABLEOFCONTENTS % In report style, \tableofcontents, \listoffigures, etc. are always % set in single-column style. @restonecol %!! Except that in the R^3RS it's supposed to be one-column. \def\tableofcontents{ \chapter*{Contents\markboth{Contents}{Contents}} %!! {\parskip=0pt\@starttoc{toc}}} \def\l@chapter#1#2{\pagebreak[3] \vskip 0.5em plus 1pt % space above chapter line \@tempdima 1.5em % width of box holding chapter number \begingroup \parindent \z@ \rightskip \@pnumwidth \parfillskip -\@pnumwidth \bf % Boldface. \leavevmode % TeX command to enter horizontal mode. #1\hfil \hbox to\@pnumwidth{\hss #2}\par \endgroup} \def\l@chapter{\@dottedtocline{0}{0em}{1.2em}} %!! \def\l@section{\@dottedtocline{1}{1.5em}{2.3em}} \def\l@subsection{\@dottedtocline{2}{3.8em}{3.2em}} \def\l@subsubsection{\@dottedtocline{3}{7.0em}{4.1em}} \def\l@paragraph{\@dottedtocline{4}{10em}{5em}} \def\l@subparagraph{\@dottedtocline{5}{12em}{6em}} % LIST OF FIGURES % \def\listoffigures{\@restonecolfalse\if@twocolumn\@restonecoltrue\onecolumn \fi\chapter*{List of Figures\markboth {List of figures}{List of figures}}\@starttoc{lof}\if@restonecol\twocolumn \fi} \def\l@figure{\@dottedtocline{1}{1.5em}{2.3em}} % LIST OF TABLES % \def\listoftables{\@restonecolfalse\if@twocolumn\@restonecoltrue\onecolumn \fi\chapter*{List of Tables\markboth {List of tables}{List of tables}}\@starttoc{lot}\if@restonecol\twocolumn \fi} \let\l@table\l@figure % **************************************** % * BIBLIOGRAPHY * % **************************************** % % The thebibliography environment executes the following commands: % % \def\newblock{\hskip .11em plus .33em minus -.07em} -- % Defines the `closed' format, where the blocks (major units of % information) of an entry run together. % % \sloppy -- Used because it's rather hard to do line breaks in % bibliographies, % % \sfcode`\.=1000\relax -- % Causes a `.' (period) not toproduce an end-of-sentence space. \def\thebibliography#1{\chapter*{Bibliography and references}\markboth {Bibliography}{Bibliography}% \addcontentsline{toc}{chapter}{Bibliography and references}\list {[\arabic{enumi}]}{\settowidth\labelwidth{[#1]}\leftmargin\labelwidth \advance\leftmargin\labelsep \usecounter{enumi}} \def\newblock{\hskip .11em plus .33em minus -.07em} \sloppy \sfcode`\.=1000\relax} \let\endthebibliography=\endlist % \def\@biblabel#1{[#1]\hfill} % Produces the label for a \bibitem[...] % command. % \def\@cite#1{[#1]} % Produces the output of the \cite command. % **************************************** % * THE INDEX * % **************************************** % % THE THEINDEX ENVIRONMENT % Produces double column format, with each paragraph a separate entry. % The user commands \item, \subitem and \subsubitem are used to % produce the entries, and \indexspace adds an extra vertical space % that's the right size to put above the first entry with a new letter % of the alphabet. \newif\if@restonecol \def\theindex{%\@restonecoltrue\if@twocolumn\@restonecolfalse\fi %\columnseprule \z@ %!! \columnsep 35pt \clearpage \@topnewpage[ \centerline{\large\bf\uppercase{Alphabetic index of definitions of concepts,}} \centerline{\large\bf\uppercase{keywords, and procedures}} \vskip 1ex \bigskip] \markboth{Index}{Index} \addcontentsline{toc}{chapter}{Alphabetic index of definitions of concepts,\hfil\penalty0 \hbox{\hspace*{2em} keywords, and procedures}} \bgroup %\small \parindent\z@ \parskip\z@ plus .1pt\relax\let\item\@idxitem} \def\@idxitem{\par\hangindent 40pt} \def\subitem{\par\hangindent 40pt \hspace*{20pt}} \def\subsubitem{\par\hangindent 40pt \hspace*{30pt}} \def\endtheindex{%\if@restonecol\onecolumn\else\clearpage\fi \egroup} \def\indexspace{\par \vskip 10pt plus 5pt minus 3pt\relax} % **************************************** % * FOOTNOTES * % **************************************** % % \footnoterule is a macro to draw the rule separating the footnotes from % the text. It should take zero vertical space, so it needs a negative % skip to compensate for any positive space taken by the rule. (See % PLAIN.TEX.) \def\footnoterule{\kern-3\p@ \hrule width .4\columnwidth \kern 2.6\p@} % The \hrule has default height of .4pt . % \newcounter{footnote} \@addtoreset{footnote}{chapter} % Numbers footnotes within chapters % \@makefntext{NOTE} : % Must produce the actual footnote, using \@thefnmark as the mark % of the footnote and NOTE as the text. It is called when effectively % inside a \parbox of width \columnwidth (i.e., with \hsize = % \columnwidth). % % The following macro indents all lines of the footnote by 10pt, and % indents the first line of a new paragraph by 1em. To change these % dimensions, just substitute the desired value for '10pt' [in both % places] or '1em'. The mark is flushright against the footnote. % \long\def\@makefntext#1{\@setpar{\@@par\@tempdima \hsize % \advance\@tempdima-10pt\parshape \@ne 10pt \@tempdima}\par % \parindent 1em\noindent \hbox to \z@{\hss$^{\@thefnmark}$}#1} % % A simpler macro is used, in which the footnote text is % set like an ordinary text paragraph, with no indentation except % on the first line of a paragraph, and the first line of the % footnote. Thus, all the macro must do is set \parindent % to the appropriate value for succeeding paragraphs and put the % proper indentation before mark. \long\def\@makefntext#1{\parindent 1em\noindent \hbox to 1.8em{\hss$^{\@thefnmark}$}#1} % \@makefnmark : A macro to generate the footnote marker that goes % in the text. Default used. % % **************************************** % * FIGURES AND TABLES * % **************************************** % % Float placement parameters. See LaTeX manual for their definition. % \setcounter{topnumber}{2} \def\topfraction{.7} \setcounter{bottomnumber}{1} \def\bottomfraction{.3} \setcounter{totalnumber}{3} \def\textfraction{.2} \def\floatpagefraction{.5} \setcounter{dbltopnumber}{2} \def\dbltopfraction{.7} \def\dblfloatpagefraction{.5} % \@makecaption{NUMBER}{TEXT} : Macro to make a figure or table caption. % NUMBER : Figure or table number--e.g., 'Figure 3.2' % TEXT : The caption text. % Macro should be called inside a \parbox of right width, with \normalsize. \long\def\@makecaption#1#2{ \vskip 10pt \setbox\@tempboxa\hbox{#1: #2} \ifdim \wd\@tempboxa >\hsize % IF longer than one line: \unhbox\@tempboxa\par % THEN set as ordinary paragraph. \else % ELSE center. \hbox to\hsize{\hfil\box\@tempboxa\hfil} \fi} % To define a float of type TYPE (e.g., TYPE = figure), the document style % must define the following. % % \fps@TYPE : The default placement specifier for floats of type TYPE. % % \ftype@TYPE : The type number for floats of type TYPE. Each TYPE has % associated a unique positive TYPE NUMBER, which is a power % of two. E.g., figures might have type number 1, tables type % number 2, programs type number 4, etc. % % \ext@TYPE : The file extension indicating the file on which the % contents list for float type TYPE is stored. For example, % \ext@figure = 'lof'. % % \fnum@TYPE : A macro to generate the figure number for a caption. % For example, \fnum@TYPE == Figure \thefigure. % % The actual float-making environment commands--e.g., the commands % \figure and \endfigure--are defined in terms of the macros \@float % and \end@float, which are described below. % % \@float{TYPE}[PLACEMENT] : Macro to begin a float environment for a % single-column float of type TYPE with PLACEMENT as the placement % specifier. The default value of PLACEMENT is defined by \fps@TYPE. % The environment is ended by \end@float. % E.g., \figure == \@float{figure}, \endfigure == \end@float. % FIGURE \newcounter{figure}[chapter] \def\thefigure{\thechapter.\@arabic\c@figure} \def\fps@figure{tbp} \def\ftype@figure{1} \def\ext@figure{lof} \def\fnum@figure{Figure \thefigure} \def\figure{\@float{figure}} \let\endfigure\end@float \@namedef{figure*}{\@dblfloat{figure}} \@namedef{endfigure*}{\end@dblfloat} % TABLE % \newcounter{table}[chapter] \def\thetable{\thechapter.\@arabic\c@table} \def\fps@table{tbp} \def\ftype@table{2} \def\ext@table{lot} \def\fnum@table{Table \thetable} \def\table{\@float{table}} \let\endtable\end@float \@namedef{table*}{\@dblfloat{table}} \@namedef{endtable*}{\end@dblfloat} % **************************************** % * TITLE AND ABSTRACT * % **************************************** % % % Uses same title and abstract format as the article style's % titlepage option. % \input titlepage.sty % **************************************** % * PAGE STYLES * % **************************************** % % The page style 'foo' is defined by defining the command \ps@foo. This % command should make only local definitions. There should be no stray % spaces in the definition, since they could lead to mysterious extra % spaces in the output. % % The \ps@... command defines the macros \@oddhead, \@oddfoot, % \@evenhead, and \@evenfoot to define the running heads and % feet---e.g., \@oddhead is the macro to produce the contents of the % heading box for odd-numbered pages. It is called inside an \hbox of % width \textwidth. % % To make headings determined by the sectioning commands, the page style % defines the commands \chaptermark, \sectionmark, ... , where % \chaptermark{TEXT} is called by \chapter to set a mark, and so on. % The \...mark commands and the \...head macros are defined with the % help of the following macros. (All the \...mark commands should be % initialized to no-ops.) % % MARKING CONVENTIONS: % LaTeX extends TeX's \mark facility by producing two kinds of marks % a 'left' and a 'right' mark, using the following commands: % \markboth{LEFT}{RIGHT} : Adds both marks. % \markright{RIGHT} : Adds a 'right' mark. % \leftmark : Used in the \@oddhead, \@oddfoot, \@evenhead or \@evenfoot % macro, gets the current 'left' mark. Works like TeX's % \botmark command. % \rightmark : Used in the \@oddhead, \@oddfoot, \@evenhead or \@evenfoot % macro, gets the current 'right' mark. Works like TeX's % \firstmark command. % The marking commands work reasonably well for right marks 'numbered % within' left marks--e.g., the left mark is changed by a \chapter command and % the right mark is changed by a \section command. However, it does % produce somewhat anomalous results if two \bothmark's occur on the same page. % \mark{{}{}} % Initializes TeX's marks % \def\ps@empty{\def\@oddhead{} % \def\@oddfoot{} % \def\@evenhead{}\def\@evenfoot{}} % % \def\ps@plain{\def\@oddhead{} % \def\@oddfoot{\rm\hfil\thepage\hfil} % \def\@evenhead{} % \let\@evenfoot\@oddfoot} % Definition of 'headings' page style % Note the use of ##1 for parameter of \def\chaptermark inside the % \def\ps@headings. % %!! HACKED FOR R^3RS \if@twoside % If two-sided printing. \gdef\ps@headings{\def\@oddfoot{}\def\@evenfoot{}% No feet. \gdef\@evenhead{\rm \thepage\qquad \theevenhead \hfil}% Left heading. \gdef\@oddhead{\hbox{}\hfil \rightmark \qquad \rm\thepage}% Right heading. \gdef\chaptermark##1{\markright {{\ifnum \c@secnumdepth >\m@ne \@chapapp\ \thechapter. \ \fi ##1}}}% %\gdef\sectionmark##1{\markright {{\ifnum \c@secnumdepth >\z@ % \thesection. \ \fi ##1}}} } \else % If one-sided printing. \gdef\ps@headings{\def\@oddfoot{\hfil\thepage\hfil}\def\@evenfoot{}% \gdef\@oddhead{\theevenhead \hfil \rightmark}% Heading. \gdef\chaptermark##1{\markright {{\ifnum \c@secnumdepth >\m@ne \@chapapp\ \thechapter. \ \fi ##1}}}} \fi % Definition of 'myheadings' page style. % \def\ps@myheadings{\def\@oddhead{\hbox{}\sl\rightmark \hfil \rm\thepage}% \def\@oddfoot{}\def\@evenhead{\rm \thepage\hfil\sl\leftmark\hbox {}}% \def\@evenfoot{}\def\sectionmark##1{}\def\subsectionmark##1{}} % **************************************** % * MISCELLANEOUS * % **************************************** % % DATE % \def\today{\ifcase\month\or January\or February\or March\or April\or May\or June\or July\or August\or September\or October\or November\or December\fi \space\number\day, \number\year} % EQUATION and EQNARRAY -- put here because it must follow \chapter definition % % \newcounter{equation} % \@addtoreset{equation}{chapter} % Makes \chapter reset 'equation' counter. \def\theequation{\thechapter.\arabic{equation}} % \jot = 3pt % Extra space added between lines of an eqnarray environment % The macro \@eqnnum defines how equation numbers are to appear in equations. % % \def\@eqnnum{(\theequation)} % % **************************************** % * INITIALIZATION * % **************************************** % % Default initializations \ps@plain % 'plain' page style \pagenumbering{arabic} % Arabic page numbers \onecolumn % Single-column. \if@twoside\else\raggedbottom\fi % Ragged bottom unless twoside option. % Two-column \twocolumn \sloppy \flushbottom %\parindent 1em \leftmargini 2em \leftmarginv .5em \leftmarginvi .5em \let\topnewpage\@topnewpage scheme2c-2012.10.14/doc/r4rs/basic.tex000066400000000000000000000206321203736146400170460ustar00rootroot00000000000000%\vfill\eject \chapter{Basic concepts} \label{basicchapter} \section{Variables and regions} \label{specialformsection} \label{variablesection} Any identifier that is not a syntactic keyword\index{keyword} (see section~\ref{keywordsection}) may be used as a variable.\index{syntactic keyword}\index{identifier}\mainindex{variable} A variable may name a location where a value can be stored. A variable that does so is said to be {\em bound} to the location. The set of all visible bindings\mainindex{binding} in effect at some point in a program is known as the {\em environment} in effect at that point. The value stored in the location to which a variable is bound is called the variable's value. By abuse of terminology, the variable is sometimes said to name the value or to be bound to the value. This is not quite accurate, but confusion rarely results from this practice. \todo{Define ``assigned'' and ``unassigned'' perhaps?} \todo{In programs without side effects, one can safely pretend that the variables are bound directly to the arguments. Or: In programs without \ide{set!}, one can safely pretend that the variable is bound directly to the value. } \vest Certain expression types are used to create new locations and to bind variables to those locations. The most fundamental of these {\em binding constructs}\mainindex{binding construct} is the \lambdaexp{}\index{\lambdaexp{}}, because all other binding constructs can be explained in terms of \lambdaexp{}s. The other binding constructs are \ide{let}, \ide{let*}, \ide{letrec}, and \ide{do} expressions (see sections~\ref{lambda}, \ref{letrec}, and \ref{do}). %Note: internal definitions not mentioned here. \vest Like Algol and Pascal, and unlike most other dialects of Lisp except for Common Lisp, Scheme is a statically scoped language with block structure. To each place where a variable is bound in a program there corresponds a \defining{region} of the program text within which the binding is effective. The region is determined by the particular binding construct that establishes the binding; if the binding is established by a \lambdaexp{}, for example, then its region is the entire \lambdaexp{}. Every reference to or assignment of a variable refers to the binding of the variable that established the innermost of the regions containing the use. If there is no binding of the variable whose region contains the use, then the use refers to the binding for the variable in the top level environment, if any (section~\ref{initialenv}); if there is no binding for the identifier, it is said to be \defining{unbound}.\mainindex{bound}\index{top level environment} \todo{Mention that some implementations have multiple top level environments?} \todo{Pitman sez: needs elaboration in case of {\tt(let ...)}} \todo{Pitman asks: say something about vars created after scheme starts? {\tt (define x 3) (define (f) x) (define (g) y) (define y 4)} Clinger replies: The language was explicitly designed to permit a view in which no variables are created after Scheme starts. In files, you can scan out the definitions beforehand. I think we're agreed on the principle that interactive use should approximate that behavior as closely as possible, though we don't yet agree on which programming environment provides the best approximation.} \section{True and false} Any Scheme value can be used as a boolean value for the purpose of a conditional test. As explained in section~\ref{booleansection}, all values count as true in such a test except for \schfalse{}. % and possibly the empty list. % The only value that is guaranteed to count as % false is \schfalse{}. It is explicitly unspecified whether the empty list % counts as true or as false. This report uses the word ``true'' to refer to any Scheme value that counts as true, and the word ``false'' to refer to \schfalse{}. \mainindex{true} \mainindex{false} \begin{note} In some implementations the empty list also counts as false instead of true. \end{note} \todo{Bartley: tighten this up.} \section{External representations} \label{externalreps} An important concept in Scheme (and Lisp) is that of the {\em external representation} of an object as a sequence of characters. For example, an external representation of the integer 28 is the sequence of characters ``{\tt 28}'', and an external representation of a list consisting of the integers 8 and 13 is the sequence of characters ``{\tt(8 13)}''. The external representation of an object is not necessarily unique. The integer 28 also has representations ``{\tt \#e28.000}'' and ``{\tt\#x1c}'', and the list in the previous paragraph also has the representations ``{\tt( 08 13 )}'' and ``{\tt(8 .\ (13 .\ ()))}'' (see section~\ref{listsection}). Many objects have standard external representations, but some, such as procedures, do not have standard representations (although particular implementations may define representations for them). An external representation may be written in a program to obtain the corresponding object (see \ide{quote}, section~\ref{quote}). External representations can also be used for input and output. The procedure \ide{read} (section~\ref{read}) parses external representations, and the procedure \ide{write} (section~\ref{write}) generates them. Together, they provide an elegant and powerful input/output facility. Note that the sequence of characters ``{\tt(+ 2 6)}'' is {\em not} an external representation of the integer 8, even though it {\em is} an expression evaluating to the integer 8; rather, it is an external representation of a three-element list, the elements of which are the symbol {\tt +} and the integers 2 and 6. Scheme's syntax has the property that any sequence of characters that is an expression is also the external representation of some object. This can lead to confusion, since it may not be obvious out of context whether a given sequence of characters is intended to denote data or program, but it is also a source of power, since it facilitates writing programs such as interpreters and compilers that treat programs as data (or vice versa). The syntax of external representations of various kinds of objects accompanies the description of the primitives for manipulating the objects in the appropriate sections of chapter~\ref{initialenv}. \section{Disjointness of types} \label{disjointness} No object satisfies more than one of the following predicates: \begin{scheme} boolean? pair? symbol? number? char? string? vector? procedure?% \end{scheme} These predicates define the types {\em boolean}, {\em pair}, {\em symbol}, {\em number}, {\em char} (or {\em character}), {\em string}, {\em vector}, and {\em procedure}.\mainindex{type} \section{Storage model} \label{storagemodel} Variables and objects such as pairs, vectors, and strings implicitly denote locations\mainindex{location} or sequences of locations. A string, for example, denotes as many locations as there are characters in the string. (These locations need not correspond to a full machine word.) A new value may be stored into one of these locations using the {\tt string-set!} procedure, but the string continues to denote the same locations as before. An object fetched from a location, by a variable reference or by a procedure such as \ide{car}, \ide{vector-ref}, or \ide{string-ref}, is equivalent in the sense of \ide{eqv?} (section~\ref{equivalencesection}) to the object last stored in the location before the fetch. Every location is marked to show whether it is in use. No variable or object ever refers to a location that is not in use. Whenever this report speaks of storage being allocated for a variable or object, what is meant is that an appropriate number of locations are chosen from the set of locations that are not in use, and the chosen locations are marked to indicate that they are now in use before the variable or object is made to denote them. In many systems it is desirable for constants\index{constant} (i.e. the values of literal expressions) to reside in read-only-memory. To express this, it is convenient to imagine that every object that denotes locations is associated with a flag telling whether that object is mutable\index{mutable} or immutable\index{immutable}. The constants and the strings returned by \ide{symbol->string} are then the immutable objects, while all objects created by the other procedures listed in this report are mutable. It is an error to attempt to store a new value into a location that is denoted by an immutable object. scheme2c-2012.10.14/doc/r4rs/bib.tex000066400000000000000000000537171203736146400165330ustar00rootroot00000000000000%\extrapart{Bibliography and references} % My reference for proper reference format is: % Mary-Claire van Leunen. % {\em A Handbook for Scholars.} % Knopf, 1978. % I think the references list would look better in ``open'' format, % i.e. with the three blocks for each entry appearing on separate % lines. I used the compressed format for SIGPLAN in the interest of % space. In open format, when a block runs over one line, % continuation lines should be indented; this could probably be done % using some flavor of latex list environment. Maybe the right thing % to do in the long run would be to convert to Bibtex, which probably % does the right thing, since it was implemented by one of van % Leunen's colleagues at DEC SRC. % -- Jonathan % I tried to follow Jonathan's format, insofar as I understood it. % I tried to order entries lexicographically by authors (with singly % authored papers first), then by date. % In some cases I replaced a technical report or conference paper % by a subsequent journal article, but I think there are several % more such replacements that ought to be made. % -- Will, 1991. % This is just a personal remark on your question on the RRRS: % The language CUCH (Curry-Church) was implemented by 1964 and % is a practical version of the lambda-calculus (call-by-name). % One reference you may find in Formal Language Description Languages % for Computer Programming T.~B.~Steele, 1965 (or so). % -- Matthias Felleisen \begin{thebibliography}{999} \bibitem{Abelson88} %new Harold Abelson and Gerald Jay Sussman. Lisp: a langauge for stratified design. {\em BYTE} 13(2):207--218, February 1988. \bibitem{SICP} Harold Abelson and Gerald Jay Sussman with Julie Sussman. {\em Structure and Interpretation of Computer Programs.} MIT Press, Cambridge, 1985. \bibitem{Adams88} %new Norman Adams and Jonathan Rees. Object-oriented programming in Scheme. In {\em Proceedings of the 1988 Conference on Lisp and Functional Programming}, pages 277--288, August 1988. \bibitem{Bartley86} David H.~Bartley and John C.~Jensen. The implementation of PC Scheme. In {\em Proceedings of the 1986 ACM Conference on Lisp and Functional Programming}, pages 86--93. \bibitem{Scheme81} John Batali, Edmund Goodhue, Chris Hanson, Howie Shrobe, Richard M.~Stallman, and Gerald Jay Sussman. The Scheme-81 architecture---system and chip. In {\em Proceedings, Conference on Advanced Research in VLSI}, pages 69--77. Paul Penfield, Jr., editor. Artech House, 610 Washington Street, Dedham MA, 1982. \bibitem{Bawden88} %new Alan Bawden and Jonathan Rees. Syntactic closures. In {\em Proceedings of the 1988 ACM Symposium on Lisp and Functional Programming}, pages 86--95. \todo{Church??} \bibitem{Clinger84} William Clinger. The Scheme 311 compiler: an exercise in denotational semantics. In {\em Conference Record of the 1984 ACM Symposium on Lisp and Functional Programming}, pages 356--364. \bibitem{RRRS} William Clinger, editor. The revised revised report on Scheme, or an uncommon Lisp. MIT Artificial Intelligence Memo 848, August 1985. Also published as Computer Science Department Technical Report 174, Indiana University, June 1985. \bibitem{Clinger88} %new William Clinger. Semantics of Scheme. {\em BYTE} 13(2):221--227, February 1988. \bibitem{howtoread} %new William Clinger. How to read floating point numbers accurately. In {\em Proceedings of the ACM SIGPLAN '90 Conference on Programming Language Design and Implementation}, pages 92--101. Proceedings published as {\em SIGPLAN Notices} 25(6), June 1990. \bibitem{Clinger85} %new William Clinger, Daniel P.~Friedman, and Mitchell Wand. A scheme for a higher-level semantic algebra. In {\em Algebraic Methods in Semantics}, pages 237--250. J. Reynolds, M. Nivat, editor. Cambridge University Press, 1985. \bibitem{Clinger88b} %new William Clinger, Anne Hartheimer, and Eric Ost. Implementation strategies for continuations. In {\em Proceedings of the 1988 ACM Conference on Lisp and Functional Programming}, pages 124--131. \bibitem{macrosthatwork} %new William Clinger and Jonathan Rees. Macros that work. In {\em Proceedings of the 1991 ACM Conference on Principles of Programming Languages}, pages~155--162. \bibitem{Curtis90} %new Pavel Curtis and James Rauen. A module system for Scheme. In {\em Proceedings of the 1990 ACM Conference on Lisp and Functional Programming}, June 1990. \todo{pages?} \bibitem{Dybvig87} %new R.~Kent Dybvig. {\em The Scheme Programming Language.} Prentice-Hall, 1987. % \bibitem{Dybvig86} % R.~Kent Dybvig, Daniel P.~Friedman, and Christopher T.~Haynes. % Expansion-passing style: Beyond conventional macros. % In {\em Proceedings of the 1986 ACM Conference on Lisp and % Functional Programming}, pages 143--150. \bibitem{Dybvig86} %new; replaces the above R.~Kent Dybvig and Daniel P. Friedman and Christopher T. Haynes. Expansion-passing style: a general macro mechanism. {\em Lisp and Symbolic Computation} 1(1):53--76, June 1988. \bibitem{Dybvig88} %new R.~Kent Dybvig and Robert Hieb. A variable-arity procedural interface. In {\em Proceedings of the 1988 ACM Symposium on Lisp and Functional Programming}, pages 106--115. \bibitem{Dybvig88} %new R.~Kent Dybvig and Robert Hieb. Engines from continuations. {\em Journal of Computer Languages} 14(2), pages~109--123, 1989. \bibitem{Dybvig88} %new R.~Kent Dybvig and Robert Hieb. Continuations and concurrency. In {\em Proceedings of the Second ACM SIGPLAN Notices Symposium on Principles and Practice of Parallel Programming}, pages~128--136, March 1990. % technical report: \bibitem{Eisenberg85} Michael A.~Eisenberg. Bochser: an integrated Scheme programming system. MIT Laboratory for Computer Science Technical Report 349, October 1985. \bibitem{Eisenberg88} %new Michael Eisenberg. Harold Abelson, editor. {\em Programming In Scheme.} Scientific Press, Redwood City, California, 1988. \bibitem{Eisenberg90} %new Michael Eisenberg, with William Clinger and Anne Hartheimer. Harold Abelson, editor. {\em Programming In MacScheme.} Scientific Press, San Francisco, 1990. \bibitem{Feeley86} Marc Feeley. Deux approches \`{a} l'implantation du language Scheme. M.Sc.~thesis, D\'{e}partement d'Informatique et de Recherche Op\'{e}rationelle, University of Montreal, May 1986. \bibitem{Feeley87} %new Marc Feeley and Guy LaPalme. Using closures for code generation. {\em Journal of Computer Languages} 12(1):47--66, 1987. \bibitem{Feeley90} %new Marc Feeley and James Miller. A parallel virtual machine for efficient Scheme compilation. In {\em Proceedings of the 1990 ACM Conference on Lisp and Functional Programming}, June 1990. \todo{pages?} \bibitem{Felleisen87b} %new Matthias Felleisen. Reflections on Landin's J-Operator: a partly historical note. {\em Journal of Computer Languages} 12(3/4):197--207, 1987. \bibitem{Felleisen86b} %new Matthias Felleisen and Daniel P. Friedman. Control operators, the SECD-machine, and the lambda-calculus. In {\em 3rd Working Conference on the Formal Description of Programming Concepts}, pages 193--219, August 1986. \bibitem{Felleisen86c} %new Matthias Felleisen and Daniel P.~Friedman. A closer look at export and import statements. {\em Journal of Computer Languages} 11(1):29--37, 1986. \bibitem{Felleisen87} %new Matthias Felleisen and Daniel P. Friedman. A calculus for assignments in higher-order languages. In {\em Conference Record of the 14th Annual ACM Symposium on Principles of Programming Languages}, pages 314--345, January 1987. \bibitem{Felleisen87d} %new Matthias Felleisen and Daniel P.~Friedman. A reduction semantics for imperative higher-order languages. In {\em Lecture Notes in Computer Science}, {\em Parallel Architectures and Languages Europe} 259:206--223, 1987. De Bakker, Nijman and Treleaven, editors. Springer-Verlag, Berlin. \bibitem{Felleisen86} Matthias Felleisen, Daniel P.~Friedman, Eugene Kohlbecker, and Bruce Duba. Reasoning with continuations. In {\em Proceedings of the Symposium on Logic in Computer Science}, pages 131--141. IEEE Computer Society Press, Washington DC, 1986. % Does [Felleisen87c] replace [Felleisen86] above? \bibitem{Felleisen87c} %new Matthias Felleisen, Daniel P.~Friedman, Eugene E.~Kohlbecker, and Bruce Duba. A syntactic theory of sequential control. {\em Theoretical Computer Science} \todo{5(2)?}52:205--237, 1987. \bibitem{Felleisen88} %new Matthias Felleisen, Mitchell Wand, Daniel P.~Friedman, and Bruce Duba. Abstract continuations: a mathematical semantics for handling functional jumps. In {\em Proceedings of the 1988 ACM Symposium on Lisp and Functional Programming}, \todo{pages} July 1988. % technical report \bibitem{Scheme311} Carol Fessenden, William Clinger, Daniel P.~Friedman, and Christopher Haynes. Scheme 311 version 4 reference manual. Indiana University Computer Science Technical Report 137, February 1983. Superseded by~\cite{Scheme84}. \bibitem{Franco90} %new John Franco and Daniel P.~Friedman. Towards a facility for lexically scoped, dynamic mutual recursion in Scheme. {\em Journal of Computer Languages} 15(1):55--64, 1990. \bibitem{Lisper} Daniel P.~Friedman and Matthias Felleisen. {\em The Little LISPer.} Science Research Associates, second edition 1986. \bibitem{littlelisper} Daniel P.~Friedman and Matthias Felleisen. {\em The Little LISPer.} MIT Press, 1987. \bibitem{Friedman85} Daniel P.~Friedman and Christopher T.~Haynes. Constraining control. In {\em Proceedings of the Twelfth Annual Symposium on Principles of Programming Languages}, pages 245--254. ACM, January 1985. \bibitem{Friedman84} Daniel P.~Friedman, Christopher T.~Haynes, and Eugene Kohlbecker. Programming with continuations. In {\em Program Transformation and Programming Environments,\/} pages 263--274. P.~Pepper, editor. Springer-Verlag, 1984. \bibitem{Scheme84} D.~Friedman, C.~Haynes, E.~Kohlbecker, and M.~Wand. Scheme 84 interim reference manual. Indiana University Computer Science Technical Report 153, January 1985. \bibitem{Friedman84b} %new Daniel P. Friedman and Mitchell Wand. Reification: reflection without metaphysics. In {\em Conference Record of the 1984 ACM Symposium on Lisp and Functional Programming}, pages 348--355. \bibitem{Haynes86} Christopher T.~Haynes. Logic continuations. In {\em Proceedings of the Third International Conference on Logic Programming,\/} pages 671--685. Springer-Verlag, July 1986. % and to appear in {\it The Journal of Logic Programming.} \todo{find the journal reference} \bibitem{Engines} Christopher T.~Haynes and Daniel P.~Friedman. Engines build process abstractions. In {\em Conference Record of the 1984 ACM Symposium on Lisp and Functional Programming,\/} pages 18--24. % Does this replace [Engines] above? \bibitem{Haynes87b} %new Christopher T.~Haynes and Daniel P.~Friedman. Abstracting timed preemption with engines. {\em Journal of Computer Languages} 12(2):109--121, 1987. \bibitem{Haynes87a} %new Christopher T.~Haynes and Daniel P.~Friedman. Embedding continuations in procedural objects. {\em ACM Transactions on Programming Languages and Systems} 9(4):582--598, October 1987. % \bibitem{Haynes84} % Christopher T.~Haynes, Daniel P.~Friedman, and Mitchell Wand. % Continuations and coroutines. % In {\em Conference Record of the 1984 ACM Symposium on Lisp and % Functional Programming,} pages 293--298. % I assume the one below replaces the one above. \bibitem{Haynes86} %new Christopher T.~Haynes and Daniel P.~Friedman and Mitchell Wand. Obtaining coroutines with continuations. {\em Journal of Computer Languages} 11(3/4):143--153, 1986. \bibitem{Henderson82} Peter Henderson. Functional geometry. In {\em Conference Record of the 1982 ACM Symposium on Lisp and Functional Programming}, pages 179--187. \bibitem{Dybvig88} %new Robert Hieb, R.~Kent Dybvig, and Carl Bruggeman. Representing control in the presence of first-class continuations. In {\em Proceedings of the ACM SIGPLAN '90 Conference on Programming Language Design and Implementation}, pages~66--77, June 1990. Proceedings published as {\em SIGPLAN Notices} 25(6), June 1990. \bibitem{IEEE} {\em IEEE Standard 754-1985. IEEE Standard for Binary Floating-Point Arithmetic.} IEEE, New York, 1985. \bibitem{IEEEScheme} {\em IEEE Standard 1178-1990. IEEE Standard for the Scheme Programming Language.} IEEE, New York, 1991. \bibitem{Kohlbecker86} Eugene Edmund Kohlbecker~Jr. {\em Syntactic Extensions in the Programming Language Lisp.} PhD thesis, Indiana University, August 1986. \bibitem{hygienic} Eugene E.~Kohlbecker, Daniel P.~Friedman, Matthias Felleisen, and Bruce Duba. Hygienic macro expansion. In {\em Proceedings of the 1986 ACM Conference on Lisp and Functional Programming}, pages 151--161. \bibitem{Kranz86} David Kranz, Richard Kelsey, Jonathan Rees, Paul Hudak, James Philbin, and Norman Adams. Orbit: An optimizing compiler for Scheme. In {\em Proceedings of the SIGPLAN '86 Symposium on Compiler Construction}, pages 219--233. ACM, June 1986. Proceedings published as {\em SIGPLAN Notices} 21(7), July 1986. \bibitem{Kranz88} David Kranz. {\em Orbit: An optimizing compiler for Scheme.} PhD thesis, Yale University, 1988. \bibitem{Landin65} Peter Landin. A correspondence between Algol 60 and Church's lambda notation: Part I. {\em Communications of the ACM} 8(2):89--101, February 1965. \bibitem{McDermott80} Drew McDermott. An efficient environment allocation scheme in an interpreter for a lexically-scoped lisp. In {\em Conference Record of the 1980 Lisp Conference,} pages 154--162. % The Lisp Conference, P.O.~Box 487, Redwood Estates CA, % 1980. Proceedings reprinted by ACM. \bibitem{MITScheme} MIT Department of Electrical Engineering and Computer Science. Scheme manual, seventh edition. September 1984. \bibitem{Muchnick80} Steven S.~Muchnick and Uwe F.~Pleban. A semantic comparison of Lisp and Scheme. In {\em Conference Record of the 1980 Lisp Conference}, pages 56--64. % The Lisp Conference, 1980. Proceedings reprinted by ACM. \bibitem{Naur63} Peter Naur et al. Revised report on the algorithmic language Algol 60. {\em Communications of the ACM} 6(1):1--17, January 1963. \bibitem{Penfield81} Paul Penfield, Jr. Principal values and branch cuts in complex APL. In {\em APL '81 Conference Proceedings,} pages 248--256. ACM SIGAPL, San Francisco, September 1981. Proceedings published as {\em APL Quote Quad} 12(1), ACM, September 1981. % technical report \bibitem{Pitman85} Kent M.~Pitman. Exceptional situations in Lisp. MIT Artificial Intelligence Laboratory Working Paper 268, February 1985. % technical report \bibitem{Pitman83} Kent M.~Pitman. The revised MacLisp manual (Saturday evening edition). MIT Laboratory for Computer Science Technical Report 295, May 1983. \bibitem{Pitman80} Kent M.~Pitman. Special forms in Lisp. In {\em Conference Record of the 1980 Lisp Conference}, pages 179--187. % The Lisp Conference, 1980. Proceedings reprinted by ACM. \bibitem{Plebanthesis} %new Uwe F. Pleban. {\em A Denotational Approach to Flow Analysis and Optimization of Scheme, A Dialect of Lisp.} PhD thesis, University of Kansas, 1980. \bibitem{Rees89} Jonathan A.~Rees. {\em Modular Macros}. M.S.~thesis, MIT, May 1989. \bibitem{Rees82} Jonathan A.~Rees and Norman I.~Adams IV. T: A dialect of Lisp or, lambda: The ultimate software tool. In {\em Conference Record of the 1982 ACM Symposium on Lisp and Functional Programming}, pages 114--122. \bibitem{Rees84} Jonathan A.~Rees, Norman I.~Adams IV, and James R.~Meehan. The T manual, fourth edition. Yale University Computer Science Department, January 1984. \bibitem{R3RS} Jonathan Rees and William Clinger, editors. The revised$^3$ report on the algorithmic language Scheme. In {\em ACM SIGPLAN Notices} 21(12), pages~37--79, December 1986. \bibitem{Reynolds72} John Reynolds. Definitional interpreters for higher order programming languages. In {\em ACM Conference Proceedings}, pages 717--740. ACM, \todo{month?}~1972. \bibitem{Rozas84} Guillermo J.~Rozas. Liar, an Algol-like compiler for Scheme. S.~B.~thesis, MIT Department of Electrical Engineering and Computer Science, January 1984. \bibitem{schflow} %new Olin Shivers. Control flow analysis in Scheme. {\em Proceedings of the SIGPLAN 1988 Conference on Programming Language Design and Implementation}, pages 164--174. Proceedings published as {\em SIGPLAN Notices} 23(7), July 1988. \bibitem{Sitaram90} %new Dorai Sitaram and Matthias Felleisen. Control delimiters and their hierarchies. {\em Lisp and Symbolic Computation} 3(1):67--99, January 1990. % technical report \bibitem{Smith84} Brian C.~Smith. Reflection and semantics in a procedural language. MIT Laboratory for Computer Science Technical Report 272, January 1982. \bibitem{Springer89} %new George Springer and Daniel P.~Friedman. {\em Scheme and the Art of Programming.} MIT Press and McGraw-Hill, 1989. \bibitem{Srivastava85} Amitabh Srivastava, Don Oxley, and Aditya Srivastava. An(other) integration of logic and functional programming. In {\em Proceedings of the Symposium on Logic Programming}, pages 254--260. IEEE, 1985. % technical report \bibitem{Stallman80} Richard M.~Stallman. Phantom stacks---if you look too hard, they aren't there. MIT Artificial Intelligence Memo 556, July 1980. % NOTE -- there should not be a comma between ``Steele'' and ``Jr.'' \bibitem{Declarative} Guy Lewis Steele Jr. Lambda, the ultimate declarative. MIT Artificial Intelligence Memo 379, November 1976. \bibitem{Debunking} Guy Lewis Steele Jr. Debunking the ``expensive procedure call'' myth, or procedure call implementations considered harmful, or lambda, the ultimate GOTO. In {\em ACM Conference Proceedings}, pages 153--162. ACM, 1977. \bibitem{Macaroni} Guy Lewis Steele Jr. Macaroni is better than spaghetti. In {\em Proceedings of the Symposium on Artificial Intelligence and Programming Languages}, pages 60--66. These proceedings were published as a special joint issue of {\em SIGPLAN Notices} 12(8) and {\em SIGART Newsletter} 64, August 1977. \bibitem{Rabbit} Guy Lewis Steele Jr. Rabbit: a compiler for Scheme. MIT Artificial Intelligence Laboratory Technical Report 474, May 1978. \bibitem{renamegoto} %new Guy Lewis Steele Jr. Compiler optimization based on viewing LAMBDA as RENAME + GOTO. In {\em AI: An MIT Perspective.} Patrick Henry Winston Richard Henry Brown, editor. MIT Press, 1980. \bibitem{CLoverview} Guy Lewis Steele Jr. An overview of Common Lisp. In {\em Conference Record of the 1982 ACM Symposium on Lisp and Functional Programming}, pages 98--107. \bibitem{CLtL} Guy Lewis Steele Jr. {\em Common Lisp: The Language.} Digital Press, Burlington MA, 1984. \bibitem{Imperative} Guy Lewis Steele Jr.~and Gerald Jay Sussman. Lambda, the ultimate imperative. MIT Artificial Intelligence Memo 353, March 1976. \bibitem{Scheme78} Guy Lewis Steele Jr.~and Gerald Jay Sussman. The revised report on Scheme, a dialect of Lisp. MIT Artificial Intelligence Memo 452, January 1978. \bibitem{TAOTI} Guy Lewis Steele Jr.~and Gerald Jay Sussman. The art of the interpreter, or the modularity complex (parts zero, one, and two). MIT Artificial Intelligence Memo 453, May 1978. \bibitem{DOALBP} Guy Lewis Steele Jr.~and Gerald Jay Sussman. Design of a Lisp-based processor. {\em Communications of the ACM} 23(11):628--645, November 1980. \bibitem{Dream} Guy Lewis Steele Jr.~and Gerald Jay Sussman. The dream of a lifetime: a lazy variable extent mechanism. In {\em Conference Record of the 1980 Lisp Conference}, pages 163--172. % The Lisp Conference, 1980. Proceedings reprinted by ACM. \bibitem{howtoprint} Guy Lewis Steele Jr.~and Jon L White. How to print floating point numbers accurately. In {\em Proceedings of the ACM SIGPLAN '90 Conference on Programming Language Design and Implementation}, pages~112--126. Proceedings published as {\em SIGPLAN Notices} 25(6), June 1990. \bibitem{Sussman82} Gerald Jay Sussman. Lisp, programming and implementation. In {\em Functional Programming and its Applications.} Darlington, Henderson, Turner, editor. Cambridge University Press, 1982. \bibitem{Scheme75} Gerald Jay Sussman and Guy Lewis Steele Jr. Scheme: an interpreter for extended lambda calculus. MIT Artificial Intelligence Memo 349, December 1975. \bibitem{Scheme79} Gerald Jay Sussman, Jack Holloway, Guy Lewis Steele Jr., and Alan Bell. Scheme-79---Lisp on a chip. {\em IEEE Computer} 14(7):10--21, July 1981. \bibitem{Stoy77} Joseph E.~Stoy. {\em Denotational Semantics: The Scott-Strachey Approach to Programming Language Theory.} MIT Press, Cambridge, 1977. \bibitem{TI85} Texas Instruments, Inc. {\em TI Scheme Language Reference Manual.} Preliminary version 1.0, November 1985. \todo{get a more recent reference} \bibitem{Vegdahl89} Steven R.~Vegdahl and Uwe F.~Pleban. The runtime environment for Screme, a Scheme implementation on the 88000. In {\em Proceedings of the Third International Conference on Architectural Support for Programming Languages and Operating Systems}, pages 172--182, April 1989. \bibitem{Wand78} Mitchell Wand. Continuation-based program transformation strategies. {\em Journal of the ACM} 27(1):174--180, 1978. \bibitem{Wand80} Mitchell Wand. Continuation-based multiprocessing. In {\em Conference Re\-cord of the 1980 Lisp Conference}, pages 19--28. Proceedings available from ACM. \bibitem{Wand86} %new Mitchell Wand. {\em Finding the source of type errors.} In {\em Conference Record of the Thirteenth Annual Symposium on Principles of Programming Languages}, pages 38--43, 1986. \todo{make sure this is relevant} \bibitem{tower} %new Mitchell Wand. The mystery of the tower revealed: a non-reflective description of the reflective tower. In {\em Proceedings of the 1986 ACM Symposium on LISP and Functional Programming}, pages 298--307, August 1986. \bibitem{Wand78} %new Mitchell Wand and Daniel P. Friedman. Compiling lambda expressions using continuations and factorizations. {\em Journal of Computer Languages} 3:241--263, 1978. % This next one probably replaces [tower] above, but the above is % probably more widely available. \bibitem{Wand88} %new Mitchell Wand and Daniel P.~Friedman. The mystery of the tower revealed: a non-reflective description of the reflective tower. In {\em Meta-Level Architectures and Reflection}, pages 111--134. P. Maes and D. Nardi, editor. Elsevier Sci. Publishers B.V. (North Holland), 1988. \end{thebibliography} scheme2c-2012.10.14/doc/r4rs/commands.tex000066400000000000000000000130041203736146400175610ustar00rootroot00000000000000% Macros for R^nRS. \makeatletter % Chapters, sections, etc. \newcommand{\extrapart}[1]{ \chapter*{#1} \markboth{#1}{#1} \vskip 1ex \addcontentsline{toc}{chapter}{#1}} \newcommand{\clearchapterstar}[1]{ \clearpage \topnewpage[ \centerline{\large\bf\uppercase{#1}} \bigskip]} \newcommand{\clearextrapart}[1]{ \clearchapterstar{#1} \markboth{#1}{#1} \addcontentsline{toc}{chapter}{#1}} \newcommand{\vest}{} \newcommand{\dotsfoo}{$\ldots\,$} \newcommand{\sharpfoo}[1]{{\tt\##1}} \newcommand{\schfalse}{\sharpfoo{f}} \newcommand{\schtrue}{\sharpfoo{t}} \newcommand{\singlequote}{{\tt'}} %\char19 \newcommand{\doublequote}{{\tt"}} \newcommand{\backquote}{{\tt\char18}} \newcommand{\backwhack}{{\tt\char`\\}} \newcommand{\atsign}{{\tt\char`\@}} \newcommand{\sharpsign}{{\tt\#}} \newcommand{\verticalbar}{{\tt|}} \newcommand{\coerce}{\discretionary{->}{}{->}} % Knuth's \in sucks big boulders \def\elem{\hbox{\raise.13ex\hbox{$\scriptstyle\in$}}} \newcommand{\meta}[1]{{\noindent\hbox{\rm$\langle$#1$\rangle$}}} \let\hyper=\meta \newcommand{\hyperi}[1]{\hyper{#1$_1$}} \newcommand{\hyperii}[1]{\hyper{#1$_2$}} \newcommand{\hyperj}[1]{\hyper{#1$_i$}} \newcommand{\hypern}[1]{\hyper{#1$_n$}} \newcommand{\var}[1]{\noindent\hbox{\it{}#1\/}} % Careful, is \/ always the right thing? \newcommand{\vari}[1]{\var{#1$_1$}} \newcommand{\varii}[1]{\var{#1$_2$}} \newcommand{\variii}[1]{\var{#1$_3$}} \newcommand{\variv}[1]{\var{#1$_4$}} \newcommand{\varj}[1]{\var{#1$_j$}} \newcommand{\varn}[1]{\var{#1$_n$}} \newcommand{\vr}[1]{{\noindent\hbox{$#1$\/}}} % Careful, is \/ always the right thing? \newcommand{\vri}[1]{\vr{#1_1}} \newcommand{\vrii}[1]{\vr{#1_2}} \newcommand{\vriii}[1]{\vr{#1_3}} \newcommand{\vriv}[1]{\vr{#1_4}} \newcommand{\vrj}[1]{\vr{#1_j}} \newcommand{\vrn}[1]{\vr{#1_n}} \newcommand{\defining}[1]{\mainindex{#1}{\em #1}} \newcommand{\ide}[1]{{\schindex{#1}\frenchspacing\tt#1}} \newcommand{\lambdaexp}{lambda expression} \newcommand{\Lambdaexp}{Lambda expression} % \reallyindex{SORTKEY}{HEADCS}{TYPE} % writes (index-entry "SORTKEY" "HEADCS" TYPE PAGENUMBER) % which becomes \item \HEADCS{SORTKEY} mainpagenumber ; auxpagenumber ... \global\def\reallyindex#1#2#3{% \write\@indexfile{(index-entry "#1" "#2" #3 \thepage)}} \newcommand{\mainschindex}[1]{\label{#1}\reallyindex{#1}{tt}{main}} \newcommand{\mainindex}[1]{\reallyindex{#1}{rm}{main}} \newcommand{\schindex}[1]{\reallyindex{#1}{tt}{aux}} \newcommand{\sharpindex}[1]{\reallyindex{#1}{sharpfoo}{aux}} \renewcommand{\index}[1]{\reallyindex{#1}{rm}{aux}} \newcommand{\domain}[1]{#1} \newcommand{\nodomain}[1]{} %\newcommand{\todo}[1]{{\rm$[\![$!!~#1$]\!]$}} \newcommand{\todo}[1]{} % \frobq will make quote and backquote look nicer. \def\frobqcats{%\catcode`\'=13 \catcode`\`=13{}} {\frobqcats \gdef\frobqdefs{%\def'{\singlequote} \def`{\backquote}}} \def\frobq{\frobqcats\frobqdefs} % \cf = code font % Unfortunately, \cf \cf won't work at all, so don't even attempt to % next constructions which use them... \newcommand{\cf}{\frenchspacing\frobq\tt} % Same as \obeycr, but doesn't do a \@gobblecr. {\catcode`\^^M=13 \gdef\myobeycr{\catcode`\^^M=13 \def^^M{\\}}% \gdef\restorecr{\catcode`\^^M=5 }} {\catcode`\^^I=13 \gdef\obeytabs{\catcode`\^^I=13 \def^^I{\hbox{\hskip 4em}}}} {\obeyspaces\gdef {\hbox{\hskip0.5em}}} \gdef\gobblecr{\@gobblecr} \def\setupcode{\@makeother\^} % Scheme example environment % At 11 points, one column, these are about 56 characters wide. % That's 32 characters to the left of the => and about 20 to the right. \newenvironment{schemenoindent}{ % Commands for scheme examples \newcommand{\ev}{\>\>\evalsto} \newcommand{\lev}{\\\>\evalsto} \newcommand{\unspecified}{{\em{}unspecified}} \newcommand{\scherror}{{\em{}error}} \setupcode \small \cf \obeytabs \obeyspaces \myobeycr \begin{tabbing}% \qquad\=\hspace*{5em}\=\hspace*{9em}\=\kill% was 16em \gobblecr}{\unskip\end{tabbing}} %\newenvironment{scheme}{\begin{schemenoindent}\+\kill}{\end{schemenoindent}} \newenvironment{scheme}{ % Commands for scheme examples \newcommand{\ev}{\>\>\evalsto} \newcommand{\lev}{\\\>\evalsto} \newcommand{\unspecified}{{\em{}unspecified}} \newcommand{\scherror}{{\em{}error}} \setupcode \small \cf \obeyspaces \myobeycr \begin{tabbing}% \qquad\=\hspace*{5em}\=\hspace*{9em}\=\+\kill% was 16em \gobblecr}{\unskip\end{tabbing}} \newcommand{\evalsto}{$\Longrightarrow$} % Rationale \newenvironment{rationale}{% \bgroup\small\noindent{\em Rationale:}\space}{% \egroup} % Notes \newenvironment{note}{% \bgroup\small\noindent{\em Note:}\space}{% \egroup} % Manual entries \newenvironment{entry}[1]{ \vspace{3.1ex plus .5ex minus .3ex}\noindent#1% \unpenalty\nopagebreak}{\vspace{0ex plus 1ex minus 1ex}} \newcommand{\exprtype}{syntax} % Primitive prototype \newcommand{\pproto}[2]{\unskip% \hbox{\cf\spaceskip=0.5em#1}\hfill\penalty 0% \hbox{ }\nobreak\hfill\hbox{\rm #2}\break} % Parenthesized prototype \newcommand{\proto}[3]{\pproto{(\mainschindex{#1}\hbox{#1}{\it#2\/})}{#3}} % Variable prototype \newcommand{\vproto}[2]{\mainschindex{#1}\pproto{#1}{#2}} % Random prototype \newcommand{\rproto}[3]{\proto{#1}{#2}{#3}} % Grammar environment \newenvironment{grammar}{ \def\:{\goesto{}} \def\|{$\vert$} \cf \myobeycr \begin{tabbing} %\qquad\quad \= \qquad \= $\vert$ \= \kill }{\unskip\end{tabbing}} %\newcommand{\unsection}{\unskip} \newcommand{\unsection}{{\vskip -2ex}} % Commands for grammars \newcommand{\arbno}[1]{#1\hbox{\rm*}} \newcommand{\atleastone}[1]{#1\hbox{$^+$}} \newcommand{\goesto}{$\longrightarrow$} \makeatother scheme2c-2012.10.14/doc/r4rs/derive.tex000066400000000000000000000144021203736146400172410ustar00rootroot00000000000000\section{Derived expression types} \label{derivedsection} This section gives rewrite rules for the derived expression types. By the application of these rules, any expression can be reduced to a semantically equivalent expression in which only the primitive expression types (literal, variable, call, \ide{lambda}, \ide{if}, \ide{set!}) occur. % \todo{Expressions such as {\tt (cond)} aren't legal, but they make the % rewrite rules work.} \newcommand{\iet}{\hbox to 2em{\hfil $\equiv$}} % is equivalent to \begin{schemenoindent} (cond (\hyper{test} \hyper{sequence}) \hyperii{clause} \dotsfoo) \iet (if \hyper{test} (begin \hyper{sequence}) (cond \hyperii{clause} \dotsfoo)) (cond (\hyper{test}) \hyperii{clause} \dotsfoo) \iet (or \hyper{test} (cond \hyperii{clause} \dotsfoo)) (cond (\hyper{test} => \hyper{recipient}) \hyperii{clause} \dotsfoo) \iet (let ((test-result \hyper{test}) (thunk2 (lambda () \hyper{recipient})) (thunk3 (lambda () (cond \hyperii{clause} \dotsfoo)))) (if test-result ((thunk2) test-result) (thunk3))) (cond (else \hyper{sequence})) \iet (begin \hyper{sequence}) (cond) \iet \hyper{some expression returning an unspecified value} (case \hyper{key} ((d1 \dotsfoo) \hyper{sequence}) \dotsfoo) \iet (let ((key \hyper{key}) (thunk1 (lambda () \hyper{sequence})) \dotsfoo) (cond ((\hyper{memv} key '(d1 \dotsfoo)) (thunk1)) \dotsfoo)) (case \hyper{key} ((d1 \dotsfoo) \hyper{sequence}) \dotsfoo (else f1 f2 \dotsfoo)) \iet (let ((key \hyper{key}) (thunk1 (lambda () \hyper{sequence})) \dotsfoo (elsethunk (lambda () f1 f2 \dotsfoo))) (cond ((\hyper{memv} key '(d1 \dotsfoo)) (thunk1)) \dotsfoo (else (elsethunk))))% \end{schemenoindent} where \hyper{memv} is an expression evaluating to the \ide{memv} procedure. \begin{schemenoindent} (and) \=\iet \schtrue (and \hyper{test})\>\iet \hyper{test} (and \hyperi{test} \hyperii{test} \dotsfoo) \iet (let ((x \hyperi{test}) (thunk (lambda () (and \hyperii{test} \dotsfoo)))) (if x (thunk) x)) (or) \>\iet \schfalse (or \hyper{test})\>\iet \hyper{test} (or \hyperi{test} \hyperii{test} \dotsfoo) \iet (let ((x \hyperi{test}) (thunk (lambda () (or \hyperii{test} \dotsfoo)))) (if x x (thunk))) (let ((\hyperi{variable} \hyperi{init}) \dotsfoo) \hyper{body}) \iet ((lambda (\hyperi{variable} \dotsfoo) \hyper{body}) \hyperi{init} \dotsfoo) (let* () \hyper{body}) \iet ((lambda () \hyper{body})) (let* ((\hyperi{variable} \hyperi{init}) (\hyperii{variable} \hyperii{init}) \dotsfoo) \hyper{body}) \iet (let ((\hyperi{variable} \hyperi{init})) (let* ((\hyperii{variable} \hyperii{init}) \dotsfoo) \hyper{body})) (letrec ((\hyperi{variable} \hyperi{init}) \dotsfoo) \hyper{body}) \iet (let ((\hyperi{variable} \hyper{undefined}) \dotsfoo) (let ((\hyperi{temp} \hyperi{init}) \dotsfoo) (set! \hyperi{variable} \hyperi{temp}) \dotsfoo) \hyper{body})% \end{schemenoindent} where \hyperi{temp}, \hyperii{temp}, \dotsfoo{} are variables, distinct from \hyperi{variable}, \dotsfoo{}, that do not free occur in the original \hyper{init} expressions, and \hyper{undefined} is an expression which returns something that when stored in a location makes it an error to try to obtain the value stored in the location. (No such expression is defined, but one is assumed to exist for the purposes of this rewrite rule.) The second \ide{let} expression in the expansion is not strictly necessary, but it serves to preserve the property that the \hyper{init} expressions are evaluated in an arbitrary order. \begin{schemenoindent} (begin \hyper{sequence}) \iet ((lambda () \hyper{sequence}))% \end{schemenoindent} The following alternative expansion for \ide{begin} does not make use of the ability to write more than one expression in the body of a lambda expression. In any case, note that these rules apply only if \hyper{sequence} contains no definitions. \begin{schemenoindent} (begin \hyper{expression})\iet \hyper{expression} (begin \hyper{command} \hyper{sequence}) \iet ((lambda (ignore thunk) (thunk)) \hyper{command} (lambda () (begin \hyper{sequence})))% \end{schemenoindent} The following expansion for \ide{do} is simplified by the assumption that no \hyper{step} is omitted. Any \ide{do} expression in which a \hyper{step} is omitted can be replaced by an equivalent \ide{do} expression in which the corresponding \hyper{variable} appears as the \hyper{step}. \begin{schemenoindent} (do ((\hyperi{variable} \hyperi{init} \hyperi{step}) \dotsfoo) (\hyper{test} \hyper{sequence}) \hyperi{command} \dotsfoo) \iet (letrec ((\hyper{loop} (lambda (\hyperi{variable} \dotsfoo) (if \hyper{test} (begin \hyper{sequence}) (begin \hyperi{command} \dotsfoo (\hyper{loop} \hyperi{step} \dotsfoo)))))) (\hyper{loop} \hyperi{init} \dotsfoo))% \end{schemenoindent} where \hyper{loop} is any variable which is distinct from \hyperi{variable},~\dotsfoo, and which does not occur free in the \ide{do} expression. \begin{schemenoindent} (let \hyper{variable$_0$} ((\hyperi{variable} \hyperi{init}) \dotsfoo) \hyper{body}) \iet ((letrec ((\hyper{variable$_0$} (lambda (\hyperi{variable} \dotsfoo) \hyper{body}))) \hyper{variable$_0$}) \hyperi{init} \dotsfoo) (delay \hyper{expression}) \iet (\hyper{make-promise} (lambda () \hyper{expression}))% \end{schemenoindent} where \hyper{make-promise} is an expression evaluating to some procedure which behaves appropriately with respect to the \ide{force} procedure; see section~\ref{force}. % `a = Q_1[a] % `(a b c ... . z) = `(a . (b c ...)) % `(a . b) = (append Q*_0[a] `b) % `(a) = Q*_0[a] % Q*_0[a] = (list 'a) % Q*_0[,a] = (list a) % Q*_0[,@a] = a % Q*_0[`a] = (list 'quasiquote Q*_1[a]) % `#(a b ...) = (list->vector `(a b ...)) % ugh. scheme2c-2012.10.14/doc/r4rs/example.tex000066400000000000000000000103311203736146400174130ustar00rootroot00000000000000\vfill\eject \extrapart{Example} % -*- Mode: Lisp; Package: SCHEME; Syntax: Common-lisp -*- \nobreak \ide{Integrate-system} integrates the system $$y_k^\prime = f_k(y_1, y_2, \ldots, y_n), \; k = 1, \ldots, n$$ of differential equations with the method of Runge-Kutta. The parameter {\tt system-derivative} is a function that takes a system state (a vector of values for the state variables $y_1, \ldots, y_n$) and produces a system derivative (the values $y_1^\prime, \ldots, y_n^\prime$). The parameter {\tt initial-state} provides an initial system state, and {\tt h} is an initial guess for the length of the integration step. The value returned by \ide{integrate-system} is an infinite stream of system states. \begin{schemenoindent} (define integrate-system (lambda (system-derivative initial-state h) (let ((next (runge-kutta-4 system-derivative h))) (letrec ((states (cons initial-state (delay (map-streams next states))))) states))))% \end{schemenoindent} \ide{Runge-Kutta-4} takes a function, {\tt f}, that produces a system derivative from a system state. \ide{Runge-Kutta-4} produces a function that takes a system state and produces a new system state. \begin{schemenoindent} (define runge-kutta-4 (lambda (f h) (let ((*h (scale-vector h)) (*2 (scale-vector 2)) (*1/2 (scale-vector (/ 1 2))) (*1/6 (scale-vector (/ 1 6)))) (lambda (y) ;; y {\rm{}is a system state} (let* ((k0 (*h (f y))) (k1 (*h (f (add-vectors y (*1/2 k0))))) (k2 (*h (f (add-vectors y (*1/2 k1))))) (k3 (*h (f (add-vectors y k2))))) (add-vectors y (*1/6 (add-vectors k0 (*2 k1) (*2 k2) k3)))))))) %|--------------------------------------------------| (define elementwise (lambda (f) (lambda vectors (generate-vector (vector-length (car vectors)) (lambda (i) (apply f (map (lambda (v) (vector-ref v i)) vectors))))))) %|--------------------------------------------------| (define generate-vector (lambda (size proc) (let ((ans (make-vector size))) (letrec ((loop (lambda (i) (cond ((= i size) ans) (else (vector-set! ans i (proc i)) (loop (+ i 1))))))) (loop 0))))) (define add-vectors (elementwise +)) (define scale-vector (lambda (s) (elementwise (lambda (x) (* x s)))))% \end{schemenoindent} \ide{Map-streams} is analogous to \ide{map}: it applies its first argument (a procedure) to all the elements of its second argument (a stream). \begin{schemenoindent} (define map-streams (lambda (f s) (cons (f (head s)) (delay (map-streams f (tail s))))))% \end{schemenoindent} Infinite streams are implemented as pairs whose car holds the first element of the stream and whose cdr holds a promise to deliver the rest of the stream. \begin{schemenoindent} (define head car) (define tail (lambda (stream) (force (cdr stream))))% \end{schemenoindent} \bigskip The following illustrates the use of \ide{integrate-system} in integrating the system $$ C {dv_C \over dt} = -i_L - {v_C \over R}$$\nobreak $$ L {di_L \over dt} = v_C$$ which models a damped oscillator. \begin{schemenoindent} (define damped-oscillator (lambda (R L C) (lambda (state) (let ((Vc (vector-ref state 0)) (Il (vector-ref state 1))) (vector (- 0 (+ (/ Vc (* R C)) (/ Il C))) (/ Vc L)))))) (define the-states (integrate-system (damped-oscillator 10000 1000 .001) '\#(1 0) .01))% \end{schemenoindent} \todo{Show some output?} % (letrec ((loop (lambda (s) % (newline) % (write (head s)) % (loop (tail s))))) % (loop the-states)) % #(1 0) % #(0.99895054 9.994835e-6) % #(0.99780226 1.9978681e-5) % #(0.9965554 2.9950552e-5) % #(0.9952102 3.990946e-5) % #(0.99376684 4.985443e-5) % #(0.99222565 5.9784474e-5) % #(0.9905868 6.969862e-5) % #(0.9888506 7.9595884e-5) % #(0.9870173 8.94753e-5) scheme2c-2012.10.14/doc/r4rs/expr.tex000066400000000000000000000636541203736146400167560ustar00rootroot00000000000000%\vfill\eject \chapter{Expressions} \label{expressionchapter} \newcommand{\syntax}{{\em Syntax: }} \newcommand{\semantics}{{\em Semantics: }} A Scheme expression is a construct that returns a value, such as a variable reference, literal, procedure call, or conditional. Expression types are categorized as {\em primitive} or {\em derived}. Primitive expression types include variables and procedure calls. Derived expression types are not semantically primitive, but can instead be explained in terms of the primitive constructs as in section~\ref{derivedsection}. They are redundant in the strict sense of the word, but they capture common patterns of usage, and are therefore provided as convenient abbreviations. \section{Primitive expression types} \label{primitivexps} \subsection{Variable references}\unsection \begin{entry}{% \pproto{\hyper{variable}}{essential \exprtype}} An expression consisting of a variable\index{variable} (section~\ref{variablesection}) is a variable reference. The value of the variable reference is the value stored in the location to which the variable is bound. It is an error to reference an unbound\index{unbound} variable. \begin{scheme} (define x 28) x \ev 28% \end{scheme} \end{entry} \subsection{Literal expressions}\unsection \label{literalsection} \begin{entry}{% \proto{quote}{ \hyper{datum}}{essential \exprtype} \pproto{\singlequote\hyper{datum}}{essential \exprtype} \pproto{\hyper{constant}}{essential \exprtype}} {\cf (quote \hyper{datum})} evaluates to \hyper{datum}.\mainschindex{'} \hyper{Datum} may be any external representation of a Scheme object (see section~\ref{externalreps}). This notation is used to include literal constants in Scheme code. \index{constant} \begin{scheme}% (quote a) \ev a (quote \sharpsign(a b c)) \ev \#(a b c) (quote (+ 1 2)) \ev (+ 1 2)% \end{scheme} {\cf (quote \hyper{datum})} may be abbreviated as \singlequote\hyper{datum}. The two notations are equivalent in all respects. \begin{scheme} 'a \ev a '\#(a b c) \ev \#(a b c) '() \ev () '(+ 1 2) \ev (+ 1 2) '(quote a) \ev (quote a) ''a \ev (quote a)% \end{scheme} Numerical constants, string constants, character constants, and boolean constants evaluate ``to themselves''; they need not be quoted. \begin{scheme} '"abc" \ev "abc" "abc" \ev "abc" '145932 \ev 145932 145932 \ev 145932 '\schtrue \ev \schtrue \schtrue \ev \schtrue% \end{scheme} As noted in section~\ref{storagemodel}, it is an error to alter a constant (i.e.~the value of a literal expression) using a mutation procedure like \ide{set-car!}\ or \ide{string-set!}. \index{constant} \end{entry} \subsection{Procedure calls}\unsection \begin{entry}{% \pproto{(\hyper{operator} \hyperi{operand} \dotsfoo)}{essential \exprtype}} A procedure call is written by simply enclosing in parentheses expressions for the procedure to be called and the arguments to be passed to it. The operator and operand expressions are evaluated (in an unspecified order) and the resulting procedure is passed the resulting arguments.\mainindex{call}\mainindex{procedure call} \begin{scheme}% (+ 3 4) \ev 7 ((if \schfalse + *) 3 4) \ev 12% \end{scheme} A number of procedures are available as the values of variables in the initial environment; for example, the addition and multiplication procedures in the above examples are the values of the variables \ide{+} and \ide{*}. New procedures are created by evaluating \lambdaexp{}s (see section~\ref{lambda}). \todo{At Friedman's reuest, flushed mention of other ways.} % or definitions (see section~\ref{define}). Procedure calls are also called {\em combinations}. \mainindex{combination} \begin{note} In contrast to other dialects of Lisp, the order of evaluation is unspecified, and the operator expression and the operand expressions are always evaluated with the same evaluation rules. \end{note} \begin{note} Although the order of evaluation is otherwise unspecified, the effect of any concurrent evaluation of the operator and operand expressions is constrained to be consistent with some sequential order of evaluation. The order of evaluation may be chosen differently for each procedure call. \end{note} \begin{note} In many dialects of Lisp, the empty combination, {\tt ()}, is a legitimate expression. In Scheme, combinations must have at least one subexpression, so {\tt ()} is not a syntactically valid expression. \todo{Dybvig: ``it should be obvious from the syntax.''} \end{note} \todo{Freeman: I think an explanation as to why evaluation order is not specified should be included. It should not include any reference to parallel evaluation. Does any existing compiler generate better code because the evaluation order is unspecified? Clinger: yes: T3, MacScheme v2, probably MIT Scheme and Chez Scheme. But that's not the main reason for leaving the order unspecified.} \end{entry} \subsection{\Lambdaexp{}s}\unsection \label{lamba} \begin{entry}{% \proto{lambda}{ \hyper{formals} \hyper{body}}{essential \exprtype}} \syntax \hyper{Formals} should be a formal arguments list as described below, and \hyper{body} should be a sequence of one or more expressions. \semantics \vest A \lambdaexp{} evaluates to a procedure. The environment in effect when the \lambdaexp{} was evaluated is remembered as part of the procedure. When the procedure is later called with some actual arguments, the environment in which the \lambdaexp{} was evaluated will be extended by binding the variables in the formal argument list to fresh locations, the corresponding actual argument values will be stored in those locations, and the expressions in the body of the \lambdaexp{} will be evaluated sequentially in the extended environment. The result of the last expression in the body will be returned as the result of the procedure call. \begin{scheme} (lambda (x) (+ x x)) \ev {\em{}a procedure} ((lambda (x) (+ x x)) 4) \ev 8 (define reverse-subtract (lambda (x y) (- y x))) (reverse-subtract 7 10) \ev 3 (define add4 (let ((x 4)) (lambda (y) (+ x y)))) (add4 6) \ev 10% \end{scheme} \hyper{Formals} should have one of the following forms: \begin{itemize} \item {\tt(\hyperi{variable} \dotsfoo)}: The procedure takes a fixed number of arguments; when the procedure is called, the arguments will be stored in the bindings of the corresponding variables. \item \hyper{variable}: The procedure takes any number of arguments; when the procedure is called, the sequence of actual arguments is converted into a newly allocated list, and the list is stored in the binding of the \hyper{variable}. \item {\tt(\hyperi{variable} \dotsfoo{} \hyper{variable$_{n-1}$} {\bf.}\ \hypern{variable})}: If a space-delimited period precedes the last variable, then the value stored in the binding of the last variable will be a newly allocated list of the actual arguments left over after all the other actual arguments have been matched up against the other formal arguments. \end{itemize} It is an error for a \hyper{variable} to appear more than once in \hyper{formals}. \begin{scheme} ((lambda x x) 3 4 5 6) \ev (3 4 5 6) ((lambda (x y . z) z) 3 4 5 6) \ev (5 6)% \end{scheme} Each procedure created as the result of evaluating a \lambdaexp{} is tagged with a storage location, in order to make \ide{eqv?} and \ide{eq?} work on procedures (see section~\ref{equivalencesection}). \end{entry} \subsection{Conditionals}\unsection \begin{entry}{% \proto{if}{ \hyper{test} \hyper{consequent} \hyper{alternate}}{essential \exprtype} \proto{if}{ \hyper{test} \hyper{consequent}}{\exprtype}} %\/ if hyper = italic \syntax \hyper{Test}, \hyper{consequent}, and \hyper{alternate} may be arbitrary expressions. \semantics An \ide{if} expression is evaluated as follows: first, \hyper{test} is evaluated. If it yields a true value\index{true} (see section~\ref{booleansection}), then \hyper{consequent} is evaluated and its value is returned. Otherwise \hyper{alternate} is evaluated and its value is returned. If \hyper{test} yields a false value and no \hyper{alternate} is specified, then the result of the expression is unspecified. \begin{scheme} (if (> 3 2) 'yes 'no) \ev yes (if (> 2 3) 'yes 'no) \ev no (if (> 3 2) (- 3 2) (+ 3 2)) \ev 1% \end{scheme} \end{entry} \subsection{Assignments}\unsection \begin{entry}{% \proto{set!}{ \hyper{variable} \hyper{expression}}{essential \exprtype}} \hyper{Expression} is evaluated, and the resulting value is stored in the location to which \hyper{variable} is bound. \hyper{Variable} must be bound either in some region\index{region} enclosing the \ide{set!}\ expression or at top level. The result of the \ide{set!} expression is unspecified. \begin{scheme} (define x 2) (+ x 1) \ev 3 (set! x 4) \ev \unspecified (+ x 1) \ev 5% \end{scheme} \end{entry} \section{Derived expression types} \label{derivedexps} For reference purposes, section~\ref{derivedsection} gives rewrite rules that will convert constructs described in this section into the primitive constructs described in the previous section. \subsection{Conditionals}\unsection \begin{entry}{% \proto{cond}{ \hyperi{clause} \hyperii{clause} \dotsfoo}{essential \exprtype}} \syntax Each \hyper{clause} should be of the form \begin{scheme} (\hyper{test} \hyper{expression} \dotsfoo)% \end{scheme} where \hyper{test} is any expression. The last \hyper{clause} may be an ``else clause,'' which has the form \begin{scheme} (else \hyperi{expression} \hyperii{expression} \dotsfoo)\rm.% \end{scheme} \mainschindex{else} \mainschindex{=>} \semantics A \ide{cond} expression is evaluated by evaluating the \hyper{test} expressions of successive \hyper{clause}s in order until one of them evaluates to a true value\index{true} (see section~\ref{booleansection}). When a \hyper{test} evaluates to a true value, then the remaining \hyper{expression}s in its \hyper{clause} are evaluated in order, and the result of the last \hyper{expression} in the \hyper{clause} is returned as the result of the entire \ide{cond} expression. If the selected \hyper{clause} contains only the \hyper{test} and no \hyper{expression}s, then the value of the \hyper{test} is returned as the result. If all \hyper{test}s evaluate to false values, and there is no else clause, then the result of the conditional expression is unspecified; if there is an else clause, then its \hyper{expression}s are evaluated, and the value of the last one is returned. \begin{scheme} (cond ((> 3 2) 'greater) ((< 3 2) 'less)) \ev greater% (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)) \ev equal% \end{scheme} Some implementations support an alternative \hyper{clause} syntax, {\tt(\hyper{test} => \hyper{recipient})}, where \hyper{recipient} is an expression. If \hyper{test} evaluates to a true value, then \hyper{recipient} is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the \hyper{test}. \begin{scheme} (cond ((assv 'b '((a 1) (b 2))) => cadr) (else \schfalse{})) \ev 2% \end{scheme} \end{entry} \begin{entry}{% \proto{case}{ \hyper{key} \hyperi{clause} \hyperii{clause} \dotsfoo}{essential \exprtype}} \syntax \hyper{Key} may be any expression. Each \hyper{clause} should have the form \begin{scheme} ((\hyperi{datum} \dotsfoo) \hyperi{expression} \hyperii{expression} \dotsfoo)\rm,% \end{scheme} where each \hyper{datum} is an external representation of some object. All the \hyper{datum}s must be distinct. The last \hyper{clause} may be an ``else clause,'' which has the form \begin{scheme} (else \hyperi{expression} \hyperii{expression} \dotsfoo)\rm.% \end{scheme} \schindex{else} \semantics A \ide{case} expression is evaluated as follows. \hyper{Key} is evaluated and its result is compared against each \hyper{datum}. If the result of evaluating \hyper{key} is equivalent (in the sense of \ide{eqv?}; see section~\ref{eqv?}) to a \hyper{datum}, then the expressions in the corresponding \hyper{clause} are evaluated from left to right and the result of the last expression in the \hyper{clause} is returned as the result of the \ide{case} expression. If the result of evaluating \hyper{key} is different from every \hyper{datum}, then if there is an else clause its expressions are evaluated and the result of the last is the result of the \ide{case} expression; otherwise the result of the \ide{case} expression is unspecified. \begin{scheme} (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite)) \ev composite (case (car '(c d)) ((a) 'a) ((b) 'b)) \ev \unspecified (case (car '(c d)) ((a e i o u) 'vowel) ((w y) 'semivowel) (else 'consonant)) \ev consonant% \end{scheme} \end{entry} \begin{entry}{% \proto{and}{ \hyperi{test} \dotsfoo}{essential \exprtype}} The \hyper{test} expressions are evaluated from left to right, and the value of the first expression that evaluates to a false value (see section~\ref{booleansection}) is returned. Any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then \schtrue{} is returned. \begin{scheme} (and (= 2 2) (> 2 1)) \ev \schtrue (and (= 2 2) (< 2 1)) \ev \schfalse (and 1 2 'c '(f g)) \ev (f g) (and) \ev \schtrue% \end{scheme} \end{entry} \begin{entry}{% \proto{or}{ \hyperi{test} \dotsfoo}{essential \exprtype}} The \hyper{test} expressions are evaluated from left to right, and the value of the first expression that evaluates to a true value (see section~\ref{booleansection}) is returned. Any remaining expressions are not evaluated. If all expressions evaluate to false values, the value of the last expression is returned. If there are no expressions then \schfalse{} is returned. \begin{scheme} (or (= 2 2) (> 2 1)) \ev \schtrue (or (= 2 2) (< 2 1)) \ev \schtrue (or \schfalse \schfalse \schfalse) \ev \schfalse (or (memq 'b '(a b c)) (/ 3 0)) \ev (b c)% \end{scheme} \end{entry} \subsection{Binding constructs} The three binding constructs \ide{let}, \ide{let*}, and \ide{letrec} give Scheme a block structure, like Algol 60. The syntax of the three constructs is identical, but they differ in the regions\index{region} they establish for their variable bindings. In a \ide{let} expression, the initial values are computed before any of the variables become bound; in a \ide{let*} expression, the bindings and evaluations are performed sequentially; while in a \ide{letrec} expression, all the bindings are in effect while their initial values are being computed, thus allowing mutually recursive definitions. \begin{entry}{% \proto{let}{ \hyper{bindings} \hyper{body}}{essential \exprtype}} \syntax \hyper{Bindings} should have the form \begin{scheme} ((\hyperi{variable} \hyperi{init}) \dotsfoo)\rm,% \end{scheme} where each \hyper{init} is an expression, and \hyper{body} should be a sequence of one or more expressions. It is an error for a \hyper{variable} to appear more than once in the list of variables being bound. \semantics The \hyper{init}s are evaluated in the current environment (in some unspecified order), the \hyper{variable}s are bound to fresh locations holding the results, the \hyper{body} is evaluated in the extended environment, and the value of the last expression of \hyper{body} is returned. Each binding of a \hyper{variable} has \hyper{body} as its region.\index{region} \begin{scheme} (let ((x 2) (y 3)) (* x y)) \ev 6 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))) \ev 35% \end{scheme} See also named \ide{let}, section \ref{namedlet}. \end{entry} \begin{entry}{% \proto{let*}{ \hyper{bindings} \hyper{body}}{\exprtype}}\nobreak \nobreak \syntax \hyper{Bindings} should have the form \begin{scheme} ((\hyperi{variable} \hyperi{init}) \dotsfoo)\rm,% \end{scheme} and \hyper{body} should be a sequence of one or more expressions. \semantics \ide{Let*} is similar to \ide{let}, but the bindings are performed sequentially from left to right, and the region\index{region} of a binding indicated by {\cf(\hyper{variable} \hyper{init})} is that part of the \ide{let*} expression to the right of the binding. Thus the second binding is done in an environment in which the first binding is visible, and so on. \begin{scheme} (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))) \ev 70% \end{scheme} \end{entry} \begin{entry}{% \proto{letrec}{ \hyper{bindings} \hyper{body}}{essential \exprtype}} \syntax \hyper{Bindings} should have the form \begin{scheme} ((\hyperi{variable} \hyperi{init}) \dotsfoo)\rm,% \end{scheme} and \hyper{body} should be a sequence of one or more expressions. It is an error for a \hyper{variable} to appear more than once in the list of variables being bound. \semantics The \hyper{variable}s are bound to fresh locations holding undefined values, the \hyper{init}s are evaluated in the resulting environment (in some unspecified order), each \hyper{variable} is assigned to the result of the corresponding \hyper{init}, the \hyper{body} is evaluated in the resulting environment, and the value of the last expression in \hyper{body} is returned. Each binding of a \hyper{variable} has the entire \ide{letrec} expression as its region\index{region}, making it possible to define mutually recursive procedures. \begin{scheme} %(letrec ((x 2) (y 3)) % (letrec ((foo (lambda (z) (+ x y z))) (x 7)) % (foo 4))) \ev 14 % (letrec ((even? (lambda (n) (if (zero? n) \schtrue (odd? (- n 1))))) (odd? (lambda (n) (if (zero? n) \schfalse (even? (- n 1)))))) (even? 88)) \ev \schtrue% \end{scheme} One restriction on \ide{letrec} is very important: it must be possible to evaluate each \hyper{init} without assigning or referring to the value of any \hyper{variable}. If this restriction is violated, then it is an error. The restriction is necessary because Scheme passes arguments by value rather than by name. In the most common uses of \ide{letrec}, all the \hyper{init}s are \lambdaexp{}s and the restriction is satisfied automatically. % \todo{use or uses? --- Jinx.} \end{entry} \subsection{Sequencing}\unsection \begin{entry}{% \proto{begin}{ \hyperi{expression} \hyperii{expression} \dotsfoo}{essential \exprtype}} The \hyper{expression}s are evaluated sequentially from left to right, and the value of the last \hyper{expression} is returned. This expression type is used to sequence side effects such as input and output. \begin{scheme} (define x 0) (begin (set! x 5) (+ x 1)) \ev 6 (begin (display "4 plus 1 equals ") (display (+ 4 1))) \ev \unspecified \>{\em and prints} 4 plus 1 equals 5% \end{scheme} \begin{note} \cite{SICP} uses the keyword \ide{sequence} instead of \ide{begin}. \end{note} \end{entry} \subsection{Iteration}%\unsection \noindent% \pproto{(do ((\hyperi{variable} \hyperi{init} \hyperi{step})}{\exprtype} \mainschindex{do}{\tt\obeyspaces% \dotsfoo)\\ (\hyper{test} \hyper{expression} \dotsfoo)\\ \hyper{command} \dotsfoo)} \ide{Do} is an iteration construct. It specifies a set of variables to be bound, how they are to be initialized at the start, and how they are to be updated on each iteration. When a termination condition is met, the loop exits with a specified result value. \ide{Do} expressions are evaluated as follows: The \hyper{init} expressions are evaluated (in some unspecified order), the \hyper{variable}s are bound to fresh locations, the results of the \hyper{init} expressions are stored in the bindings of the \hyper{variable}s, and then the iteration phase begins. \vest Each iteration begins by evaluating \hyper{test}; if the result is false (see section~\ref{booleansection}), then the \hyper{command} expressions are evaluated in order for effect, the \hyper{step} expressions are evaluated in some unspecified order, the \hyper{variable}s are bound to fresh locations, the results of the \hyper{step}s are stored in the bindings of the \hyper{variable}s, and the next iteration begins. \vest If \hyper{test} evaluates to a true value, then the \hyper{expression}s are evaluated from left to right and the value of the last \hyper{expression} is returned as the value of the \ide{do} expression. If no \hyper{expression}s are present, then the value of the \ide{do} expression is unspecified. \vest The region\index{region} of the binding of a \hyper{variable} consists of the entire \ide{do} expression except for the \hyper{init}s. It is an error for a \hyper{variable} to appear more than once in the list of \ide{do} variables. \vest A \hyper{step} may be omitted, in which case the effect is the same as if {\cf(\hyper{variable} \hyper{init} \hyper{variable})} had been written instead of {\cf(\hyper{variable} \hyper{init})}. \begin{scheme} (do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i)) \ev \#(0 1 2 3 4) (let ((x '(1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum))) \ev 25% \end{scheme} %\end{entry} \begin{entry}{% \proto{let}{ \hyper{variable} \hyper{bindings} \hyper{body}}{\exprtype}} \label{namedlet} Some implementations of Scheme permit a variant on the syntax of \ide{let} called ``named \ide{let}'' which provides a more general looping construct than \ide{do}, and may also be used to express recursions. Named \ide{let} has the same syntax and semantics as ordinary \ide{let} except that \hyper{variable} is bound within \hyper{body} to a procedure whose formal arguments are the bound variables and whose body is \hyper{body}. Thus the execution of \hyper{body} may be repeated by invoking the procedure named by \hyper{variable}. % | <-- right margin \begin{scheme} (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) (cond ((null? numbers) (list nonneg neg)) ((>= (car numbers) 0) (loop (cdr numbers) (cons (car numbers) nonneg) neg)) ((< (car numbers) 0) (loop (cdr numbers) nonneg (cons (car numbers) neg))))) % \lev ((6 1 3) (-5 -2))% \end{scheme} \end{entry} \subsection{Delayed evaluation}\unsection \label{delay} \begin{entry}{% \proto{delay}{ \hyper{expression}}{\exprtype}} \todo{Fix.} The \ide{delay} construct is used together with the procedure \ide{force} to implement \defining{lazy evaluation} or \defining{call by need}. {\tt(delay \hyper{expression})} returns an object called a \defining{promise} which at some point in the future may be asked (by the \ide{force} procedure) \todo{Bartley's white lie; OK?} to evaluate \hyper{expression} and deliver the resulting value. See the description of \ide{force} (section~\ref{force}) for a more complete description of \ide{delay}. \end{entry} \subsection{Quasiquotation}\unsection \label{quasiquotesection} \begin{entry}{% \proto{quasiquote}{ \hyper{template}}{essential \exprtype} \nopagebreak \pproto{\backquote\hyper{template}}{essential \exprtype}} ``Backquote'' or ``quasiquote''\index{backquote} expressions are useful for constructing a list or vector structure when most but not all of the desired structure is known in advance. If no commas\index{comma} appear within the \hyper{template}, the result of evaluating \backquote\hyper{template} is equivalent to the result of evaluating \singlequote\hyper{template}. If a comma\mainschindex{,} appears within the \hyper{template}, however, the expression following the comma is evaluated (``unquoted'') and its result is inserted into the structure instead of the comma and the expression. If a comma appears followed immediately by an at-sign (\atsign),\index{at-sign} then the following expression must evaluate to a list; the opening and closing parentheses of the list are then ``stripped away'' and the elements of the list are inserted in place of the comma at-sign expression sequence. % struck: "(in the sense of \ide{equal?})" after "equivalent" \begin{scheme} `(list ,(+ 1 2) 4) \ev (list 3 4) (let ((name 'a)) `(list ,name ',name)) % \lev (list a (quote a)) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b) % \lev (a 3 4 5 6 b) `((\ide{foo} ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))) % \lev ((foo 7) . cons) `\#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8) % \lev \#(10 5 2 4 3 8)% \end{scheme} Quasiquote forms may be nested. Substitutions are made only for unquoted components appearing at the same nesting level as the outermost backquote. The nesting level increases by one inside each successive quasiquotation, and decreases by one inside each unquotation. \begin{scheme} `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) % \lev (a `(b ,(+ 1 2) ,(foo 4 d) e) f) (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) % \lev (a `(b ,x ,'y d) e)% \end{scheme} The notations \backquote\hyper{template} and {\tt (quasiquote \hyper{template})} are identical in all respects. {\cf,\hyper{expression}} is identical to {\cf (unquote \hyper{expression})}, and {\cf,@\hyper{expression}} is identical to {\cf (unquote-splicing \hyper{expression})}. The external syntax generated by \ide{write} for two-element lists whose car is one of these symbols may vary between implementations. \mainschindex{`} \begin{scheme} (quasiquote (list (unquote (+ 1 2)) 4)) % \lev (list 3 4) '(quasiquote (list (unquote (+ 1 2)) 4)) % \lev `(list ,(+ 1 2) 4) {\em{}i.e.,} (quasiquote (list (unquote (+ 1 2)) 4))% \end{scheme} Unpredictable behavior can result if any of the symbols \ide{quasiquote}, \ide{unquote}, or \ide{unquote-splicing} appear in positions within a \hyper{template} otherwise than as described above. \end{entry} scheme2c-2012.10.14/doc/r4rs/first.tex000066400000000000000000000047301203736146400171150ustar00rootroot00000000000000% First page \thispagestyle{empty} % \todo{"another" report?} \topnewpage[{ \begin{center} {\huge\bf Revised$^{\bf 4}$ Report on the Algorithmic Language \\ \vskip 3pt Scheme} \vskip 1ex $$ \begin{tabular}{l@{\extracolsep{.5in}}lll} \multicolumn{4}{c}{W{\sc ILLIAM} C{\sc LINGER AND} J{\sc ONATHAN} R{\sc EES} ({\it Editors\/})} \\ H. A{\sc BELSON} & R. K. D{\sc YBVIG} & C. T. H{\sc AYNES} & G. J. R{\sc OZAS} \\ N. I. A{\sc DAMS IV} & D. P. F{\sc RIEDMAN} & E. K{\sc OHLBECKER} & G. L. S{\sc TEELE} J{\sc R}. \\ D. H. B{\sc ARTLEY} & R. H{\sc ALSTEAD} & D. O{\sc XLEY} & G. J. S{\sc USSMAN} \\ G. B{\sc ROOKS} & C. H{\sc ANSON} & K. M. P{\sc ITMAN} & M. W{\sc AND} \\ \end{tabular} $$ \vskip 2ex {\it Dedicated to the Memory of ALGOL 60} \vskip 2.6ex \end{center} }] \chapter*{Summary} The report gives a defining description of the programming language Scheme. Scheme is a statically scoped and properly tail-recursive dialect of the Lisp programming language invented by Guy Lewis Steele~Jr.\ and Gerald Jay~Sussman. It was designed to have an exceptionally clear and simple semantics and few different ways to form expressions. A wide variety of programming paradigms, including imperative, functional, and message passing styles, find convenient expression in Scheme. \vest The introduction offers a brief history of the language and of the report. \vest The first three chapters present the fundamental ideas of the language and describe the notational conventions used for describing the language and for writing programs in the language. \vest Chapters~\ref{expressionchapter} and~\ref{programchapter} describe the syntax and semantics of expressions, programs, and definitions. \vest Chapter~\ref{builtinchapter} describes Scheme's built-in procedures, which include all of the language's data manipulation and input/output primitives. \vest Chapter~\ref{formalchapter} provides a formal syntax for Scheme written in extended BNF, along with a formal denotational semantics. An example of the use of the language follows the formal syntax and semantics. \vest The appendix describes a macro facility that may be used to extend the syntax of Scheme. \vest The report concludes with a bibliography and an alphabetic index. \todo{expand the summary so that it fills up the column.} %\vfill %\begin{center} %{\large \bf %*** DRAFT*** \\ %August 31, 1989%\today %}\end{center} \vfill \eject {\footnotesize \tableofcontents } \vfill \eject scheme2c-2012.10.14/doc/r4rs/index.sch000066400000000000000000000065661203736146400170630ustar00rootroot00000000000000; Program to process r4rs.idx entries. (define main 0) (define aux 1) (define (make-entry key font main/aux page) (list key font main/aux page)) (define (entry-key x) (car x)) (define (entry-font x) (cadr x)) (define (entry-main/aux x) (caddr x)) (define (entry-page x) (cadddr x)) (define *database* '()) (define (index-entry key font main/aux page) (set! *database* (cons (make-entry (string-downcase key) font main/aux page) *database*)) #t) (define (create-index p) (define (loop) (if (null? *database*) 'done (begin (process-key (collect-entries) p) (loop)))) (set! *database* (sort *database* (lambda (x y) (stringstring '(#\\)))) (define *s2* "{") (define *s3* "}}{\\hskip .75em}") (define *semi* "\; ") (define *comma* ", ") (define (write-entries key font main pages p) (if (and (char-alphabetic? (string-ref key 0)) (not (char=? (string-ref *last-key* 0) (string-ref key 0)))) (begin (display "\\indexspace" p) (newline p))) (set! *last-key* key) (display (string-append *s1* font *s2* key *s3*) p) (if main (begin (write main p) (if (not (null? pages)) (display *semi* p)))) (if (not (null? pages)) (begin (write (car pages) p) (for-each (lambda (page) (display *comma* p) (write page p)) (cdr pages)))) (newline p)) scheme2c-2012.10.14/doc/r4rs/index.tex000066400000000000000000000277001203736146400170770ustar00rootroot00000000000000\item{\tt{!}}{\hskip .75em}4 \item{\tt{'}}{\hskip .75em}7; 16 \item{\tt{*}}{\hskip .75em}21; 8, 38 \item{\tt{+}}{\hskip .75em}21; 5, 8, 13, 19, 28, 36, 38 \item{\tt{,}}{\hskip .75em}11; 16 \item{\tt{-}}{\hskip .75em}21; 5, 38 \item{\tt{->}}{\hskip .75em}4, 5 \item{\tt{...}}{\hskip .75em}5 \item{\tt{/}}{\hskip .75em}21; 20, 38 \item{\tt{;}}{\hskip .75em}5 \item{\tt{<}}{\hskip .75em}21; 36, 38 \item{\tt{<=}}{\hskip .75em}21; 25, 38 \item{\tt{=}}{\hskip .75em}21; 14, 38 \item{\tt{=>}}{\hskip .75em}9 \item{\tt{>}}{\hskip .75em}21; 38 \item{\tt{>=}}{\hskip .75em}21; 38 \item{\tt{?}}{\hskip .75em}4 \item{\tt{`}}{\hskip .75em}12 \indexspace \item{\tt{abs}}{\hskip .75em}21; 13, 23 \item{\tt{acos}}{\hskip .75em}23 \item{\tt{and}}{\hskip .75em}9; 13, 38 \item{\tt{angle}}{\hskip .75em}23 \item{\tt{append}}{\hskip .75em}17; 38 \item{\tt{apply}}{\hskip .75em}27; 36 \item{\tt{approximate}}{\hskip .75em}38 \item{\tt{asin}}{\hskip .75em}23 \item{\tt{assoc}}{\hskip .75em}17 \item{\tt{assq}}{\hskip .75em}17 \item{\tt{assv}}{\hskip .75em}17 \item{\rm{at-sign}}{\hskip .75em}11 \item{\tt{atan}}{\hskip .75em}23 \indexspace \item{\sharpfoo{b}}{\hskip .75em}20, 32 \item{\rm{backquote}}{\hskip .75em}11 \item{\tt{begin}}{\hskip .75em}10; 11, 12, 37, 38 \item{\rm{binding}}{\hskip .75em}6 \item{\rm{binding construct}}{\hskip .75em}6 \item{\tt{boolean?}}{\hskip .75em}13; 38 \item{\rm{bound}}{\hskip .75em}6 \item{\tt{bound-identifier=?}}{\hskip .75em}45 \indexspace \item{\tt{caar}}{\hskip .75em}16 \item{\tt{caddr}}{\hskip .75em}16 \item{\tt{cadr}}{\hskip .75em}16 \item{\rm{call}}{\hskip .75em}8 \item{\rm{call by need}}{\hskip .75em}11 \item{\tt{call-with-current-continuation}}{\hskip .75em}28; 29, 36 \item{\tt{call-with-input-file}}{\hskip .75em}29 \item{\tt{call-with-output-file}}{\hskip .75em}29 \item{\tt{call/cc}}{\hskip .75em}29 \item{\tt{car}}{\hskip .75em}16; 7, 15, 36 \item{\tt{case}}{\hskip .75em}9; 38 \item{\tt{catch}}{\hskip .75em}29 \item{\tt{cdddar}}{\hskip .75em}16 \item{\tt{cddddr}}{\hskip .75em}16 \item{\tt{cdr}}{\hskip .75em}16; 15, 28 \item{\tt{ceiling}}{\hskip .75em}22 \item{\tt{char->integer}}{\hskip .75em}25 \item{\tt{char-alphabetic?}}{\hskip .75em}25 \item{\tt{char-ci<=?}}{\hskip .75em}25 \item{\tt{char-ci=?}}{\hskip .75em}25 \item{\tt{char-ci>?}}{\hskip .75em}25 \item{\tt{char-downcase}}{\hskip .75em}25 \item{\tt{char-lower-case?}}{\hskip .75em}25 \item{\tt{char-numeric?}}{\hskip .75em}25 \item{\tt{char-ready}}{\hskip .75em}30 \item{\tt{char-ready?}}{\hskip .75em}30; 31 \item{\tt{char-upcase}}{\hskip .75em}25 \item{\tt{char-upper-case?}}{\hskip .75em}25 \item{\tt{char-whitespace?}}{\hskip .75em}25 \item{\tt{char<=?}}{\hskip .75em}24; 25 \item{\tt{char=?}}{\hskip .75em}24 \item{\tt{char>?}}{\hskip .75em}24 \item{\tt{char?}}{\hskip .75em}24; 38 \item{\tt{close-input-port}}{\hskip .75em}30 \item{\tt{close-output-port}}{\hskip .75em}30 \item{\rm{combination}}{\hskip .75em}8 \item{\rm{comma}}{\hskip .75em}11 \item{\rm{comment}}{\hskip .75em}5; 32 \item{\tt{complex?}}{\hskip .75em}20; 19, 21 \item{\tt{cond}}{\hskip .75em}9; 13 \item{\tt{cons}}{\hskip .75em}16; 15 \item{\rm{constant}}{\hskip .75em}7 \item{\tt{construct-identifier}}{\hskip .75em}45 \item{\rm{continuation}}{\hskip .75em}29 \item{\tt{cos}}{\hskip .75em}23 \item{\tt{current-input-port}}{\hskip .75em}30; 31 \item{\tt{current-output-port}}{\hskip .75em}30; 31 \indexspace \item{\sharpfoo{d}}{\hskip .75em}20 \item{\tt{d}}{\hskip .75em}20 \item{\tt{define}}{\hskip .75em}12; 13 \item{\tt{define-syntax}}{\hskip .75em}41 \item{\rm{definition}}{\hskip .75em}12 \item{\tt{delay}}{\hskip .75em}11; 28 \item{\tt{denominator}}{\hskip .75em}22 \item{\tt{display}}{\hskip .75em}31 \item{\tt{do}}{\hskip .75em}11; 6, 13, 37, 38 \item{\rm{dotted pair}}{\hskip .75em}15 \indexspace \item{\sharpfoo{e}}{\hskip .75em}20, 32 \item{\tt{e}}{\hskip .75em}20 \item{\tt{else}}{\hskip .75em}9 \item{\rm{empty list}}{\hskip .75em}15; 16 \item{\tt{eof-object?}}{\hskip .75em}30 \item{\tt{eq?}}{\hskip .75em}15; 8, 13, 17 \item{\tt{equal?}}{\hskip .75em}15; 13, 17, 26 \item{\rm{equivalence predicate}}{\hskip .75em}13 \item{\tt{eqv?}}{\hskip .75em}13; 7, 8, 9, 14, 15, 16, 17, 18, 38 \item{\rm{error}}{\hskip .75em}3 \item{\rm{escape procedure}}{\hskip .75em}28 \item{\rm{essential}}{\hskip .75em}3 \item{\tt{even?}}{\hskip .75em}21 \item{\rm{exact}}{\hskip .75em}14 \item{\tt{exact->inexact}}{\hskip .75em}23 \item{\tt{exact?}}{\hskip .75em}21 \item{\rm{exactness}}{\hskip .75em}19 \item{\tt{exp}}{\hskip .75em}23 \item{\tt{expt}}{\hskip .75em}23 \indexspace \item{\sharpfoo{f}}{\hskip .75em}13 \item{\tt{f}}{\hskip .75em}20 \item{\rm{false}}{\hskip .75em}6; 13 \item{\tt{floor}}{\hskip .75em}22 \item{\tt{foo}}{\hskip .75em}5, 12 \item{\tt{for-each}}{\hskip .75em}28; 38 \item{\tt{force}}{\hskip .75em}28; 11, 38 \item{\tt{free-identifier=?}}{\hskip .75em}44 \indexspace \item{\tt{gcd}}{\hskip .75em}22 \item{\tt{gen-counter}}{\hskip .75em}14 \item{\tt{gen-loser}}{\hskip .75em}14 \item{\tt{generate-identifier}}{\hskip .75em}45 \indexspace \item{\rm{hygienic}}{\hskip .75em}40 \indexspace \item{\sharpfoo{i}}{\hskip .75em}20, 32 \item{\rm{identifier}}{\hskip .75em}5; 6, 18, 32 \item{\tt{identifier->symbol}}{\hskip .75em}45 \item{\tt{identifier?}}{\hskip .75em}44 \item{\tt{if}}{\hskip .75em}8; 13, 35, 36 \item{\tt{imag-part}}{\hskip .75em}23 \item{\rm{immutable}}{\hskip .75em}7 \item{\rm{implementation restriction}}{\hskip .75em}4; 19 \item{\rm{improper list}}{\hskip .75em}16 \item{\rm{inexact}}{\hskip .75em}14 \item{\tt{inexact->exact}}{\hskip .75em}23; 19, 22 \item{\tt{inexact?}}{\hskip .75em}21 \item{\rm{initial environment}}{\hskip .75em}13 \item{\tt{input-port?}}{\hskip .75em}29 \item{\tt{integer->char}}{\hskip .75em}25; 38 \item{\tt{integer?}}{\hskip .75em}20; 19 \item{\tt{integrate-system}}{\hskip .75em}39 \item{\rm{internal definition}}{\hskip .75em}13 \indexspace \item{\rm{keyword}}{\hskip .75em}5, 6, 32, 40 \indexspace \item{\tt{l}}{\hskip .75em}20 \item{\tt{lambda}}{\hskip .75em}8; 13, 34, 35, 36, 38 \item{\rm{lambda expression{}}}{\hskip .75em}6 \item{\tt{last-pair}}{\hskip .75em}38 \item{\rm{lazy evaluation}}{\hskip .75em}11 \item{\tt{lcm}}{\hskip .75em}22 \item{\tt{length}}{\hskip .75em}17; 19 \item{\tt{let}}{\hskip .75em}10, 11; 6, 13, 37, 38 \item{\tt{let*}}{\hskip .75em}10; 6, 13 \item{\tt{let-syntax}}{\hskip .75em}41 \item{\tt{letrec}}{\hskip .75em}10; 6, 13, 38 \item{\tt{letrec-syntax}}{\hskip .75em}41 \item{\tt{list}}{\hskip .75em}17; 27 \item{\tt{list->string}}{\hskip .75em}26 \item{\tt{list->vector}}{\hskip .75em}27; 4 \item{\tt{list-ref}}{\hskip .75em}17 \item{\tt{list-tail}}{\hskip .75em}17 \item{\tt{list?}}{\hskip .75em}16; 38 \item{\tt{load}}{\hskip .75em}31 \item{\rm{location}}{\hskip .75em}7 \item{\tt{log}}{\hskip .75em}23 \indexspace \item{\rm{macro}}{\hskip .75em}40 \item{\rm{macro keyword}}{\hskip .75em}40 \item{\rm{macro transformer}}{\hskip .75em}40 \item{\rm{macro use}}{\hskip .75em}40 \item{\tt{magnitude}}{\hskip .75em}23 \item{\tt{make-polar}}{\hskip .75em}23 \item{\tt{make-promise}}{\hskip .75em}28 \item{\tt{make-rectangular}}{\hskip .75em}23 \item{\tt{make-string}}{\hskip .75em}25 \item{\tt{make-vector}}{\hskip .75em}26 \item{\tt{map}}{\hskip .75em}27; 28, 38, 39 \item{\tt{map-streams}}{\hskip .75em}39 \item{\tt{max}}{\hskip .75em}21 \item{\tt{member}}{\hskip .75em}17 \item{\tt{memq}}{\hskip .75em}17 \item{\tt{memv}}{\hskip .75em}17; 37 \item{\tt{min}}{\hskip .75em}21 \item{\tt{modulo}}{\hskip .75em}22 \item{\rm{mutable}}{\hskip .75em}7 \indexspace \item{\tt{negative?}}{\hskip .75em}21 \item{\tt{newline}}{\hskip .75em}31 \item{\tt{nil}}{\hskip .75em}13, 38 \item{\tt{not}}{\hskip .75em}13 \item{\tt{null?}}{\hskip .75em}16 \item{\rm{number}}{\hskip .75em}18 \item{\tt{number->string}}{\hskip .75em}23; 24, 38 \item{\tt{number?}}{\hskip .75em}20; 19, 21, 38 \item{\tt{numerator}}{\hskip .75em}22 \item{\rm{numerical types}}{\hskip .75em}19 \indexspace \item{\sharpfoo{o}}{\hskip .75em}20, 32 \item{\rm{object}}{\hskip .75em}3 \item{\tt{odd?}}{\hskip .75em}21 \item{\tt{open-input-file}}{\hskip .75em}30 \item{\tt{open-output-file}}{\hskip .75em}30 \item{\tt{or}}{\hskip .75em}9; 13, 38 \item{\tt{output-port?}}{\hskip .75em}29 \indexspace \item{\rm{pair}}{\hskip .75em}15 \item{\tt{pair?}}{\hskip .75em}16; 38 \item{\tt{peek-char}}{\hskip .75em}30; 38 \item{\rm{port}}{\hskip .75em}29 \item{\tt{positive?}}{\hskip .75em}21 \item{\rm{predicate}}{\hskip .75em}13 \item{\rm{procedure call}}{\hskip .75em}8 \item{\tt{procedure?}}{\hskip .75em}27; 38 \item{\rm{promise}}{\hskip .75em}11; 28 \indexspace \item{\tt{quasiquote}}{\hskip .75em}11; 12, 16, 38 \item{\tt{quote}}{\hskip .75em}7; 6, 16 \item{\tt{quotient}}{\hskip .75em}22 \indexspace \item{\tt{rational?}}{\hskip .75em}20; 19, 21 \item{\tt{rationalize}}{\hskip .75em}22; 38 \item{\tt{read}}{\hskip .75em}30; 3, 6, 16, 18, 33 \item{\tt{read-char}}{\hskip .75em}30 \item{\tt{real-part}}{\hskip .75em}23 \item{\tt{real?}}{\hskip .75em}20; 19, 21 \item{\rm{referentially transparent}}{\hskip .75em}40 \item{\rm{region}}{\hskip .75em}6; 9, 10, 11 \item{\tt{remainder}}{\hskip .75em}22 \item{\tt{return}}{\hskip .75em}29 \item{\tt{reverse}}{\hskip .75em}17 \item{\tt{round}}{\hskip .75em}22 \item{\tt{runge-kutta-4}}{\hskip .75em}39 \indexspace \item{\tt{s}}{\hskip .75em}20 \item{\tt{sequence}}{\hskip .75em}11 \item{\tt{set!}}{\hskip .75em}9; 12, 35, 36 \item{\tt{set-car!}}{\hskip .75em}16; 7, 15, 36 \item{\tt{set-cdr!}}{\hskip .75em}16; 15 \item{\rm{simplest rational}}{\hskip .75em}22 \item{\tt{sin}}{\hskip .75em}23 \item{\tt{sqrt}}{\hskip .75em}23; 20 \item{\tt{string}}{\hskip .75em}25 \item{\tt{string->list}}{\hskip .75em}26 \item{\tt{string->number}}{\hskip .75em}24; 38 \item{\tt{string->symbol}}{\hskip .75em}18 \item{\tt{string-append}}{\hskip .75em}26 \item{\tt{string-ci<=?}}{\hskip .75em}26 \item{\tt{string-ci=?}}{\hskip .75em}26 \item{\tt{string-ci>?}}{\hskip .75em}26 \item{\tt{string-copy}}{\hskip .75em}26 \item{\tt{string-fill!}}{\hskip .75em}26 \item{\tt{string-length}}{\hskip .75em}25; 19 \item{\tt{string-ref}}{\hskip .75em}25; 7 \item{\tt{string-set!}}{\hskip .75em}26; 7, 18 \item{\tt{string<=?}}{\hskip .75em}26 \item{\tt{string=?}}{\hskip .75em}26 \item{\tt{string>?}}{\hskip .75em}26 \item{\tt{string?}}{\hskip .75em}25; 38 \item{\tt{substring}}{\hskip .75em}26 \item{\tt{symbol->string}}{\hskip .75em}18; 7 \item{\tt{symbol?}}{\hskip .75em}18; 38 \item{\rm{syntactic keyword}}{\hskip .75em}5, 6, 32, 40 \item{\tt{syntax}}{\hskip .75em}44 \item{\tt{syntax-rules}}{\hskip .75em}42 \indexspace \item{\sharpfoo{t}}{\hskip .75em}13 \item{\tt{t}}{\hskip .75em}38 \item{\tt{tan}}{\hskip .75em}23 \item{\rm{token}}{\hskip .75em}32 \item{\rm{top level environment}}{\hskip .75em}13; 6 \item{\tt{transcript-off}}{\hskip .75em}31 \item{\tt{transcript-on}}{\hskip .75em}31 \item{\rm{true}}{\hskip .75em}6; 8, 9, 13 \item{\tt{truncate}}{\hskip .75em}22 \item{\rm{type}}{\hskip .75em}7 \indexspace \item{\rm{unbound}}{\hskip .75em}6; 7, 12 \item{\tt{unquote}}{\hskip .75em}12, 16 \item{\tt{unquote-splicing}}{\hskip .75em}12, 16 \item{\rm{unspecified}}{\hskip .75em}4 \item{\tt{unwrap-syntax}}{\hskip .75em}44 \indexspace \item{\rm{valid indexes}}{\hskip .75em}25; 26 \item{\tt{values-list}}{\hskip .75em}36 \item{\rm{variable}}{\hskip .75em}6; 5, 7, 32 \item{\tt{vector}}{\hskip .75em}27 \item{\tt{vector->list}}{\hskip .75em}27 \item{\tt{vector-fill!}}{\hskip .75em}27 \item{\tt{vector-length}}{\hskip .75em}27; 19 \item{\tt{vector-ref}}{\hskip .75em}27; 7 \item{\tt{vector-set!}}{\hskip .75em}27 \item{\tt{vector?}}{\hskip .75em}26; 38 \indexspace \item{\rm{whitespace}}{\hskip .75em}5 \item{\tt{with-input-from-file}}{\hskip .75em}30 \item{\tt{with-output-to-file}}{\hskip .75em}30 \item{\tt{write}}{\hskip .75em}31; 6, 12, 18 \item{\tt{write-char}}{\hskip .75em}31 \indexspace \item{\sharpfoo{x}}{\hskip .75em}20, 32 \indexspace \item{\tt{zero?}}{\hskip .75em}21 scheme2c-2012.10.14/doc/r4rs/intro.tex000066400000000000000000000175611203736146400171270ustar00rootroot00000000000000\clearextrapart{Introduction} \label{historysection} Programming languages should be designed not by piling feature on top of feature, but by removing the weaknesses and restrictions that make additional features appear necessary. Scheme demonstrates that a very small number of rules for forming expressions, with no restrictions on how they are composed, suffice to form a practical and efficient programming language that is flexible enough to support most of the major programming paradigms in use today. %Scheme has influenced the evolution of Lisp. Scheme was one of the first programming languages to incorporate first class procedures as in the lambda calculus, thereby proving the usefulness of static scope rules and block structure in a dynamically typed language. Scheme was the first major dialect of Lisp to distinguish procedures from lambda expressions and symbols, to use a single lexical environment for all variables, and to evaluate the operator position of a procedure call in the same way as an operand position. By relying entirely on procedure calls to express iteration, Scheme emphasized the fact that tail-recursive procedure calls are essentially goto's that pass arguments. Scheme was the first widely used programming language to embrace first class escape procedures, from which all previously known sequential control structures can be synthesized. More recently, building upon the design of generic arithmetic in Common Lisp, Scheme introduced the concept of exact and inexact numbers. With the appendix to this report Scheme becomes the first programming language to support hygienic macros, which permit the syntax of a block-structured language to be extended reliably. % A few %of these innovations have recently been incorporated into Common Lisp, while %others remain to be adopted. \todo{Ramsdell: I would like to make a few comments on presentation. The most important comment is about section organization. Newspaper writers spend most of their time writing the first three paragraphs of any article. This part of the article is often the only part read by readers, and is important in enticing readers to continue. In the same way, The first page is most likely to be the only page read by many SIGPLAN readers. If I had my choice of what I would ask them to read, it would be the material in section 1.1, the Semantics section that notes that scheme is lexically scoped, tail recursive, weakly typed, ... etc. I would expand on the discussion on continutations, as they represent one important difference between Scheme and other languages. The introduction, with its history of scheme, its history of scheme reports and meetings, and acknowledgements giving names of people that the reader will not likely know, is not that one page I would like all to read. I suggest moving the history to the back of the report, and use the first couple of pages to convince the reader that the language documented in this report is worth studying. } \subsection*{Background} \vest The first description of Scheme was written in 1975~\cite{Scheme75}. A revised report~\cite{Scheme78} \todo{italicize or not?} appeared in 1978, which described the evolution of the language as its MIT implementation was upgraded to support an innovative compiler~\cite{Rabbit}. Three distinct projects began in 1981 and 1982 to use variants of Scheme for courses at MIT, Yale, and Indiana University~\cite{Rees82,MITScheme,Scheme311}. An introductory computer science textbook using Scheme was published in 1984~\cite{SICP}. %\vest As might be expected of a language used primarily for education and %research, Scheme has always evolved rapidly. This was no problem when %Scheme was used only within MIT, but \vest As Scheme became more widespread, local dialects began to diverge until students and researchers occasionally found it difficult to understand code written at other sites. Fifteen representatives of the major implementations of Scheme therefore met in October 1984 to work toward a better and more widely accepted standard for Scheme. %Participating in this workshop were Hal Abelson, Norman Adams, David %Bartley, Gary Brooks, William Clinger, Daniel Friedman, Robert Halstead, %Chris Hanson, Christopher Haynes, Eugene Kohlbecker, Don Oxley, Jonathan Rees, %Guillermo Rozas, Gerald Jay Sussman, and Mitchell Wand. Kent Pitman %made valuable contributions to the agenda for the workshop but was %unable to attend the sessions. % %Subsequent electronic mail discussions and committee work completed the %definition of the language. %Gerry Sussman drafted the section on numbers, Chris Hanson drafted the %sections on characters and strings, and Gary Brooks and William Clinger %drafted the sections on input and output. %William Clinger recorded the decisions of the workshop and %compiled the pieces into a coherent document. %The ``Revised revised report on Scheme''~\cite{RRRS} Their report~\cite{RRRS} was published at MIT and Indiana University in the summer of 1985. Another round of revision took place in the spring of 1986~\cite{R3RS}. %, again accomplished %almost entirely by electronic mail, resulted in the present report. The present report reflects further revisions agreed upon in a meeting that preceded the 1988 ACM Conference on Lisp and Functional Programming and in subsequent electronic mail. %\vest The number 3 in the title is part of the title, not a reference to %a footnote. The word ``revised'' is raised to the third power because %the report is a revision of a report that was already twice revised. \todo{Write an editors' note?} \medskip We intend this report to belong to the entire Scheme community, and so we grant permission to copy it in whole or in part without fee. In particular, we encourage implementors of Scheme to use this report as a starting point for manuals and other documentation, modifying it as necessary. \subsection*{Acknowledgements} We would like to thank the following people for their help: Alan Bawden, Michael Blair, George Carrette, Andy Cromarty, Pavel Curtis, Jeff Dalton, Olivier Danvy, Ken Dickey, Andy Freeman, Richard Gabriel, Yekta G\"ursel, Ken Haase, Robert Hieb, Paul Hudak, Richard Kelsey, Morry Katz, Chris Lindblad, Mark Meyer, Jim Miller, Jim Philbin, John Ramsdell, Mike Shaff, Jonathan Shapiro, Julie Sussman, Perry Wagle, Daniel Weise, Henry Wu, and Ozan Yigit. We thank Carol Fessenden, Daniel Friedman, and Christopher Haynes for permission to use text from the Scheme 311 version 4 reference manual. We thank Texas Instruments, Inc.~for permission to use text from the {\em TI Scheme Language Reference Manual.} We gladly acknowledge the influence of manuals for MIT Scheme, T, Scheme 84, Common Lisp, and Algol 60. \vest We also thank Betty Dexter for the extreme effort she put into setting this report in \TeX, and Donald Knuth for designing the program that caused her troubles. \vest The Artificial Intelligence Laboratory of the Massachusetts Institute of Technology, the Computer Science Department of Indiana University, and the Computer and Information Sciences Department of the University of Oregon supported the preparation of this report. Support for the MIT work was provided in part by the Advanced Research Projects Agency of the Department of Defense under Office of Naval Research contract N00014-80-C-0505. Support for the Indiana University work was provided by NSF grants NCS 83-04567 and NCS 83-03325. \todo{Steele: [c] There should be a very clear message to the reader that Scheme certainly does owe debts to other sources, and one of them is Common Lisp. While Scheme certainly has been the pioneer in the treatment of closures and functional programming in a Lisp framework, I think it is fair to say that Common lisp pioneered a rational (forgive the pun) treatment of numeric data types in a Lisp framework, and my impression is that Scheme learned something in this area from the Common Lisp experience. } % I think the above \todo has been done. -- Will, 1991. scheme2c-2012.10.14/doc/r4rs/lex.tex000066400000000000000000000136541203736146400165630ustar00rootroot00000000000000% Lexical structure %%\vfill\eject \chapter{Lexical conventions} This section gives an informal account of some of the lexical conventions used in writing Scheme programs. For a formal syntax of Scheme, see section~\ref{BNF}. \vest Upper and lower case forms of a letter are never distinguished except within character and string constants. For example, \ide{Foo} is the same identifier as \ide{FOO}, and {\tt\#x1AB} is the same number as {\tt\#X1ab}. \section{Identifiers} \label{syntaxsection} Most identifiers\mainindex{identifier} allowed by other programming languages are also acceptable to Scheme. The precise rules for forming identifiers vary among implementations of Scheme, but in all implementations a sequence of letters, digits, and ``extended alphabetic characters'' that begins with a character that cannot begin a number is an identifier. In addition, \ide{+}, \ide{-}, and \ide{...} are identifiers. Here are some examples of identifiers: \begin{scheme} lambda q list->vector soup {+} V17a <=? a34kTMNs the-word-recursion-has-many-meanings% \end{scheme} % _ = 5F & = 26 ~ = 7E ^ = 5E Extended alphabetic characters may be used within identifiers as if they were letters. The following are extended alphabetic characters: \begin{scheme} + - . * / < = > !\ ?\ :\ \$ \% \char"5F{} \char"26{} \char"7E{} \char"5E % \end{scheme} See section~\ref{extendedalphas} for a formal syntax of identifiers. \vest Identifiers have several uses within Scheme programs: \begin{itemize} \item Certain identifiers are reserved for use as syntactic keywords (see below).\index{syntactic keyword}\index{keyword} % (This does not preclude their use as identifiers %as well, although in certain situations ambiguities can result if this is done.) \item Any identifier that is not a syntactic keyword may be used as a variable\index{variable} (see section~\ref{variablesection}). \item When an identifier appears as a literal or within a literal (see section~\ref{quote}), it is being used to denote a {\em symbol} (see section~\ref{symbolsection}). \end{itemize} \label{keywordsection} The following identifiers are syntactic keywords, and should not be used as variables: \begin{scheme} => do or and else quasiquote begin if quote case lambda set! cond let unquote define let* unquote-splicing delay letrec% \end{scheme} Some implementations allow all identifiers, including syntactic keywords, to be used as variables. This is a compatible extension to the language, but ambiguities in the language result when the restriction is relaxed, and the ways in which these ambiguities are resolved vary between implementations. \section{Whitespace and comments} \defining{Whitespace} characters are spaces and newlines. (Implementations typically provide additional whitespace characters such as tab or page break.) Whitespace is used for improved readability and as necessary to separate tokens from each other, a token being an indivisible lexical unit such as an identifier or number, but is otherwise insignificant. Whitespace may occur between any two tokens, but not within a token. Whitespace may also occur inside a string, where it is significant. A semicolon ({\tt;}) indicates the start of a comment.\mainindex{comment}\mainschindex{;} The comment continues to the end of the line on which the semicolon appears. Comments are invisible to Scheme, but the end of the line is visible as whitespace. This prevents a comment from appearing in the middle of an identifier or number. \begin{scheme} ;;; The FACT procedure computes the factorial ;;; of a non-negative integer. (define fact (lambda (n) (if (= n 0) 1 ;Base case: return 1 (* n (fact (- n 1))))))% \end{scheme} \section{Other notations} \todo{Rewrite?} For a description of the notations used for numbers, see section~\ref{numbersection}. \begin{description}{}{} \item[{\tt.\ + -}] These are used in numbers, and may also occur anywhere in an identifier except as the first character. A delimited plus or minus sign by itself is also an identifier. A delimited period (not occurring within a number or identifier) is used in the notation for pairs (section~\ref{listsection}), and to indicate a rest-parameter in a formal parameter list (section~\ref{lambda}). A delimited sequence of three successive periods is also an identifier. \item[\tt( )] Parentheses are used for grouping and to notate lists (section~\ref{listsection}). \item[\singlequote] The single quote character is used to indicate literal data (section~\ref{quote}). \item[\backquote] The backquote character is used to indicate almost-constant data (section~\ref{quasiquote}). \item[\tt, ,@] The character comma and the sequence comma at-sign are used in conjunction with backquote (section~\ref{quasiquote}). \item[\tt"] The double quote character is used to delimit strings (section~\ref{stringsection}). \item[\backwhack] Backslash is used in the syntax for character constants (section~\ref{charactersection}) and as an escape character within string constants (section~\ref{stringsection}). \setbox0\hbox{\tt \char"5B{} \char"5D{} \char"7B{} \char"7D} \item[\copy0] Left and right square brackets and curly braces are reserved for possible future extensions to the language. \item[\sharpsign] Sharp sign is used for a variety of purposes depending on the character that immediately follows it: \item[\schtrue{} \schfalse{}] These are the boolean constants (section~\ref{booleansection}). \item[\sharpsign\backwhack] This introduces a character constant (section~\ref{charactersection}). \item[\sharpsign\tt(] This introduces a vector constant (section~\ref{vectorsection}). Vector constants are terminated by~{\tt)}~. \item[{\tt\#e \#i \#b \#o \#d \#x}] These are used in the notation for numbers (section~\ref{numbernotations}). \end{description} scheme2c-2012.10.14/doc/r4rs/macros.tex000066400000000000000000001017701203736146400172540ustar00rootroot00000000000000\extrapart{Appendix: Macros} This appendix describes an extension to Scheme that allows programs to define and use new derived expression types. A derived expression type that has been defined using this extension is called a {\em macro}.\mainindex{macro} Derived expression types introduced using this extension have the syntax \begin{scheme} (\hyper{keyword} \arbno{\hyper{datum}})% \end{scheme}% where \hyper{keyword} is an identifier that uniquely determines the expression type. This identifier is called the {\em syntactic keyword}\index{syntactic keyword}, or simply {\em keyword}\index{keyword}, of the macro\index{macro keyword}. The number of the \hyper{datum}s, and their syntax, depends on the expression type. Each instance of a macro is called a {\em use}\index{macro use} of the macro. The set of rules, or more generally the procedure, that specifies how a use of a macro is transcribed into a more primitive expression is called the {\em transformer}\index{macro transformer} of the macro. The extension described here consists of three parts: \begin{itemize} \item A set of expressions used to establish that certain identifiers are macro keywords, associate them with macro transformers, and control the scope within which a macro is defined, \item a convenient pattern language that makes it easy to write transformers for most macros, and \item a compatible low-level macro facility for writing macro transformers that cannot be expressed by the pattern language. \end{itemize} With this extension, there are no reserved identifiers. The syntactic keyword of a macro may shadow variable bindings, and local variable bindings may shadow keyword bindings. \index{keyword} All macros defined using the pattern language are ``hygienic'' and ``referentially transparent'':\mainindex{hygienic} \mainindex{referentially transparent} \begin{itemize} \item If a macro transformer inserts a binding for an identifier (variable or keyword), the identifier will in effect be renamed throughout its scope to avoid conflicts with other identifiers. \item If a macro transformer inserts a free reference to an identifier, the reference refers to the binding that was visible where the transformer was specified, regardless of any local bindings that may surround the use of the macro. \end{itemize} %The low-level facility permits non-hygienic macros to be written, %and may be used to implement the high-level pattern language. This appendix is divided into three major sections. The first section describes the expressions and definitions used to introduce macros, i.e.~to bind identifiers to macro transformers. The second section describes the pattern language. This pattern language is sufficient to specify most macro transformers, including those for all the derived expression types from section~\ref{derivedexps}. The primary limitation of the pattern language is that it is thoroughly hygienic, and thus cannot express macros that bind identifiers implicitly. The third section describes a low-level macro facility that could be used to implement the pattern language described in the second section. This low-level facility is also capable of expressing non-hygienic macros and other macros whose transformers cannot be described by the pattern language, and is important as an example of a more powerful facility that can co-exist with the high-level pattern language. The particular low-level facility described in the third section is but one of several low-level facilities that have been designed and implemented to complement the pattern language described in the second section. The design of such low-level macro facilities remains an active area of research, and descriptions of alternative low-level facilities will be published in subsequent documents. % The fourth section describes some features that would make the % low-level macro facility easier to use directly. \subsection*{Binding syntactic keywords} \label{bindsyntax} {\cf Define-syntax}, {\cf let-syntax}, and {\cf letrec-syntax} are analogous to {\cf define}, {\cf let}, and {\cf letrec}, but they bind syntactic keywords to macro transformers instead of binding variables to locations that contain values. Furthermore, there is no {\cf define-syntax} analogue of the internal definitions described in section~\ref{internaldefines}. \begin{rationale} As discussed below, the syntax and scope rules for definitions give rise to syntactic ambiguities when syntactic keywords are not reserved. Further ambiguities would arise if {\cf define-syntax} were permitted at the beginning of a \meta{body}, with scope rules analogous to those for internal definitions. \end{rationale} These new expression types and the pattern language described in section~\ref{patternlanguage} are added to Scheme by augmenting the BNF in section~\ref{BNF} with the following new productions. Note that the identifier {\cf ...} used in some of these productions is not a metasymbol. \begin{grammar}% \meta{expression} \: \meta{macro use} \> \| \meta{macro block} \meta{macro use} \: (\meta{keyword} \arbno{\meta{datum}}) \meta{keyword} \: \meta{identifier} \meta{macro block} \: \> \> (let-syntax (\arbno{\meta{syntax spec}}) \meta{body}) \> \| (letrec-syntax (\arbno{\meta{syntax spec}}) \meta{body}) \meta{syntax spec} \: (\meta{keyword} \meta{transformer spec}) \meta{transformer spec} \: \> \> (syntax-rules (\arbno{\meta{identifier}}) \arbno{\meta{syntax rule}}) \meta{syntax rule} \: (\meta{pattern} \meta{template}) \meta{pattern} \: \meta{pattern identifier} \> \| (\arbno{\meta{pattern}}) \> \| (\atleastone{\meta{pattern}} . \meta{pattern}) \> \| (\arbno{\meta{pattern}} \meta{pattern} \meta{ellipsis}) \> \| \meta{pattern datum} \meta{pattern datum} \: \meta{vector} \> \| \meta{string} \> \| \meta{character} \> \| \meta{boolean} \> \| \meta{number} \meta{template} \: \meta{pattern identifier} \> \| (\arbno{\meta{template element}}) \> \| (\atleastone{\meta{template element}} . \meta{template}) \> \| \meta{template datum} \meta{template element} \: \meta{template} \> \| \meta{template} \meta{ellipsis} \meta{template datum} \: \meta{pattern datum} \meta{pattern identifier} \: \meta{any identifier except {\cf ...}} \meta{ellipsis} \: \meta{the identifier {\cf ...}} \meta{command or definition} \: \meta{syntax definition} \meta{syntax definition} \: \> \> (define-syntax \meta{keyword} \meta{transformer spec}) \> \| (begin \arbno{\meta{syntax definition}})% \end{grammar} % It is an error for a program to contain more than one top-level % \meta{definition} or \meta{syntax definition} of any identifier. % % [I flushed this because it isn't an error for a program to % contain more than one top-level definition of an identifier, % and I didn't want to introduce any gratuitous incompatibilities % with the existing Scheme language. -- Will] Although macros may expand into definitions in any context that permits definitions, it is an error for a definition to shadow a syntactic keyword whose meaning is needed to determine whether some definition in the group of top-level or internal definitions that contains the shadowing definition is in fact a definition, or is needed to determine the boundary between the group and the expressions that follow the group. For example, the following are errors: \begin{scheme} (define define 3) (begin (define begin list)) (let-syntax ((foo (syntax-rules () ((foo (proc args ...) body ...) (define proc (lambda (args ...) body ...)))))) (let ((x 3)) (foo (plus x y) (+ x y)) (define foo x) (plus foo x))) \end{scheme} \begin{entry}{% \proto{let-syntax}{ \hyper{bindings} \hyper{body}}{\exprtype}} \syntax \hyper{Bindings} should have the form \begin{scheme} ((\hyper{keyword} \hyper{transformer spec}) \dotsfoo)% \end{scheme} %where each \hyper{keyword} is an identifier, %each \hyper{transformer spec} is an instance of {\cf syntax-rules}, and Each \hyper{keyword} is an identifier, each \hyper{transformer spec} is an instance of {\cf syntax-rules}, and \hyper{body} should be a sequence of one or more expressions. It is an error for a \hyper{keyword} to appear more than once in the list of keywords being bound. \semantics The \hyper{body} is expanded in the syntactic environment obtained by extending the syntactic environment of the {\cf let-syntax} expression with macros whose keywords are the \hyper{keyword}s, bound to the specified transformers. Each binding of a \hyper{keyword} has \hyper{body} as its region. \begin{scheme} (let-syntax ((when (syntax-rules () ((when test stmt1 stmt2 ...) (if test (begin stmt1 stmt2 ...)))))) (let ((if \schtrue)) (when if (set! if 'now)) if)) \ev now (let ((x 'outer)) (let-syntax ((m (syntax-rules () ((m) x)))) (let ((x 'inner)) (m)))) \ev outer% \end{scheme} \end{entry} \begin{entry}{% \proto{letrec-syntax}{ \hyper{bindings} \hyper{body}}{\exprtype}} \syntax Same as for {\cf let-syntax}. \semantics The \hyper{body} is expanded in the syntactic environment obtained by extending the syntactic environment of the {\cf letrec-syntax} expression with macros whose keywords are the \hyper{keyword}s, bound to the specified transformers. Each binding of a \hyper{keyword} has the \hyper{bindings} as well as the \hyper{body} within its region, so the transformers can transcribe expressions into uses of the macros introduced by the {\cf letrec-syntax} expression. \begin{scheme} (letrec-syntax ((or (syntax-rules () ((or) \schfalse) ((or e) e) ((or e1 e2 ...) (let ((temp e1)) (if temp temp (or e2 ...))))))) (let ((x \schfalse) (y 7) (temp 8) (let odd?) (if even?)) (or x (let temp) (if y) y))) \ev 7% \end{scheme} \end{entry} \begin{entry}{% \proto{define-syntax}{ \hyper{keyword} \hyper{transformer spec}}{}} \syntax The \hyper{keyword} is an identifier, and the \hyper{transformer spec} should be an instance of {\cf syntax-rules}. \semantics The top-level syntactic environment is extended by binding the \hyper{keyword} to the specified transformer. \begin{scheme} (define-syntax let* (syntax-rules () ((let* () body1 body2 ...) (let () body1 body2 ...)) ((let* ((name1 val1) (name2 val2) ...) body1 body2 ...) (let ((name1 val1)) (let* ((name2 val2) ...) body1 body2 ...))))) \end{scheme} \end{entry} \subsection*{Pattern language} \label{patternlanguage} \begin{entry}{% \proto{syntax-rules}{ \hyper{literals} \hyper{syntax rule} \dotsfoo}{}} \syntax \hyper{Literals} is a list of identifiers, and each \hyper{syntax rule} should be of the form \begin{scheme} (\hyper{pattern} \hyper{template})% \end{scheme} where the \hyper{pattern} and \hyper{template} are as in the grammar above. \semantics An instance of {\cf syntax-rules} produces a new macro transformer by specifying a sequence of hygienic rewrite rules. A use of a macro whose keyword is associated with a transformer specified by {\cf syntax-rules} is matched against the patterns contained in the \hyper{syntax rule}s, beginning with the leftmost \hyper{syntax rule}. When a match is found, the macro use is transcribed hygienically according to the template. Each pattern begins with the keyword for the macro. This keyword is not involved in the matching and is not considered a pattern variable or literal identifier. \begin{rationale} The scope of the keyword is determined by the expression or syntax definition that binds it to the associated macro transformer. If the keyword were a pattern variable or literal identifier, then the template that follows the pattern would be within its scope regardless of whether the keyword were bound by {\cf let-syntax} or by {\cf letrec-syntax}. \end{rationale} An identifier that appears in the pattern of a \hyper{syntax rule} is a pattern variable, unless it is the keyword that begins the pattern, is listed in \hyper{literals}, or is the identifier ``{\cf ...}''. Pattern variables match arbitrary input elements and are used to refer to elements of the input in the template. It is an error for the same pattern variable to appear more than once in a \hyper{pattern}. Identifiers that appear in \hyper{literals} are interpreted as literal identifiers to be matched against corresponding subforms of the input. A subform in the input matches a literal identifier if and only if it is an identifier and either both its occurrence in the macro expression and its occurrence in the macro definition have the same lexical binding, or the two identifiers are equal and both have no lexical binding. % [Bill Rozas suggested the term "noise word" for these literal % identifiers, but in their most interesting uses, such as a setf % macro, they aren't noise words at all. -- Will] A subpattern followed by {\cf ...} can match zero or more elements of the input. It is an error for {\cf ...} to appear in \hyper{literals}. Within a pattern the identifier {\cf ...} must follow the last element of a nonempty sequence of subpatterns. More formally, an input form $F$ matches a pattern $P$ if and only if: \begin{itemize} \item $P$ is a pattern variable; or \item $P$ is a literal identifier and $F$ is an identifier with the same binding; or \item $P$ is a pattern list {\cf ($P_1$ $\dots$ $P_n$)} and $F$ is a list of $n$ forms that match $P_1$ through $P_n$, respectively; or \item $P$ is an improper pattern list {\cf ($P_1$ $P_2$ $\dots$ $P_n$ . $P_{n+1}$)} and $F$ is a list or improper list of $n$ or more forms that match $P_1$ through $P_n$, respectively, and whose $n$th ``cdr'' matches $P_{n+1}$; or \item $P$ is % a pattern list of the form {\cf ($P_1$ $\dots$ $P_n$ $P_{n+1}$ \meta{ellipsis})} where \meta{ellipsis} is the identifier {\cf ...} and $F$ is a proper list of at least $n$ elements, the first $n$ of which match $P_1$ through $P_n$, respectively, and each remaining element of $F$ matches $P_{n+1}$; or \item $P$ is a pattern datum and $F$ is equal to $P$ in the sense of the {\cf equal?} procedure. \end{itemize} It is an error to use a macro keyword, within the scope of its binding, in an expression that does not match any of the patterns. When a macro use is transcribed according to the template of the matching \hyper{syntax rule}, pattern variables that occur in the template are replaced by the subforms they match in the input. Pattern variables that occur in subpatterns followed by one or more instances of the identifier {\cf ...} are allowed only in subtemplates that are followed by as many instances of {\cf ...}. They are replaced in the output by all of the subforms they match in the input, distributed as indicated. It is an error if the output cannot be built up as specified. %%% This description of output construction is very vague. It should %%% probably be formalized, but that is not easy... Identifiers that appear in the template but are not pattern variables or the identifier {\cf ...} are inserted into the output as literal identifiers. If a literal identifier is inserted as a free identifier then it refers to the binding of that identifier within whose scope the instance of {\cf syntax-rules} appears. If a literal identifier is inserted as a bound identifier then it is in effect renamed to prevent inadvertent captures of free identifiers. \begin{scheme} (define-syntax let (syntax-rules () ((let ((name val) ...) body1 body2 ...) ((lambda (name ...) body1 body2 ...) val ...)) ((let tag ((name val) ...) body1 body2 ...) ((letrec ((tag (lambda (name ...) body1 body2 ...))) tag) val ...)))) (define-syntax cond (syntax-rules (else =>) ((cond (else result1 result2 ...)) (begin result1 result2 ...)) ((cond (test => result)) (let ((temp test)) (if temp (result temp)))) ((cond (test => result) clause1 clause2 ...) (let ((temp test)) (if temp (result temp) (cond clause1 clause2 ...)))) ((cond (test)) test) ((cond (test) clause1 clause2 ...) (or test (cond clause1 clause2 ...))) ((cond (test result1 result2 ...)) (if test (begin result1 result2 ...))) ((cond (test result1 result2 ...) clause1 clause2 ...) (if test (begin result1 result2 ...) (cond clause1 clause2 ...))))) (let ((=> \schfalse)) (cond (\schtrue => 'ok))) \ev ok% \end{scheme} The last example is not an error because the local variable {\cf =>} is renamed in effect, so that its use is distinct from uses of the top level identifier {\cf =>} that the transformer for {\cf cond} looks for. Thus, rather than expanding into \begin{scheme} (let ((=> \schfalse)) (let ((temp \schtrue)) (if temp ('ok temp))))% \end{scheme} which would result in an invalid procedure call, it expands instead into \begin{scheme} (let ((=> \schfalse)) (if \schtrue (begin => 'ok)))% \end{scheme} \end{entry} \subsection*{A compatible low-level macro facility} \label{lowlevelmacros} Although the pattern language provided by {\cf syntax-rules} is the preferred way to specify macro transformers, other low-level facilities may be provided to specify more complex macro transformers. In fact, {\cf syntax-rules} can itself be defined as a macro using the low-level facilities described in this section. The low-level macro facility described here introduces {\cf syntax} as a new syntactic keyword analogous to {\cf quote}, and allows a \meta{transformer spec} to be any expression. This is accomplished by adding the following two productions to the productions in section~\ref{BNF} and in section~\ref{bindsyntax} above. \begin{grammar}% \meta{expression} \: (syntax \hyper{datum}) \meta{transformer spec} \: \meta{expression}% \end{grammar} The low-level macro system also adds the following procedures: \begin{scheme} unwrap-syntax identifier->symbol identifier? generate-identifier free-identifier=? construct-identifier bound-identifier=? \end{scheme} Evaluation of a program proceeds in two logical steps. First the program is converted into an intermediate language via macro-expansion, and then the result of macro expansion is evaluated. When it is necessary to distinguish the second stage of this process from the full evaluation process, it is referred to as ``execution.'' Syntax definitions, either lexical or global, cause an identifier to be treated as a keyword within the scope of the binding. The keyword is associated with a transformer, which may be created implicitly using the pattern language of {\cf syntax-rules} or explicitly using the low-level facilities described below. Since a transformer spec must be fully evaluated during the course of expansion, it is necessary to specify the environment in which this evaluation takes place. A transformer spec is expanded in the same environment as that in which the program is being expanded, but is executed in an environment that is distinct from the environment in which the program is executed. This execution environment distinction is important only for the resolution of global variable references and assignments. In what follows, the environment in which transformers are executed is called the standard transformer environment and is assumed to be a standard Scheme environment. Since part of the task of hygienic macro expansion is to resolve identifier references, the fact that transformers are expanded in the same environment as the program means that identifier bindings in the program can shadow identifier uses within transformers. Since variable bindings in the program are not available at the time the transformer is executed, it is an error for a transformer to reference or assign them. However, since keyword bindings are available during expansion, lexically visible keyword bindings from the program may be used in macro uses in a transformer. When a macro use is encountered, the macro transformer associated with the macro keyword is applied to a representation of the macro expression. The result returned by the macro transformer replaces the original expression and is expanded once again. Thus macro expansions may themselves be or contain macro uses. The syntactic representation passed to a macro transformer encapsulates information about the structure of the represented form and the bindings of the identifiers it contains. These syntax objects can be traversed and examined using the procedures described below. The output of a transformer may be built up using the usual Scheme list constructors, combining pieces of the input with new syntactic structures. \begin{entry}{% \proto{syntax}{ \hyper{datum}}{\exprtype}} \syntax The \hyper{datum} may be any external representation of a Scheme object. \semantics {\cf Syntax} is the syntactic analogue of {\cf quote}. It creates a syntactic representation of \hyper{datum} that, like an argument to a transformer, contains information about the bindings for identifiers contained in \hyper{datum}. The binding for an identifier introduced by {\cf syntax} is the closest lexically visible binding. All variables and keywords introduced by transformers must be created by {\cf syntax}. It is an error to insert a symbol in the output of a transformation procedure unless it is to be part of a quoted datum. \begin{scheme} (symbol? (syntax x)) \ev \schfalse% (let-syntax ((car (lambda (x) (syntax car)))) ((car) '(0))) \ev 0% (let-syntax ((quote-quote (lambda (x) (list (syntax quote) 'quote)))) (quote-quote)) \ev quote% (let-syntax ((quote-quote (lambda (x) (list 'quote 'quote)))) (quote-quote)) \ev \scherror% \end{scheme} The second {\cf quote-quote} example results in an error because two raw symbols are being inserted in the output. The quoted {\cf quote} in the first {\cf quote-quote} example does not cause an error because it will be a quoted datum. \begin{scheme} (let-syntax ((quote-me (lambda (x) (list (syntax quote) x)))) (quote-me please)) \ev (quote-me please) (let ((x 0)) (let-syntax ((alpha (lambda (e) (syntax x)))) (alpha))) \ev 0 (let ((x 0)) (let-syntax ((alpha (lambda (x) (syntax x)))) (alpha))) \ev \scherror (let-syntax ((alpha (let-syntax ((beta (syntax-rules () ((beta) 0)))) (lambda (x) (syntax (beta)))))) (alpha)) \ev \scherror% \end{scheme} The last two examples are errors because in both cases a lexically bound identifier is placed outside of the scope of its binding. In the first case, the variable {\cf x} is placed outside its scope. In the second case, the keyword {\cf beta} is placed outside its scope. \begin{scheme} (let-syntax ((alpha (syntax-rules () ((alpha) 0)))) (let-syntax ((beta (lambda (x) (alpha)))) (beta))) \ev 0 (let ((list 0)) (let-syntax ((alpha (lambda (x) (list 0)))) (alpha))) \ev \scherror% \end{scheme} The last example is an error because the reference to {\cf list} in the transformer is shadowed by the lexical binding for {\cf list}. Since the expansion process is distinct from the execution of the program, transformers cannot reference program variables. On the other hand, the previous example is not an error because definitions for keywords in the program do exist at expansion time. \begin{note} It has been suggested that {\cf \#'\hyper{datum}} and {\cf \#`\hyper{datum}} would be felicitous abbreviations for {\cf (syntax \hyper{datum})} and {\cf (quasisyntax \hyper{datum})}, respectively, where {\cf quasisyntax}, which is not described in this appendix, would bear the same relationship to {\cf syntax} that {\cf quasiquote} bears to {\cf quote}. \end{note} \end{entry} \begin{entry}{% \proto{identifier?}{ syntax-object}{procedure}} Returns \schtrue{} if \var{syntax-object} represents an identifier, otherwise returns \schfalse{}. \begin{scheme} (identifier? (syntax x)) \ev \schtrue (identifier? (quote x)) \ev \schfalse (identifier? 3) \ev \schfalse% \end{scheme} \end{entry} \begin{entry}{% \proto{unwrap-syntax}{ syntax-object}{procedure}} If \var{syntax-object} is an identifier, then it is returned unchanged. Otherwise {\cf unwrap-syntax} converts the outermost structure of \var{syntax-object} into a data object whose external representation is the same as that of \var{syntax-object}. The result is either an identifier, a pair whose car and cdr are syntax objects, a vector whose elements are syntax objects, an empty list, a string, a boolean, a character, or a number. \begin{scheme} (identifier? (unwrap-syntax (syntax x))) \ev \schtrue (identifier? (car (unwrap-syntax (syntax (x))))) \ev \schtrue (unwrap-syntax (cdr (unwrap-syntax (syntax (x))))) \ev ()% \end{scheme} \end{entry} \begin{entry}{% \proto{free-identifier=?}{ \vari{id} \varii{id}}{procedure}} Returns \schtrue{} if the original occurrences of \vari{id} and \varii{id} have the same binding, otherwise returns \schfalse. {\cf free-identifier=?} is used to look for a literal identifier in the argument to a transformer, such as {\cf else} in a {\cf cond} clause. A macro definition for {\cf syntax-rules} would use {\cf free-identifier=?} to look for literals in the input. \begin{scheme} (free-identifier=? (syntax x) (syntax x)) \ev \schtrue (free-identifier=? (syntax x) (syntax y)) \ev \schfalse (let ((x (syntax x))) (free-identifier=? x (syntax x))) \ev \schfalse (let-syntax ((alpha (lambda (x) (free-identifier=? (car (unwrap-syntax x)) (syntax alpha))))) (alpha)) \ev \schfalse (letrec-syntax ((alpha (lambda (x) (free-identifier=? (car (unwrap-syntax x)) (syntax alpha))))) (alpha)) \ev \schtrue% \end{scheme} \end{entry} \begin{entry}{% \proto{bound-identifier=?}{ \vari{id} \varii{id}}{procedure}} Returns \schtrue{} if a binding for one of the two identifiers \vari{id} and \varii{id} would shadow free references to the other, otherwise returns \schfalse{}. Two identifiers can be {\cf free-identifier=?} without being {\cf bound-identifier=?} if they were introduced at different stages in the expansion process. {\cf Bound-identifier=?} can be used, for example, to detect duplicate identifiers in bound-variable lists. A macro definition of {\cf syntax-rules} would use {\cf bound-identifier=?} to look for pattern variables from the input pattern in the output template. \begin{scheme} (bound-identifier=? (syntax x) (syntax x)) \ev \schtrue (letrec-syntax ((alpha (lambda (x) (bound-identifier=? (car (unwrap-syntax x)) (syntax alpha))))) (alpha)) \ev \schfalse% \end{scheme} \end{entry} \begin{entry}{% \proto{identifier->symbol}{ \var{id}}{procedure}} Returns a symbol representing the original name of \var{id}. {\cf Identifier->symbol} is used to examine identifiers that appear in literal contexts, i.e., identifiers that will appear in quoted structures. \begin{scheme} (symbol? (identifier->symbol (syntax x))) \ev \schtrue (identifier->symbol (syntax x)) \ev x% \end{scheme} \end{entry} \begin{entry}{% \proto{generate-identifier}{}{procedure} \proto{generate-identifier}{ \var{symbol}}{procedure}} Returns a new identifier. The optional argument to {\cf generate-identifier} specifies the symbolic name of the resulting identifier. If no argument is supplied the name is unspecified. {\cf Generate-identifier} is used to introduce bound identifiers into the output of a transformer. Since introduced bound identifiers are automatically renamed, {\cf generate-identifier} is necessary only for distinguishing introduced identifiers when an indefinite number of them must be generated by a macro. The optional argument to {\cf generate-identifier} specifies the symbolic name of the resulting identifier. If no argument is supplied the name is unspecified. The procedure {\cf identifier->symbol} reveals the symbolic name of an identifier. \begin{scheme} (identifier->symbol (generate-identifier 'x)) \ev x (bound-identifier=? (generate-identifier 'x) (generate-identifier 'x)) \ev \schfalse (define-syntax set*! ; (set*! ( ) ...) (lambda (x) (letrec ((unwrap-exp (lambda (x) (let ((x (unwrap-syntax x))) (if (pair? x) (cons (car x) (unwrap-exp (cdr x))) x))))) (let ((sets (map unwrap-exp (cdr (unwrap-exp x))))) (let ((ids (map car sets)) (vals (map cadr sets)) (temps (map (lambda (x) (generate-identifier)) sets))) `(,(syntax let) ,(map list temps vals) ,@(map (lambda (id temp) `(,(syntax set!) ,id ,temp)) ids temps) \schfalse)))))) \end{scheme} \end{entry} \begin{entry}{% \proto{construct-identifier}{ \var{id} \var{symbol}}{procedure}} Creates and returns an identifier named by \var{symbol} that behaves as if it had been introduced where the identifier \var{id} was introduced. {\cf Construct-identifier} is used to circumvent hygiene by creating an identifier that behaves as though it had been implicitly present in some expression. For example, the transformer for a structure definition macro might construct the name of a field accessor that does not explicitly appear in a use of the macro, but can be constructed from the names of the structure and the field. If a binding for the field accessor were introduced by a hygienic transformer, then it would be renamed automatically, so that the introduced binding would fail to capture any references to the field accessor that were present in the input and were intended to be within the scope of the introduced binding. Another example is a macro that implicitly binds {\cf exit}: \begin{scheme} (define-syntax loop-until-exit (lambda (x) (let ((exit (construct-identifier (car (unwrap-syntax x)) 'exit)) (body (car (unwrap-syntax (cdr (unwrap-syntax x)))))) `(,(syntax call-with-current-continuation) (,(syntax lambda) (,exit) (,(syntax letrec) ((,(syntax loop) (,(syntax lambda) () ,body (,(syntax loop))))) (,(syntax loop)))))))) (let ((x 0) (y 1000)) (loop-until-exit (if (positive? y) (begin (set! x (+ x 3)) (set! y (- y 1))) (exit x)))) \evalsto 3000 \end{scheme} \end{entry} \subsection*{Acknowledgements} The extension described in this appendix is the most sophisticated macro facility that has ever been proposed for a block-structured programming language. The main ideas come from Eugene Kohlbecker's PhD thesis on hygienic macro expansion \cite{Kohlbecker86}, written under the direction of Dan Friedman \cite{hygienic}, and from the work by Alan Bawden and Jonathan Rees on syntactic closures \cite{Bawden88}. Pattern-directed macro facilities were popularized by Kent Dybvig's non-hygienic implementation of {\cf extend-syntax} \cite{Dybvig87}. At the 1988 meeting of this report's authors at Snowbird, a macro committee consisting of Bawden, Rees, Dybvig, and Bob Hieb was charged with developing a hygienic macro facility akin to {\cf extend-syntax} but based on syntactic closures. Chris Hanson implemented a prototype and wrote a paper on his experience, pointing out that an implementation based on syntactic closures must determine the syntactic roles of some identifiers before macro expansion based on textual pattern matching can make those roles apparent. William Clinger observed that Kohlbecker's algorithm amounts to a technique for delaying this determination, and proposed a more efficient version of Kohlbecker's algorithm. Pavel Curtis spoke up for referentially transparent local macros. Rees merged syntactic environments with the modified Kohlbecker's algorithm and implemented it all, twice \cite{macrosthatwork}. Dybvig and Hieb designed and implemented the low-level macro facility described above. Recently Hanson and Bawden have extended syntactic closures to obtain an alternative low-level macro facility. The macro committee has not endorsed any particular low-level facility, but does endorse the general concept of a low-level facility that is compatible with the high-level pattern language described in this appendix. Several other people have contributed by working on macros over the years. Hal Abelson contributed by holding this report hostage to the appendix on macros. scheme2c-2012.10.14/doc/r4rs/notes.tex000066400000000000000000000153071203736146400171200ustar00rootroot00000000000000\extrapart{Notes} \todo{Perhaps this section should be made to disappear. Can these remarks be moved somewhere else?} \subsection*{Language changes} \label{differences} This section enumerates the changes that have been made to Scheme since the ``Revised$^3$ report''~\cite{R3RS} was published. \begin{itemize} \item Although implementations may extend Scheme, they must offer a syntactic mode that adds no reserved words and preempts no lexical conventions of Scheme. \item Implementations may report violations of implementation restrictions. \item It is no longer specified whether the empty list counts as true or as false in conditional expressions. It should be noted that the IEEE standard for Scheme requires the empty list to count as true \cite{IEEEScheme}. \item The sets defined by \ide{boolean?}, \ide{pair?}, \ide{symbol?}, \ide{number?}, \ide{char?}, \ide{string?}, \ide{vector?}, and \ide{procedure?} are required to be disjoint. \item The variables bound by a \ide{lambda}, \ide{let}, \ide{letrec}, and \ide{do} must not contain duplicates. \item Nested \ide{begin} expressions containing definitions are treated as a sequence of definitions. \item The \ide{eqv?} procedure is no longer required to be true of any two empty strings or two empty vectors. \item The syntax of numerical constants has been changed, and the exactness implied by each syntax has been specified. \item The semantics of many numerical procedures have been clarified. \item \ide{Rationalize} has been restricted to two arguments and its specification clarified. \item The \ide{number->string} and \ide{string->number} procedures have been changed. \item \ide{Integer->char} now requires an exact integer argument. \item The specification of the \ide{force} procedure has been weakened. The previous specification was unimplementable. \item Variables removed: \ide{t}, \ide{nil}. \item Procedures removed: \ide{approximate}, \ide{last-pair}. \item Procedures added: \ide{list?}, \ide{peek-char}. \item Syntaxes made essential: \ide{case}, \ide{and}, \ide{or}, \ide{quasiquote}. \item Procedures made essential: \end{itemize} % so the next block isn't indented \begin{scheme} reverse char-ci=? make-string max char-ci? string-ci=? modulo char-ci<=? string-ci=? string-ci>? lcm char-alphabetic? string-ci<=? floor char-numeric? string-ci>=? ceiling char-whitespace? string-append truncate char-lower-case? open-input-file round char-upper-case? open-output-file number->string char-upcase close-input-port string->number char-downcase close-output-port \end{scheme} \begin{itemize} % continue with the last item \item Procedures required to accept more general numbers of arguments: \ide{append}, \ide{+}, \ide{*}, \ide{-} (one argument), \ide{/} (one argument), \ide{=}, \ide{<}, \ide{>}, \ide{<=}, \ide{>=}, \ide{map}, \ide{for-each}. \item A macro facility has been added as an appendix to this report. \todo{ \item {\tt Call-with-input-file} and {\tt call-with-output-file} renamed to \ide{call-with-input-port} and \ide{call-with-output-port} } \end{itemize} \todo{ \subsection*{Comparison with the dialect used in~\cite{SICP}} Compare with S\&ICP: simple renamings like {\tt print}; easily implemented things like {\tt cons-stream}; more grave and controversial omissions like {\tt eval} and {\tt make-envi\-ron\-ment}.} % I think the comparison with S&ICP is no longer so important. % A comparison with IEEE Scheme might now be in order, though. % -- Will, 1991. %%R4%% %\subsection*{Keywords as variable names} % %Some implementations allow arbitrary syntactic %keywords \index{keyword}\index{syntactic keyword}to be used as variable %names, instead of reserving them, as this report would have %it.\index{variable} But this creates ambiguities in the interpretation %of expressions: for example, in the following, it's not clear whether %the expression {\tt (if 1 2 3)} should be treated as a procedure call or %as a conditional. % %\begin{scheme} %(define if list) %(if 1 2 3) \ev 2 {\em{}or} (1 2 3)% %\end{scheme} % %These ambiguities are usually resolved in some consistent way within any %given implementation, but no particular treatment stands out as being %clearly superior to any other, so these situations were excluded for the %purposes of this report. %%R4%% %\subsection*{Macros} % %Scheme does not have any standard facility for defining new kinds of %expressions.\index{macros} % %\vest The ability to alter the syntax of the language creates %numerous problems. All current implementations of Scheme have macro %facilities that solve those problems to one degree or another, but the %solutions are quite different and it isn't clear at this time which %solution is best, or indeed whether any of the solutions are truly %adequate. Rather than standardize, we are encouraging implementations %to continue to experiment with different solutions. % %\vest The main problems with traditional macros are: They must be %defined to the system before any code using them is loaded; this is a %common source of obscure bugs. They are usually global; macros can be %made to follow lexical scope rules \todo{flushed: ``as in Common %Lisp's {\tt macrolet}''; OK?}, but many people find the resulting scope rules %confusing. Unless they are written very carefully, macros are %vulnerable to inadvertant capture of free variables; to get around this, %for example, macros may have to generate code in which procedure values %appear as quoted constants. There is a similar problem with syntactic %keywords if the keywords of special forms are not reserved. If keywords %are reserved, then either macros introduce new reserved words, %invalidating old code, or else special forms defined by the programmer %do not have the same status as special forms defined by the system. % %\todo{Refer to Pitman's special forms paper.} %\todo{Pitman sez: Discuss importance of having a small number of special forms %so that programs can inspect each other.} \todo{Move cwcc history back here? --- Andy Cromarty is concerned about confusion over who the audience is.} \todo{Cromarty: 23. NOTES, p.35ff.: This material should stay somehow. We need to make it clear that R$^3$ Scheme is not being touted as Yet Another Ultimate Solution To The Programming Language Problem, but rather as a snapshot of a *process* of good design, for which not all answers have yet been found. We also ought to use the opportunity for publicity afforded us by SIGPLAN to advertise some of the thorny unsolved problems that need further research, and encourage language designers to work on them.} scheme2c-2012.10.14/doc/r4rs/procs.tex000066400000000000000000003305201203736146400171130ustar00rootroot00000000000000% Initial environment %\vfill\eject \chapter{Standard procedures} \label{initialenv} \label{builtinchapter} \mainindex{initial environment} \mainindex{top level environment} This chapter describes Scheme's built-in procedures. The initial (or ``top level'') Scheme environment starts out with a number of variables bound to locations containing useful values, most of which are primitive procedures that manipulate data. For example, the variable \ide{abs} is bound to (a location initially containing) a procedure of one argument that computes the absolute value of a number, and the variable \ide{+} is bound to a procedure that computes sums. \section{Booleans} \label{booleansection} The standard boolean objects for true and false are written as \schtrue{} and \schfalse.\sharpindex{t}\sharpindex{f} What really matters, though, are the objects that the Scheme conditional expressions (\ide{if}, \ide{cond}, \ide{and}, \ide{or}, \ide{do}) treat as true\index{true} or false\index{false}. The phrase ``a true value''\index{true} (or sometimes just ``true'') means any object treated as true by the conditional expressions, and the phrase ``a false value''\index{false} (or ``false'') means any object treated as false by the conditional expressions. \vest Of all the standard Scheme values, only \schfalse{} % is guaranteed to count counts as false in conditional expressions. % It is not % specified whether the empty list\index{empty list} counts as false % or as true in conditional expressions. Except for \schfalse{}, % and possibly the empty list, all standard Scheme values, including \schtrue, pairs, the empty list, symbols, numbers, strings, vectors, and procedures, count as true. \begin{note} In some implementations the empty list counts as false, contrary to the above. Nonetheless a few examples in this report assume that the empty list counts as true, as in \cite{IEEEScheme}. \end{note} % \begin{rationale} % For historical reasons some implementations regard \schfalse{} and the % empty list as the same object. These implementations therefore cannot % make the empty list count as true in conditional expressions. % \end{rationale} \begin{note} Programmers accustomed to other dialects of Lisp should be aware that Scheme distinguishes both \schfalse{} and the empty list from the symbol \ide{nil}. \end{note} \vest Boolean constants evaluate to themselves, so they don't need to be quoted in programs. \begin{scheme} \schtrue \ev \schtrue \schfalse \ev \schfalse '\schfalse \ev \schfalse% \end{scheme} \begin{entry}{% \proto{not}{ obj}{essential procedure}} \ide{Not} returns \schtrue{} if \var{obj} is false, and returns \schfalse{} otherwise. \begin{scheme} (not \schtrue) \ev \schfalse (not 3) \ev \schfalse (not (list 3)) \ev \schfalse (not \schfalse) \ev \schtrue (not '()) \ev \schfalse (not (list)) \ev \schfalse (not 'nil) \ev \schfalse% \end{scheme} \end{entry} \begin{entry}{% \proto{boolean?}{ obj}{essential procedure}} \ide{Boolean?} returns \schtrue{} if \var{obj} is either \schtrue{} or \schfalse{} and returns \schfalse{} otherwise. \begin{scheme} (boolean? \schfalse) \ev \schtrue (boolean? 0) \ev \schfalse (boolean? '()) \ev \schfalse% \end{scheme} \end{entry} \section{Equivalence predicates} \label{equivalencesection} A \defining{predicate} is a procedure that always returns a boolean value (\schtrue{} or \schfalse). An \defining{equivalence predicate} is the computational analogue of a mathematical equivalence relation (it is symmetric, reflexive, and transitive). Of the equivalence predicates described in this section, \ide{eq?}\ is the finest or most discriminating, and \ide{equal?}\ is the coarsest. \ide{Eqv?}\ is slightly less discriminating than \ide{eq?}. \todo{Pitman doesn't like this paragraph. Lift the discussion from the Maclisp manual. Explain why there's more than one predicate.} \begin{entry}{% \proto{eqv?}{ \vari{obj} \varii{obj}}{essential procedure}} The \ide{eqv?} procedure defines a useful equivalence relation on objects. Briefly, it returns \schtrue{} if \vari{obj} and \varii{obj} should normally be regarded as the same object. This relation is left slightly open to interpretation, but the following partial specification of \ide{eqv?} holds for all implementations of Scheme. The \ide{eqv?} procedure returns \schtrue{} if: \begin{itemize} \item \vari{obj} and \varii{obj} are both \schtrue{} or both \schfalse. \item \vari{obj} and \varii{obj} are both symbols and \begin{scheme} (string=? (symbol->string obj1) (symbol->string obj2)) \ev \schtrue% \end{scheme} \begin{note} This assumes that neither \vari{obj} nor \varii{obj} is an ``uninterned symbol'' as alluded to in section~\ref{symbolsection}. This report does not presume to specify the behavior of \ide{eqv?} on implementation-dependent extensions. \end{note} \item \vari{obj} and \varii{obj} are both numbers, are numerically equal (see \ide{=}, section~\ref{numbersection}), and are either both exact\index{exact} or both inexact\index{inexact}. \item \vari{obj} and \varii{obj} are both characters and are the same character according to the \ide{char=?} procedure (section~\ref{charactersection}). \item both \vari{obj} and \varii{obj} are the empty list. \item \vari{obj} and \varii{obj} are pairs, vectors, or strings that denote the same locations in the store (section~\ref{storagemodel}). \item \vari{obj} and \varii{obj} are procedures whose location tags are equal (section~\ref{lambda}). \end{itemize} The \ide{eqv?} procedure returns \schfalse{} if: \begin{itemize} \item \vari{obj} and \varii{obj} are of different types (section~\ref{disjointness}). \item one of \vari{obj} and \varii{obj} is \schtrue{} but the other is \schfalse{}. \item \vari{obj} and \varii{obj} are symbols but \begin{scheme} (string=? (symbol->string \vari{obj}) (symbol->string \varii{obj})) \ev \schfalse% \end{scheme} \item one of \vari{obj} and \varii{obj} is an exact number but the other is an inexact number. \item \vari{obj} and \varii{obj} are numbers for which the \ide{=} procedure returns \schfalse{}. \item \vari{obj} and \varii{obj} are characters for which the \ide{char=?} procedure returns \schfalse{}. \item one of \vari{obj} and \varii{obj} is the empty list but the other is not. \item \vari{obj} and \varii{obj} are pairs, vectors, or strings that denote distinct locations. \item \vari{obj} and \varii{obj} are procedures that would behave differently (return a different value or have different side effects) for some arguments. \end{itemize} \begin{scheme} (eqv? 'a 'a) \ev \schtrue (eqv? 'a 'b) \ev \schfalse (eqv? 2 2) \ev \schtrue (eqv? '() '()) \ev \schtrue (eqv? 100000000 100000000) \ev \schtrue (eqv? (cons 1 2) (cons 1 2)) \ev \schfalse (eqv? (lambda () 1) (lambda () 2)) \ev \schfalse (eqv? \#f 'nil) \ev \schfalse (let ((p (lambda (x) x))) (eqv? p p)) \ev \schtrue% \end{scheme} The following examples illustrate cases in which the above rules do not fully specify the behavior of \ide{eqv?}. All that can be said about such cases is that the value returned by \ide{eqv?} must be a boolean. \begin{scheme} (eqv? "" "") \ev \unspecified (eqv? '\#() '\#()) \ev \unspecified (eqv? (lambda (x) x) (lambda (x) x)) \ev \unspecified (eqv? (lambda (x) x) (lambda (y) y)) \ev \unspecified% \end{scheme} The next set of examples shows the use of \ide{eqv?}\ with procedures that have local state. \ide{Gen-counter} must return a distinct procedure every time, since each procedure has its own internal counter. \ide{Gen-loser}, however, returns equivalent procedures each time, since the local state does not affect the value or side effects of the procedures. \begin{scheme} (define gen-counter (lambda () (let ((n 0)) (lambda () (set! n (+ n 1)) n)))) (let ((g (gen-counter))) (eqv? g g)) \ev \schtrue (eqv? (gen-counter) (gen-counter)) \ev \schfalse (define gen-loser (lambda () (let ((n 0)) (lambda () (set! n (+ n 1)) 27)))) (let ((g (gen-loser))) (eqv? g g)) \ev \schtrue (eqv? (gen-loser) (gen-loser)) \ev \unspecified (letrec ((f (lambda () (if (eqv? f g) 'both 'f))) (g (lambda () (if (eqv? f g) 'both 'g))) (eqv? f g)) \ev \unspecified (letrec ((f (lambda () (if (eqv? f g) 'f 'both))) (g (lambda () (if (eqv? f g) 'g 'both))) (eqv? f g)) \ev \schfalse% \end{scheme} % Objects of distinct types must never be regarded as the same object, % except that \schfalse{} and the empty list\index{empty list} are permitted to % be identical. % % \begin{scheme} % (eqv? '() \schfalse) \ev \unspecified% % \end{scheme} Since it is an error to modify constant objects (those returned by literal expressions), implementations are permitted, though not required, to share structure between constants where appropriate. Thus the value of \ide{eqv?} on constants is sometimes implementation-dependent. \begin{scheme} (eqv? '(a) '(a)) \ev \unspecified (eqv? "a" "a") \ev \unspecified (eqv? '(b) (cdr '(a b))) \ev \unspecified (let ((x '(a))) (eqv? x x)) \ev \schtrue% \end{scheme} \begin{rationale} The above definition of \ide{eqv?} allows implementations latitude in their treatment of procedures and literals: implementations are free either to detect or to fail to detect that two procedures or two literals are equivalent to each other, and can decide whether or not to merge representations of equivalent objects by using the same pointer or bit pattern to represent both. \end{rationale} \end{entry} \begin{entry}{% \proto{eq?}{ \vari{obj} \varii{obj}}{essential procedure}} \ide{Eq?}\ is similar to \ide{eqv?}\ except that in some cases it is capable of discerning distinctions finer than those detectable by \ide{eqv?}. \vest \ide{Eq?}\ and \ide{eqv?}\ are guaranteed to have the same behavior on symbols, booleans, the empty list, pairs, and non-empty strings and vectors. \ide{Eq?}'s behavior on numbers and characters is implementation-dependent, but it will always return either true or false, and will return true only when \ide{eqv?}\ would also return true. \ide{Eq?} may also behave differently from \ide{eqv?} on empty vectors and empty strings. \begin{scheme} (eq? 'a 'a) \ev \schtrue (eq? '(a) '(a)) \ev \unspecified (eq? (list 'a) (list 'a)) \ev \schfalse (eq? "a" "a") \ev \unspecified (eq? "" "") \ev \unspecified (eq? '() '()) \ev \schtrue (eq? 2 2) \ev \unspecified (eq? \#\backwhack{}A \#\backwhack{}A) \ev \unspecified (eq? car car) \ev \schtrue (let ((n (+ 2 3))) (eq? n n)) \ev \unspecified (let ((x '(a))) (eq? x x)) \ev \schtrue (let ((x '\#())) (eq? x x)) \ev \schtrue (let ((p (lambda (x) x))) (eq? p p)) \ev \schtrue% \end{scheme} \todo{Needs to be explained better above. How can this be made to be not confusing? A table maybe?} \begin{rationale} It will usually be possible to implement \ide{eq?}\ much more efficiently than \ide{eqv?}, for example, as a simple pointer comparison instead of as some more complicated operation. One reason is that it may not be possible to compute \ide{eqv?}\ of two numbers in constant time, whereas \ide{eq?}\ implemented as pointer comparison will always finish in constant time. \ide{Eq?}\ may be used like \ide{eqv?}\ in applications using procedures to implement objects with state since it obeys the same constraints as \ide{eqv?}. \end{rationale} \end{entry} \begin{entry}{% \proto{equal?}{ \vari{obj} \varii{obj}}{essential procedure}} \ide{Equal?} recursively compares the contents of pairs, vectors, and strings, applying \ide{eqv?} on other objects such as numbers and symbols. A rule of thumb is that objects are generally \ide{equal?} if they print the same. \ide{Equal?}\ may fail to terminate if its arguments are circular data structures. \begin{scheme} (equal? 'a 'a) \ev \schtrue (equal? '(a) '(a)) \ev \schtrue (equal? '(a (b) c) '(a (b) c)) \ev \schtrue (equal? "abc" "abc") \ev \schtrue (equal? 2 2) \ev \schtrue (equal? (make-vector 5 'a) (make-vector 5 'a)) \ev \schtrue (equal? (lambda (x) x) (lambda (y) y)) \ev \unspecified% \end{scheme} \end{entry} \section{Pairs and lists} \label{listsection} A \defining{pair} (sometimes called a \defining{dotted pair}) is a record structure with two fields called the car and cdr fields (for historical reasons). Pairs are created by the procedure \ide{cons}. The car and cdr fields are accessed by the procedures \ide{car} and \ide{cdr}. The car and cdr fields are assigned by the procedures \ide{set-car!}\ and \ide{set-cdr!}. Pairs are used primarily to represent lists. A list can be defined recursively as either the empty list\index{empty list} or a pair whose cdr is a list. More precisely, the set of lists is defined as the smallest set \var{X} such that \begin{itemize} \item The empty list is in \var{X}. \item If \var{list} is in \var{X}, then any pair whose cdr field contains \var{list} is also in \var{X}. \end{itemize} The objects in the car fields of successive pairs of a list are the elements of the list. For example, a two-element list is a pair whose car is the first element and whose cdr is a pair whose car is the second element and whose cdr is the empty list. The length of a list is the number of elements, which is the same as the number of pairs. The empty list\mainindex{empty list} is a special object of its own type (it is not a pair); it has no elements and its length is zero. \begin{note} The above definitions imply that all lists have finite length and are terminated by the empty list. \end{note} The most general notation (external representation) for Scheme pairs is the ``dotted'' notation \hbox{\cf (\vari{c} .\ \varii{c})} where \vari{c} is the value of the car field and \varii{c} is the value of the cdr field. For example {\cf (4 .\ 5)} is a pair whose car is 4 and whose cdr is 5. Note that {\cf (4 .\ 5)} is the external representation of a pair, not an expression that evaluates to a pair. A more streamlined notation can be used for lists: the elements of the list are simply enclosed in parentheses and separated by spaces. The empty list\index{empty list} is written {\tt()} . For example, \begin{scheme} (a b c d e)% \end{scheme} and \begin{scheme} (a . (b . (c . (d . (e . ())))))% \end{scheme} are equivalent notations for a list of symbols. A chain of pairs not ending in the empty list is called an \defining{improper list}. Note that an improper list is not a list. The list and dotted notations can be combined to represent improper lists: \begin{scheme} (a b c . d)% \end{scheme} is equivalent to \begin{scheme} (a . (b . (c . d)))% \end{scheme} Whether a given pair is a list depends upon what is stored in the cdr field. When the \ide{set-cdr!} procedure is used, an object can be a list one moment and not the next: \begin{scheme} (define x (list 'a 'b 'c)) (define y x) y \ev (a b c) (list? y) \ev \schtrue (set-cdr! x 4) \ev \unspecified x \ev (a . 4) (eqv? x y) \ev \schtrue y \ev (a . 4) (list? y) \ev \schfalse (set-cdr! x x) \ev \unspecified (list? x) \ev \schfalse% \end{scheme} %It is often convenient to speak of a homogeneous list of objects %of some particular data type, as for example \hbox{\cf (1 2 3)} is a list of %integers. To be more precise, suppose \var{D} is some data type. (Any %predicate defines a data type consisting of those objects of which the %predicate is true.) Then % %\begin{itemize} %\item The empty list is a list of \var{D}. %\item If \var{list} is a list of \var{D}, then any pair whose cdr is % \var{list} and whose car is an element of the data type \var{D} is also a % list of \var{D}. %\item There are no other lists of \var{D}. %\end{itemize} Within literal expressions and representations of objects read by the \ide{read} procedure, the forms \singlequote\hyper{datum}\schindex{'}, \backquote\hyper{datum}, {\tt,}\hyper{datum}\schindex{,}, and {\tt,@}\hyper{datum} denote two-ele\-ment lists whose first elements are the symbols \ide{quote}, \ide{quasiquote}, \hbox{\ide{unquote}}, and \ide{unquote-splicing}, respectively. The second element in each case is \hyper{datum}. This convention is supported so that arbitrary Scheme programs may be represented as lists. \todo{Can or need this be stated more carefully?} That is, according to Scheme's grammar, every \meta{expression} is also a \meta{datum} (see section~\ref{datum}). Among other things, this permits the use of the \ide{read} procedure to parse Scheme programs. See section~\ref{externalreps}. \begin{entry}{% \proto{pair?}{ obj}{essential procedure}} \ide{Pair?} returns \schtrue{} if \var{obj} is a pair, and otherwise returns \schfalse. \begin{scheme} (pair? '(a . b)) \ev \schtrue (pair? '(a b c)) \ev \schtrue (pair? '()) \ev \schfalse (pair? '\#(a b)) \ev \schfalse% \end{scheme} \end{entry} \begin{entry}{% \proto{cons}{ \vari{obj} \varii{obj}}{essential procedure}} Returns a newly allocated pair whose car is \vari{obj} and whose cdr is \varii{obj}. The pair is guaranteed to be different (in the sense of \ide{eqv?}) from every existing object. \begin{scheme} (cons 'a '()) \ev (a) (cons '(a) '(b c d)) \ev ((a) b c d) (cons "a" '(b c)) \ev ("a" b c) (cons 'a 3) \ev (a . 3) (cons '(a b) 'c) \ev ((a b) . c)% \end{scheme} \end{entry} \begin{entry}{% \proto{car}{ pair}{essential procedure}} \nodomain{\var{Pair} must be a pair.} Returns the contents of the car field of \var{pair}. Note that it is an error to take the car of the empty list\index{empty list}. \begin{scheme} (car '(a b c)) \ev a (car '((a) b c d)) \ev (a) (car '(1 . 2)) \ev 1 (car '()) \ev \scherror% \end{scheme} \end{entry} \begin{entry}{% \proto{cdr}{ pair}{essential procedure}} \nodomain{\var{Pair} must be a pair.} Returns the contents of the cdr field of \var{pair}. Note that it is an error to take the cdr of the empty list. \begin{scheme} (cdr '((a) b c d)) \ev (b c d) (cdr '(1 . 2)) \ev 2 (cdr '()) \ev \scherror% \end{scheme} \end{entry} \begin{entry}{% \proto{set-car!}{ pair obj}{essential procedure}} \nodomain{\var{Pair} must be a pair.} Stores \var{obj} in the car field of \var{pair}. The value returned by \ide{set-car!}\ is unspecified. % %This procedure can be very confusing if used indiscriminately. \begin{scheme} (define (f) (list 'not-a-constant-list)) (define (g) '(constant-list)) (set-car! (f) 3) \ev \unspecified (set-car! (g) 3) \ev \scherror% \end{scheme} \end{entry} \begin{entry}{% \proto{set-cdr!}{ pair obj}{essential procedure}} \nodomain{\var{Pair} must be a pair.} Stores \var{obj} in the cdr field of \var{pair}. The value returned by \ide{set-cdr!}\ is unspecified. % %This procedure can be very confusing if used indiscriminately. \end{entry} \setbox0\hbox{\tt(cadr \var{pair})} \setbox1\hbox{essential procedure} \begin{entry}{% \proto{caar}{ pair}{essential procedure} \proto{cadr}{ pair}{essential procedure} \pproto{\hbox to 1\wd0 {\hfil$\vdots$\hfil}}{\hbox to 1\wd1 {\hfil$\vdots$\hfil}} \proto{cdddar}{ pair}{essential procedure} \proto{cddddr}{ pair}{essential procedure}} These procedures are compositions of \ide{car} and \ide{cdr}, where for example \ide{caddr} could be defined by \begin{scheme} (define caddr (lambda (x) (car (cdr (cdr x))))){\rm.}% \end{scheme} Arbitrary compositions, up to four deep, are provided. There are twenty-eight of these procedures in all. \end{entry} \begin{entry}{% \proto{null?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is the empty list\index{empty list}, otherwise returns \schfalse. % \begin{note} % In implementations in which the empty % list is the same as \schfalse{}, \ide{null?} will return \schtrue{} % if \var{obj} is \schfalse{}. % \end{note} \end{entry} \begin{entry}{% \proto{list?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is a list, otherwise returns \schfalse{}. By definition, all lists have finite length and are terminated by the empty list. \begin{scheme} (list? '(a b c)) \ev \schtrue (list? '()) \ev \schtrue (list? '(a . b)) \ev \schfalse (let ((x (list 'a))) (set-cdr! x x) (list? x)) \ev \schfalse% \end{scheme} \end{entry} \begin{entry}{% \proto{list}{ \var{obj} \dotsfoo}{essential procedure}} Returns a newly allocated list of its arguments. \begin{scheme} (list 'a (+ 3 4) 'c) \ev (a 7 c) (list) \ev ()% \end{scheme} \end{entry} \begin{entry}{% \proto{length}{ list}{essential procedure}} \nodomain{\var{List} must be a list.} Returns the length of \var{list}. \begin{scheme} (length '(a b c)) \ev 3 (length '(a (b) (c d e))) \ev 3 (length '()) \ev 0% \end{scheme} \end{entry} \begin{entry}{% \proto{append}{ list \dotsfoo}{essential procedure}} \nodomain{All \var{list}s should be lists.} Returns a list consisting of the elements of the first \var{list} followed by the elements of the other \var{list}s. \begin{scheme} (append '(x) '(y)) \ev (x y) (append '(a) '(b c d)) \ev (a b c d) (append '(a (b)) '((c))) \ev (a (b) (c))% \end{scheme} The resulting list is always newly allocated, except that it shares structure with the last \var{list} argument. The last argument may actually be any object; an improper list results if the last argument is not a proper list. \todo{This is pretty awkward. I should get Bartley to fix this.} \begin{scheme} (append '(a b) '(c . d)) \ev (a b c . d) (append '() 'a) \ev a% \end{scheme} \end{entry} \begin{entry}{% \proto{reverse}{ list}{essential procedure}} \nodomain{\var{List} must be a list.} Returns a newly allocated list consisting of the elements of \var{list} in reverse order. \begin{scheme} (reverse '(a b c)) \ev (c b a) (reverse '(a (b c) d (e (f)))) \lev ((e (f)) d (b c) a)% \end{scheme} \end{entry} \begin{entry}{% \proto{list-tail}{ list \vr{k}}{procedure}} Returns the sublist of \var{list} obtained by omitting the first \vr{k} elements. \ide{List-tail} could be defined by \begin{scheme} (define list-tail (lambda (x k) (if (zero? k) x (list-tail (cdr x) (- k 1)))))% \end{scheme} \end{entry} \begin{entry}{% \proto{list-ref}{ list \vr{k}}{essential procedure}} Returns the \vr{k}th element of \var{list}. (This is the same as the car of {\tt(list-tail \var{list} \vr{k})}.) \begin{scheme} (list-ref '(a b c d) 2) \ev c (list-ref '(a b c d) (inexact->exact (round 1.8))) \lev c% \end{scheme} \end{entry} %\begin{entry}{% %\proto{last-pair}{ list}{procedure}} % %Returns the last pair in the nonempty, possibly improper, list \var{list}. %\ide{Last-pair} could be defined by % %\begin{scheme} %(define last-pair % (lambda (x) % (if (pair? (cdr x)) % (last-pair (cdr x)) % x)))% %\end{scheme} % %\end{entry} \begin{entry}{% \proto{memq}{ obj list}{essential procedure} \proto{memv}{ obj list}{essential procedure} \proto{member}{ obj list}{essential procedure}} These procedures return the first sublist of \var{list} whose car is \var{obj}, where the sublists of \var{list} are the non-empty lists returned by {\tt (list-tail \var{list} \var{k})} for \var{k} less than the length of \var{list}. If \var{obj} does not occur in \var{list}, then \schfalse{} (not the empty list) is returned. \ide{Memq} uses \ide{eq?}\ to compare \var{obj} with the elements of \var{list}, while \ide{memv} uses \ide{eqv?}\ and \ide{member} uses \ide{equal?}. \begin{scheme} (memq 'a '(a b c)) \ev (a b c) (memq 'b '(a b c)) \ev (b c) (memq 'a '(b c d)) \ev \schfalse (memq (list 'a) '(b (a) c)) \ev \schfalse (member (list 'a) '(b (a) c)) \ev ((a) c) (memq 101 '(100 101 102)) \ev \unspecified (memv 101 '(100 101 102)) \ev (101 102)% \end{scheme} \end{entry} \begin{entry}{% \proto{assq}{ obj alist}{essential procedure} \proto{assv}{ obj alist}{essential procedure} \proto{assoc}{ obj alist}{essential procedure}} \domain{\var{Alist} (for ``association list'') must be a list of pairs.} These procedures find the first pair in \var{alist} whose car field is \var{obj}, and returns that pair. If no pair in \var{alist} has \var{obj} as its car, then \schfalse{} (not the empty list) is returned. \ide{Assq} uses \ide{eq?}\ to compare \var{obj} with the car fields of the pairs in \var{alist}, while \ide{assv} uses \ide{eqv?}\ and \ide{assoc} uses \ide{equal?}. \begin{scheme} (define e '((a 1) (b 2) (c 3))) (assq 'a e) \ev (a 1) (assq 'b e) \ev (b 2) (assq 'd e) \ev \schfalse (assq (list 'a) '(((a)) ((b)) ((c)))) \ev \schfalse (assoc (list 'a) '(((a)) ((b)) ((c)))) \ev ((a)) (assq 5 '((2 3) (5 7) (11 13))) \ev \unspecified (assv 5 '((2 3) (5 7) (11 13))) \ev (5 7)% \end{scheme} \begin{rationale} Although they are ordinarily used as predicates, \ide{memq}, \ide{memv}, \ide{member}, \ide{assq}, \ide{assv}, and \ide{assoc} do not have question marks in their names because they return useful values rather than just \schtrue{} or \schfalse{}. \end{rationale} \end{entry} \section{Symbols} \label{symbolsection} Symbols are objects whose usefulness rests on the fact that two symbols are identical (in the sense of \ide{eqv?}) if and only if their names are spelled the same way. This is exactly the property needed to represent identifiers\index{identifier} in programs, and so most implementations of Scheme use them internally for that purpose. Symbols are useful for many other applications; for instance, they may be used the way enumerated values are used in Pascal. \vest The rules for writing a symbol are exactly the same as the rules for writing an identifier; see sections~\ref{syntaxsection} and~\ref{identifiersyntax}. \vest It is guaranteed that any symbol that has been returned as part of a literal expression, or read using the \ide{read} procedure, and subsequently written out using the \ide{write} procedure, will read back in as the identical symbol (in the sense of \ide{eqv?}). The \ide{string\coerce{}symbol} procedure, however, can create symbols for which this write/read invariance may not hold because their names contain special characters or letters in the non-standard case. \begin{note} Some implementations of Scheme have a feature known as ``slashification'' in order to guarantee write/read invariance for all symbols, but historically the most important use of this feature has been to compensate for the lack of a string data type. \vest Some implementations also have ``uninterned symbols'', which defeat write/read invariance even in implementations with slashification, and also generate exceptions to the rule that two symbols are the same if and only if their names are spelled the same. \end{note} \begin{entry}{% \proto{symbol?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is a symbol, otherwise returns \schfalse. \begin{scheme} (symbol? 'foo) \ev \schtrue (symbol? (car '(a b))) \ev \schtrue (symbol? "bar") \ev \schfalse (symbol? 'nil) \ev \schtrue (symbol? '()) \ev \schfalse (symbol? \schfalse) \ev \schfalse% \end{scheme} \end{entry} \begin{entry}{% \proto{symbol->string}{ symbol}{essential procedure}} Returns the name of \var{symbol} as a string. If the symbol was part of an object returned as the value of a literal expression (section~\ref{literalsection}) or by a call to the \ide{read} procedure, and its name contains alphabetic characters, then the string returned will contain characters in the implementation's preferred standard case---some implementations will prefer upper case, others lower case. If the symbol was returned by \ide{string\coerce{}symbol}, the case of characters in the string returned will be the same as the case in the string that was passed to \ide{string\coerce{}symbol}. It is an error to apply mutation procedures like \ide{string-set!} to strings returned by this procedure. The following examples assume that the implementation's standard case is lower case: \begin{scheme} (symbol->string 'flying-fish) \ev "flying-fish" (symbol->string 'Martin) \ev "martin" (symbol->string (string->symbol "Malvina")) \ev "Malvina"% \end{scheme} \end{entry} \begin{entry}{% \proto{string->symbol}{ string}{essential procedure}} Returns the symbol whose name is \var{string}. This procedure can create symbols with names containing special characters or letters in the non-standard case, but it is usually a bad idea to create such symbols because in some implementations of Scheme they cannot be read as themselves. See \ide{symbol\coerce{}string}. The following examples assume that the implementation's standard case is lower case: \begin{scheme} (eq? 'mISSISSIppi 'mississippi) \lev \schtrue (string->symbol "mISSISSIppi") \lev% {\rm{}the symbol with name} "mISSISSIppi" (eq? 'bitBlt (string->symbol "bitBlt")) \lev \schfalse (eq? 'JollyWog (string->symbol (symbol->string 'JollyWog))) \lev \schtrue (string=? "K. Harper, M.D." (symbol->string (string->symbol "K. Harper, M.D."))) \lev \schtrue% \end{scheme} \end{entry} \section{Numbers} \label{numbersection} \index{number} %%R4%% The excessive use of the code font in this section was % confusing, somewhat obnoxious, and inconsistent with the rest % of the report and with parts of the section itself. I added % a \tupe no-op, and changed most old uses of \type to \tupe, % to make it easier to change the fonts back if people object % to the change. \newcommand{\type}[1]{{\it#1}} \newcommand{\tupe}[1]{{#1}} Numerical computation has traditionally been neglected by the Lisp community. Until Common Lisp there was no carefully thought out strategy for organizing numerical computation, and with the exception of the MacLisp system \cite{Pitman83} little effort was made to execute numerical code efficiently. This report recognizes the excellent work of the Common Lisp committee and accepts many of their recommendations. In some ways this report simplifies and generalizes their proposals in a manner consistent with the purposes of Scheme. It is important to distinguish between the mathematical numbers, the Scheme numbers that attempt to model them, the machine representations used to implement the Scheme numbers, and notations used to write numbers. This report uses the types \type{number}, \type{complex}, \type{real}, \type{rational}, and \type{integer} to refer to both mathematical numbers and Scheme numbers. Machine representations such as fixed point and floating point are referred to by names such as \type{fixnum} and \type{flonum}. %%R4%% I did some reorganizing here to move the discussion of mathematical % numbers before the discussion of the Scheme numbers, hoping that this % would help to motivate the discussion of representation independence. \subsection{Numerical types} \label{numericaltypes} \index{numerical types} %%R4%% A Scheme system provides data of type \type{number}, which is the most %general numerical type supported by that system. %\type{Number} is %likely to be a complicated union type implemented in terms of %\type{fixnum}s, \type{bignum}s, \type{flonum}s, and so forth, but this %should not be apparent to a naive user. What the user should see is %that the usual operations on numbers produce the mathematically %expected results, within the limits of the implementation. %%R4%% I rewrote the following paragraph to make the various levels of % the tower into subsets of each other, instead of relating them by % injections. I think the injections tended to put people in the frame % of mind of thinking about coercions between non-overlapping numeric % types in mainstream programming languages. \vest Mathematically, numbers may be arranged into a tower of subtypes %%R4%% with injections relating adjacent levels of the tower: in which each level is a subset of the level above it: $$\begin{tabular}{l} \tupe{number} \\ \tupe{complex} \\ \tupe{real} \\ \tupe{rational} \\ \tupe{integer} \end{tabular} $$ For example, 3 is an integer. Therefore 3 is also a rational, a real, and a complex. The same is true of the Scheme numbers that model 3. For Scheme numbers, these types are defined by the predicates \ide{number?}, \ide{complex?}, \ide{real?}, \ide{rational?}, and \ide{integer?}. There is no simple relationship between a number's type and its representation inside a computer. Although most implementations of Scheme will offer at least two different representations of 3, these different representations denote the same integer. %%R4%% I moved "Implementations of Scheme are not required to implement % the whole tower..." to the subsection on implementation restrictions. Scheme's numerical operations treat numbers as abstract data, as independent of their representation as possible. Although an implementation of Scheme may use fixnum, flonum, and perhaps other representations for numbers, this should not be apparent to a casual programmer writing simple programs. It is necessary, however, to distinguish between numbers that are represented exactly and those that may not be. For example, indexes into data structures must be known exactly, as must some polynomial coefficients in a symbolic algebra system. On the other hand, the results of measurements are inherently inexact, and irrational numbers may be approximated by rational and therefore inexact approximations. In order to catch uses of inexact numbers where exact numbers are required, Scheme explicitly distinguishes exact from inexact numbers. This distinction is orthogonal to the dimension of type. \subsection{Exactness} %%R4%% I tried to direct the following paragraph away from philosophizing % about the exactness of mathematical numbers, and toward philosophizing % about the exactness of Scheme numbers. \mainindex{exactness} \label{exactly} Scheme numbers are either \type{exact} or \type{inexact}. A number is \tupe{exact} if it was written as an exact constant or was derived from \tupe{exact} numbers using only \tupe{exact} operations. A number is \tupe{inexact} if it was written as an inexact constant, %%R4%% models a quantity (e.g., a measurement) known only approximately, if it was derived using \tupe{inexact} ingredients, or if it was derived using \tupe{inexact} operations. Thus \tupe{inexact}ness is a contagious property of a number. %%R4%% The rest of this paragraph (from R3RS) has been dropped. \vest If two implementations produce \tupe{exact} results for a computation that did not involve \tupe{inexact} intermediate results, the two ultimate results will be mathematically equivalent. This is generally not true of computations involving \tupe{inexact} numbers since approximate methods such as floating point arithmetic may be used, but it is the duty of each implementation to make the result as close as practical to the mathematically ideal result. \vest Rational operations such as \ide{+} should always produce \tupe{exact} results when given \tupe{exact} arguments. %%R4%%If an implementation is %unable to represent an \tupe{exact} result (for example, if it does not %support infinite precision integers and rationals) If the operation is unable to produce an \tupe{exact} result, then it may either report the violation of an implementation restriction or it may silently coerce its result to an \tupe{inexact} value. %%R4%%Such a coercion may cause an error later. See section~\ref{restrictions}. \vest With the exception of \ide{inexact->exact}, the operations described in this section must generally return inexact results when given any inexact arguments. An operation may, however, return an \tupe{exact} result if it can prove that the value of the result is unaffected by the inexactness of its arguments. For example, multiplication of any number by an \tupe{exact} zero may produce an \tupe{exact} zero result, even if the other argument is \tupe{inexact}. \subsection{Implementation restrictions} \index{implementation restriction}\label{restrictions} \vest Implementations of Scheme are not required to implement the whole tower of subtypes given in section~\ref{numericaltypes}, but they must implement a coherent subset consistent with both the purposes of the implementation and the spirit of the Scheme language. For example, an implementation in which all numbers are \tupe{real} may still be quite useful. \vest Implementations may also support only a limited range of numbers of any type, subject to the requirements of this section. The supported range for \tupe{exact} numbers of any type may be different from the supported range for \tupe{inexact} numbers of that type. For example, an implementation that uses flonums to represent all its \tupe{inexact} \tupe{real} numbers may support a practically unbounded range of \tupe{exact} \tupe{integer}s and \tupe{rational}s while limiting the range of \tupe{inexact} \tupe{real}s (and therefore the range of \tupe{inexact} \tupe{integer}s and \tupe{rational}s) to the dynamic range of the flonum format. Furthermore the gaps between the representable \tupe{inexact} \tupe{integer}s and \tupe{rational}s are likely to be very large in such an implementation as the limits of this range are approached. \vest An implementation of Scheme must support exact integers throughout the range of numbers that may be used for indexes of lists, vectors, and strings or that may result from computing the length of a list, vector, or string. The \ide{length}, \ide{vector-length}, and \ide{string-length} procedures must return an exact integer, and it is an error to use anything but an exact integer as an index. Furthermore any integer constant within the index range, if expressed by an exact integer syntax, will indeed be read as an exact integer, regardless of any implementation restrictions that may apply outside this range. Finally, the procedures listed below will always return an exact integer result provided all their arguments are exact integers and the mathematically expected result is representable as an exact integer within the implementation: \begin{scheme} + - * quotient remainder modulo max min abs numerator denominator gcd lcm floor ceiling truncate round rationalize expt% \end{scheme} \vest Implementations are encouraged, but not required, to support \tupe{exact} \tupe{integer}s and \tupe{exact} \tupe{rational}s of practically unlimited size and precision, and to implement the above procedures and the \ide{/} procedure in such a way that they always return \tupe{exact} results when given \tupe{exact} arguments. If one of these procedures is unable to deliver an \tupe{exact} result when given \tupe{exact} arguments, then it may either report a violation of an implementation restriction or it may silently coerce its result to an \tupe{inexact} number. Such a coercion may cause an error later. %%R4%% I moved this stuff here. % It seems to me that the only thing that this requires is that % implementations that support inexact numbers have to have both % exact and inexact representations for the integers 0 through 15. % If that's what it's saying, I'd rather say it that way. % On the other hand, letting the limit be as small as 15 sounds a % tad silly, though I think I understand how that number was arrived at. % (Or is 35 the number?) % %Implementations are encouraged, but not required, to support \tupe{inexact} %numbers. For any implementation that supports \tupe{inexact} numbers, %there is a subset of the integers for which there are both \tupe{exact} and %\tupe{inexact} representations. This subset must include all non-negative %integers up to some limit specified by the implementation. This limit %must be 16 or greater. The %\ide{exact\coerce{}inexact} and \ide{inexact\coerce{}exact} %procedures implement the natural one-to-one correspondence between %the \tupe{inexact} and \tupe{exact} integers within this range. \vest An implementation may use floating point and other approximate representation strategies for \tupe{inexact} numbers. %%R4%% The following sentence seemed a bit condescending as well as % awkward. It didn't seem to be very enforceable, so I flushed it. % %This is not to %say that implementors need not use the best known algorithms for %\tupe{inexact} computations---only that approximate methods of high %quality are allowed. % This report recommends, but does not require, that the IEEE 32-bit and 64-bit floating point standards be followed by implementations that use flonum representations, and that implementations using other representations should match or exceed the precision achievable using these floating point standards~\cite{IEEE}. \vest In particular, implementations that use flonum representations must follow these rules: A \tupe{flonum} result must be represented with at least as much precision as is used to express any of the inexact arguments to that operation. It is desirable (but not required) for potentially inexact operations such as \ide{sqrt}, when applied to \tupe{exact} arguments, to produce \tupe{exact} answers whenever possible (for example the square root of an \tupe{exact} 4 ought to be an \tupe{exact} 2). If, however, an \tupe{exact} number is operated upon so as to produce an \tupe{inexact} result (as by \ide{sqrt}), and if the result is represented as a \tupe{flonum}, then the most precise \tupe{flonum} format available must be used; but if the result is represented in some other way then the representation must have at least as much precision as the most precise \tupe{flonum} format available. Although Scheme allows a variety of written %%R4%% representations of notations for numbers, any particular implementation may support only some of them. %%R4%% For example, an implementation in which all numbers are \tupe{real} need not support the rectangular and polar notations for complex numbers. If an implementation encounters an \tupe{exact} numerical constant that it cannot represent as an \tupe{exact} number, then it may either report a violation of an implementation restriction or it may silently represent the constant by an \tupe{inexact} number. \subsection{Syntax of numerical constants} \label{numbernotations} %@@@@LOSE@@@@ %%R4%% I removed the following paragraph in an attempt to tighten up % this subsection. Except for its first sentence, which I moved to % the subsection on implementation restrictions, I think its content % is implied by the rest of the section. % %Although Scheme allows a variety of written representations of numbers, %any particular implementation may support only some of them. %These syntaxes are intended to be purely notational; any kind of number %may be written in any form that the user deems convenient. Of course, %writing 1/7 as a limited-precision decimal fraction will not express the %number exactly, but this approximate form of expression may be just what %the user wants to see. The syntax of the written representations for numbers is described formally in section~\ref{numbersyntax}. %%R4%% See section~\ref{numberformats} for many examples. A number may be written in binary, octal, decimal, or hexadecimal by the use of a radix prefix. The radix prefixes are {\cf \#b}\sharpindex{b} (binary), {\cf \#o}\sharpindex{o} (octal), {\cf \#d}\sharpindex{d} (decimal), and {\cf \#x}\sharpindex{x} (hexadecimal). With no radix prefix, a number is assumed to be expressed in decimal. A %%R4%% % simple numerical constant may be specified to be either \tupe{exact} or \tupe{inexact} by a prefix. The prefixes are {\cf \#e}\sharpindex{e} for \tupe{exact}, and {\cf \#i}\sharpindex{i} for \tupe{inexact}. An exactness prefix may appear before or after any radix prefix that is used. If the written representation of a number has no exactness prefix, the constant may be either \tupe{inexact} or \tupe{exact}. It is \tupe{inexact} if it contains a decimal point, an exponent, or a ``\sharpsign'' character in the place of a digit, otherwise it is \tupe{exact}. %%R4%% With our new syntax, the following sentence is redundant: % %The written representation of a %compound number, such as a ratio or a complex, is exact if and only if %all of its constituents are exact. In systems with \tupe{inexact} numbers of varying precisions it may be useful to specify the precision of a constant. For this purpose, numerical constants may be written with an exponent marker that indicates the desired precision of the \tupe{inexact} representation. The letters \ide{s}, \ide{f}, \ide{d}, and \ide{l} specify the use of \var{short}, \var{single}, \var{double}, and \var{long} precision, respectively. (When fewer than four internal %%R4%%\tupe{flonum} \tupe{inexact} representations exist, the four size specifications are mapped onto those available. For example, an implementation with two internal representations may map short and single together and long and double together.) In addition, the exponent marker \ide{e} specifies the default precision for the implementation. The default precision has at least as much precision as \var{double}, but implementations may wish to allow this default to be set by the user. \begin{scheme} 3.14159265358979F0 {\rm Round to single ---} 3.141593 0.6L0 {\rm Extend to long ---} .600000000000000% \end{scheme} \subsection{Numerical operations} The reader is referred to section~\ref{typeconventions} for a summary of the naming conventions used to specify restrictions on the types of arguments to numerical routines. %%R4%% The following sentence has already been said twice, and the % term "exactness-preserving" is no longer defined by the Report. % % Remember that %an exactness-preserving operation may coerce its result to inexact if the %implementation is unable to represent it exactly. The examples used in this section assume that any numerical constant written using an \tupe{exact} notation is indeed represented as an \tupe{exact} number. Some examples also assume that certain numerical constants written using an \tupe{inexact} notation can be represented without loss of accuracy; the \tupe{inexact} constants were chosen so that this is likely to be true in implementations that use flonums to represent inexact numbers. \todo{Scheme provides the usual set of operations for manipulating numbers, etc.} \begin{entry}{% \proto{number?}{ obj}{essential procedure} \proto{complex?}{ obj}{essential procedure} \proto{real?}{ obj}{essential procedure} \proto{rational?}{ obj}{essential procedure} \proto{integer?}{ obj}{essential procedure}} These numerical type predicates can be applied to any kind of argument, including non-numbers. They return \schtrue{} if the object is of the named type, and otherwise they return \schfalse{}. In general, if a type predicate is true of a number then all higher type predicates are also true of that number. Consequently, if a type predicate is false of a number, then all lower type predicates are also false of that number. %%R4%% The new section on implementation restrictions subsumes: % Not every system %supports all of these types; for example, it is entirely possible to have a %Scheme system that has only \tupe{integer}s. Nonetheless every implementation %of Scheme must have all of these predicates. If \vr{z} is an inexact complex number, then {\cf (real? \vr{z})} is true if and only if {\cf (zero? (imag-part \vr{z}))} is true. If \vr{x} is an inexact real number, then {\cf (integer? \vr{x})} is true if and only if {\cf (= \vr{x} (round \vr{x}))}. \begin{scheme} (complex? 3+4i) \ev \schtrue (complex? 3) \ev \schtrue (real? 3) \ev \schtrue (real? -2.5+0.0i) \ev \schtrue (real? \#e1e10) \ev \schtrue (rational? 6/10) \ev \schtrue (rational? 6/3) \ev \schtrue (integer? 3+0i) \ev \schtrue (integer? 3.0) \ev \schtrue (integer? 8/4) \ev \schtrue% \end{scheme} \begin{note} The behavior of these type predicates on \tupe{inexact} numbers is unreliable, since any inaccuracy may affect the result. \end{note} \begin{note} In many implementations the \ide{rational?} procedure will be the same as \ide{real?}, and the \ide{complex?} procedure will be the same as \ide{number?}, but unusual implementations may be able to represent some irrational numbers exactly or may extend the number system to support some kind of non-complex numbers. \end{note} \end{entry} \begin{entry}{% \proto{exact?}{ \vr{z}}{essential procedure} \proto{inexact?}{ \vr{z}}{essential procedure}} These numerical predicates provide tests for the exactness of a quantity. For any Scheme number, precisely one of these predicates is true. \end{entry} \begin{entry}{% \proto{=}{ \vri{z} \vrii{z} \vriii{z} \dotsfoo}{essential procedure} \proto{<}{ \vri{x} \vrii{x} \vriii{x} \dotsfoo}{essential procedure} \proto{>}{ \vri{x} \vrii{x} \vriii{x} \dotsfoo}{essential procedure} \proto{<=}{ \vri{x} \vrii{x} \vriii{x} \dotsfoo}{essential procedure} \proto{>=}{ \vri{x} \vrii{x} \vriii{x} \dotsfoo}{essential procedure}} %- Some implementations allow these procedures to take many arguments, to %- facilitate range checks. These procedures return \schtrue{} if their arguments are (respectively): equal, monotonically increasing, monotonically decreasing, monotonically nondecreasing, or monotonically nonincreasing. These predicates are required to be transitive. \begin{note} The traditional implementations of these predicates in Lisp-like languages are not transitive. \end{note} \begin{note} While it is not an error to compare \tupe{inexact} numbers using these predicates, the results may be unreliable because a small inaccuracy may affect the result; this is especially true of \ide{=} and \ide{zero?}. When in doubt, consult a numerical analyst. \end{note} \end{entry} \begin{entry}{% \proto{zero?}{ \vr{z}}{essential procedure} \proto{positive?}{ \vr{x}}{essential procedure} \proto{negative?}{ \vr{x}}{essential procedure} \proto{odd?}{ \vr{n}}{essential procedure} \proto{even?}{ \vr{n}}{essential procedure}} These numerical predicates test a number for a particular property, returning \schtrue{} or \schfalse. See note above. \end{entry} \begin{entry}{% \proto{max}{ \vri{x} \vrii{x} \dotsfoo}{essential procedure} \proto{min}{ \vri{x} \vrii{x} \dotsfoo}{essential procedure}} These procedures return the maximum or minimum of their arguments. \begin{scheme} (max 3 4) \ev 4 ; exact (max 3.9 4) \ev 4.0 ; inexact% \end{scheme} \begin{note} If any argument is inexact, then the result will also be inexact (unless the procedure can prove that the inaccuracy is not large enough to affect the result, which is possible only in unusual implementations). If \ide{min} or \ide{max} is used to compare numbers of mixed exactness, and the numerical value of the result cannot be represented as an inexact number without loss of accuracy, then the procedure may report a violation of an implementation restriction. \end{note} \end{entry} \begin{entry}{% \proto{+}{ \vri{z} \dotsfoo}{essential procedure} \proto{*}{ \vri{z} \dotsfoo}{essential procedure}} These procedures return the sum or product of their arguments. %- These procedures are exactness preserving. \begin{scheme} (+ 3 4) \ev 7 (+ 3) \ev 3 (+) \ev 0 (* 4) \ev 4 (*) \ev 1% \end{scheme} \end{entry} \begin{entry}{% \proto{-}{ \vri{z} \vrii{z}}{essential procedure} \proto{-}{ \vr{z}}{essential procedure} \proto{-}{ \vri{z} \vrii{z} \dotsfoo}{procedure} \proto{/}{ \vri{z} \vrii{z}}{essential procedure} \proto{/}{ \vr{z}}{essential procedure} \proto{/}{ \vri{z} \vrii{z} \dotsfoo}{procedure}} With two or more arguments, these procedures return the difference or quotient of their arguments, associating to the left. With one argument, however, they return the additive or multiplicative inverse of their argument. %- These procedures are exactness preserving, except that division may %- coerce its result to inexact in implementations that do not support %- \tupe{ratnum}s. \begin{scheme} (- 3 4) \ev -1 (- 3 4 5) \ev -6 (- 3) \ev -3 (/ 3 4 5) \ev 3/20 (/ 3) \ev 1/3% \end{scheme} \end{entry} \begin{entry}{% \proto{abs}{ x}{essential procedure}} \ide{Abs} returns the magnitude of its argument. %- \ide{Abs} is exactness preserving when its argument is real. \begin{scheme} (abs -7) \ev 7 \end{scheme} \end{entry} \begin{entry}{% \proto{quotient}{ \vri{n} \vrii{n}}{essential procedure} \proto{remainder}{ \vri{n} \vrii{n}}{essential procedure} \proto{modulo}{ \vri{n} \vrii{n}}{essential procedure}} These %- exactness-preserving procedures implement number-theoretic (integer) division: For positive integers \vri{n} and \vrii{n}, if \vriii{n} and \vriv{n} are integers such that $\vri{n}=\vrii{n}\vriii{n}+\vriv{n}$ and $0\leq \vriv{n}<\vrii{n}$, then \begin{scheme} (quotient \vri{n} \vrii{n}) \ev \vriii{n} (remainder \vri{n} \vrii{n}) \ev \vriv{n} (modulo \vri{n} \vrii{n}) \ev \vriv{n}% \end{scheme} For integers \vri{n} and \vrii{n} with \vrii{n} not equal to 0, \begin{scheme} (= \vri{n} (+ \=(* \vrii{n} (quotient \vri{n} \vrii{n})) \>(remainder \vri{n} \vrii{n}))) \ev \schtrue% \end{scheme} provided all numbers involved in that computation are exact. The value returned by \ide{quotient} always has the sign of the product of its arguments. \ide{Remainder} and \ide{modulo} differ on negative arguments---the \ide{remainder} is either zero or has the sign of the dividend, while the \ide{modulo} always has the sign of the divisor: \begin{scheme} (modulo 13 4) \ev 1 (remainder 13 4) \ev 1 (modulo -13 4) \ev 3 (remainder -13 4) \ev -1 (modulo 13 -4) \ev -3 (remainder 13 -4) \ev 1 (modulo -13 -4) \ev -1 (remainder -13 -4) \ev -1 (remainder -13 -4.0) \ev -1.0 ; inexact% \end{scheme} \end{entry} \begin{entry}{% \proto{gcd}{ \vri{n} \dotsfoo}{essential procedure} \proto{lcm}{ \vri{n} \dotsfoo}{essential procedure}} These procedures return the greatest common divisor or least common multiple of their arguments. The result is always non-negative. %- These procedures are exactness preserving. %%R4%% I added the inexact example. \begin{scheme} (gcd 32 -36) \ev 4 (gcd) \ev 0 (lcm 32 -36) \ev 288 (lcm 32.0 -36) \ev 288.0 ; inexact (lcm) \ev 1% \end{scheme} \end{entry} \begin{entry}{% \proto{numerator}{ \vr{q}}{procedure} \proto{denominator}{ \vr{q}}{procedure}} These procedures return the numerator or denominator of their argument; the result is computed as if the argument was represented as a fraction in lowest terms. The denominator is always positive. The denominator of 0 is defined to be 1. %- The remarks about denominators are new. %- Clearly, they are exactness-preserving procedures. \todo{More description and examples needed.} \begin{scheme} (numerator (/ 6 4)) \ev 3 (denominator (/ 6 4)) \ev 2 (denominator (exact->inexact (/ 6 4))) \ev 2.0% \end{scheme} \end{entry} \begin{entry}{% \proto{floor}{ x}{essential procedure} \proto{ceiling}{ x}{essential procedure} \proto{truncate}{ x}{essential procedure} \proto{round}{ x}{essential procedure} } These procedures return integers. \vest \ide{Floor} returns the largest integer not larger than \vr{x}. \ide{Ceiling} returns the smallest integer not smaller than~\vr{x}. \ide{Truncate} returns the integer closest to \vr{x} whose absolute value is not larger than the absolute value of \vr{x}. \ide{Round} returns the closest integer to \vr{x}, rounding to even when \vr{x} is halfway between two integers. \begin{rationale} \ide{Round} rounds to even for consistency with the default rounding mode specified by the IEEE floating point standard. \end{rationale} \begin{note} If the argument to one of these procedures is inexact, then the result will also be inexact. If an exact value is needed, the result should be passed to the \ide{inexact->exact} procedure. \end{note} \begin{scheme} (floor -4.3) \ev -5.0 (ceiling -4.3) \ev -4.0 (truncate -4.3) \ev -4.0 (round -4.3) \ev -4.0 (floor 3.5) \ev 3.0 (ceiling 3.5) \ev 4.0 (truncate 3.5) \ev 3.0 (round 3.5) \ev 4.0 ; inexact (round 7/2) \ev 4 ; exact (round 7) \ev 7% \end{scheme} \end{entry} \begin{entry}{% \proto{rationalize}{ x y}{procedure} %- \proto{rationalize}{ x}{procedure} } \ide{Rationalize} returns the {\em simplest} rational number differing from \vr{x} by no more than \vr{y}. A rational number $r_1$ is {\em simpler} \mainindex{simplest rational} than another rational number $r_2$ if $r_1 = p_1/q_1$ and $r_2 = p_2/q_2$ (in lowest terms) and $|p_1| \leq |p_2|$ and $|q_1| \leq |q_2|$. Thus $3/5$ is simpler than $4/7$. Although not all rationals are comparable in this ordering (consider $2/7$ and $3/5$) any interval contains a rational number that is simpler than every other rational number in that interval (the simpler $2/5$ lies between $2/7$ and $3/5$). Note that $0 = 0/1$ is the simplest rational of all. \begin{scheme} (rationalize (inexact->exact .3) 1/10) \ev 1/3 ; exact (rationalize .3 1/10) \ev \#i1/3 ; inexact% \end{scheme} \end{entry} \begin{entry}{% \proto{exp}{ \vr{z}}{procedure} \proto{log}{ \vr{z}}{procedure} \proto{sin}{ \vr{z}}{procedure} \proto{cos}{ \vr{z}}{procedure} \proto{tan}{ \vr{z}}{procedure} \proto{asin}{ \vr{z}}{procedure} \proto{acos}{ \vr{z}}{procedure} \proto{atan}{ \vr{z}}{procedure} \proto{atan}{ \vr{y} \vr{x}}{procedure}} These procedures are part of every implementation that supports %%R4%% general real numbers; they compute the usual transcendental functions. \ide{Log} computes the natural logarithm of \vr{z} (not the base ten logarithm). \ide{Asin}, \ide{acos}, and \ide{atan} compute arcsine ($\sin^{-1}$), arccosine ($\cos^{-1}$), and arctangent ($\tan^{-1}$), respectively. The two-argument variant of \ide{atan} computes {\tt (angle (make-rectangular \vr{x} \vr{y}))} (see below), even in implementations that don't support general complex numbers. In general, the mathematical functions log, arcsine, arccosine, and arctangent are multiply defined. For nonzero real $x$, the value of $\log x$ is defined to be the one whose imaginary part lies in the range $-\pi$ (exclusive) to $\pi$ (inclusive). $\log 0$ is undefined. The value of $\log z$ when \vr{z} is complex is defined according to the formula $$\log z = \log {\rm magnitude}(z) + i \: {\rm angle} (z)$$ With $\log$ defined this way, the values of $\sin^{-1} z$, $\cos^{-1} z$, and $\tan^{-1} z$ are according to the following formul\ae: $$\sin^{-1} z = -i \log (i z + \sqrt{1 - z^2})$$ $$\cos^{-1} z = \pi / 2 - \sin^{-1} z$$ $$\tan^{-1} z = (\log (1 + i z) - \log (1 - i z)) / (2 i)$$ The above specification follows~\cite{CLtL}, which in turn cites~\cite{Penfield81}; refer to these sources for more detailed discussion of branch cuts, boundary conditions, and implementation of these functions. When it is possible these procedures produce a real result from a real argument. %%R4%% \todo{The cited references are likely to change their branch cuts soon to allow for the possibility of distinct positive and negative zeroes, as in IEEE floating point. We may not want to follow those changes, since we may want a complex number with zero imaginary part (whether positive or negative zero) to be treated as a real. I don't think there are any better standards for complex arithmetic than the ones cited, so we're really on our own here.} \end{entry} \begin{entry}{% \proto{sqrt}{ \vr{z}}{procedure}} Returns the principal square root of \vr{z}. The result will have either positive real part, or zero real part and non-negative imaginary part. \end{entry} \begin{entry}{% \proto{expt}{ \vri{z} \vrii{z}}{procedure}} Returns \vri{z} raised to the power \vrii{z}: $${z_1}^{z_2} = e^{z_2 \log {z_1}}$$ $0^0$ is defined to be equal to 1. \end{entry} %- \begin{entry}{%- %- \proto{approximate}{ z x}{procedure}} %- %- Returns an approximation to \vr{z} in a representation whose precision is %- the same as that %- of the representation of \vr{x}, which must be an inexact number. The %- result is always inexact. %- %- \begin{scheme} %- (approximate 3.1415926535 1F10) %- \ev 3.14159F0 %- (approximate 3.1415926535 \#I65535) %- \ev \#I3 %- (approximate 3.14F0 1L8) %- \ev 3.14L0 %- (approximate 3.1415926535F0 1L8) %- \ev 3.14159L0 %- \end{scheme} %- \end{entry} \begin{entry}{% \proto{make-rectangular}{ \vri{x} \vrii{x}}{procedure} \proto{make-polar}{ \vriii{x} \vriv{x}}{procedure} \proto{real-part}{ \vr{z}}{procedure} \proto{imag-part}{ \vr{z}}{procedure} \proto{magnitude}{ \vr{z}}{procedure} \proto{angle}{ \vr{z}}{procedure}} These procedures are part of every implementation that supports %%R4%% general complex numbers. Suppose \vri{x}, \vrii{x}, \vriii{x}, and \vriv{x} are real numbers and \vr{z} is a complex number such that $$ \vr{z} = \vri{x} + \vrii{x}\hbox{$i$} = \vriii{x} \cdot e^{{\displaystyle{\hbox{$i$}} \vriv{x}}}$$ Then \ide{make-rectangular} and \ide{make-polar} return \vr{z}, \ide{real-part} returns \vri{x}, \ide{imag-part} returns \vrii{x}, \ide{magnitude} returns \vriii{x}, and \ide{angle} returns \vriv{x}. In the case of \ide{angle}, whose value is not uniquely determined by the preceding rule, the value returned will be the one in the range $-\pi$ (exclusive) to $\pi$ (inclusive). \begin{rationale} \ide{Magnitude} is the same as \ide{abs} for a real argument, but \ide{abs} must be present in all implementations, whereas \ide{magnitude} need only be present in implementations that support general complex numbers. \end{rationale} \end{entry} \begin{entry}{% \proto{exact->inexact}{ \vr{z}}{procedure} \proto{inexact->exact}{ \vr{z}}{procedure}} \ide{Exact\coerce{}inexact} returns an \tupe{inexact} representation of \vr{z}. The value returned is the \tupe{inexact} number that is numerically closest to the argument. %%R4%%For %\tupe{exact} arguments which have no reasonably close \tupe{inexact} equivalent, %it is permissible to signal an error. If an \tupe{exact} argument has no reasonably close \tupe{inexact} equivalent, then a violation of an implementation restriction may be reported. \ide{Inexact\coerce{}exact} returns an \tupe{exact} representation of \vr{z}. The value returned is the \tupe{exact} number that is numerically closest to the argument. %%R4%% For \tupe{inexact} arguments which have no %reasonably close \tupe{exact} equivalent, it is permissible to signal %an error. If an \tupe{inexact} argument has no reasonably close \tupe{exact} equivalent, then a violation of an implementation restriction may be reported. %%R%% I moved this to the section on implementation restrictions. %For any implementation that supports \tupe{inexact} quantities, %there is a subset of the integers for which there are both \tupe{exact} and %\tupe{inexact} representations. This subset must include the non-negative %integers up to a limit specified by the implementation. The limit %must be big enough to represent all digits in reasonable radices, and %may correspond to some natural word size for the implementation. For %such integers, these procedures implement the natural one-to-one %correspondence between the representations. These procedures implement the natural one-to-one correspondence between \tupe{exact} and \tupe{inexact} integers throughout an implementation-dependent range. See section~\ref{restrictions}. \end{entry} \medskip \subsection{Numerical input and output} \begin{entry}{% \proto{number->string}{ number}{essential procedure} \proto{number->string}{ number radix}{essential procedure}} \vr{Radix} must be an exact integer, either 2, 8, 10, or 16. If omitted, \vr{radix} defaults to 10. The procedure \ide{number\coerce{}string} takes a number and a radix and returns as a string an external representation of the given number in the given radix such that \begin{scheme} (let ((number \vr{number}) (radix \vr{radix})) (eqv? number (string->number (number->string number radix) radix))) \end{scheme} is true. It is an error if no possible result makes this expression true. If \vr{number} is inexact, the radix is 10, and the above expression can be satisfied by a result that contains a decimal point, then the result contains a decimal point and is expressed using the minimum number of digits (exclusive of exponent and trailing zeroes) needed to make the above expression true~\cite{howtoprint,howtoread}; otherwise the format of the result is unspecified. The result returned by \ide{number\coerce{}string} never contains an explicit radix prefix. \begin{note} The error case can occur only when \vr{number} is not a complex number or is a complex number with a non-rational real or imaginary part. \end{note} \begin{rationale} If \vr{number} is an inexact number represented using flonums, and the radix is 10, then the above expression is normally satisfied by a result containing a decimal point. The unspecified case allows for infinities, NaNs, and non-flonum representations. \end{rationale} \end{entry} \begin{entry}{% \proto{string->number}{ string}{essential procedure} \proto{string->number}{ string radix}{essential procedure}} %%R4%% I didn't include the (string->number string radix exactness) % case, since I haven't heard any resolution of the coding to be used % for the third argument. Returns a number of the maximally precise representation expressed by the given \vr{string}. \vr{Radix} must be an exact integer, either 2, 8, 10, or 16. If supplied, \vr{radix} is a default radix that may be overridden by an explicit radix prefix in \vr{string} (e.g. {\tt "\#o177"}). If \vr{radix} is not supplied, then the default radix is 10. If \vr{string} is not a syntactically valid notation for a number, then \ide{string->number} returns \schfalse{}. \begin{scheme} (string->number "100") \ev 100 (string->number "100" 16) \ev 256 (string->number "1e2") \ev 100.0 (string->number "15\#\#") \ev 1500.0% \end{scheme} \begin{note} Although \ide{string->number} is an essential procedure, an implementation may restrict its domain in the following ways. \ide{String->number} is permitted to return \schfalse{} whenever \vr{string} contains an explicit radix prefix. If all numbers supported by an implementation are real, then \ide{string->number} is permitted to return \schfalse{} whenever \vr{string} uses the polar or rectangular notations for complex numbers. If all numbers are integers, then \ide{string->number} may return \schfalse{} whenever the fractional notation is used. If all numbers are exact, then \ide{string->number} may return \schfalse{} whenever an exponent marker or explicit exactness prefix is used, or if a {\tt \#} appears in place of a digit. If all inexact numbers are integers, then \ide{string->number} may return \schfalse{} whenever a decimal point is used. \end{note} \end{entry} \section{Characters} \label{charactersection} Characters are objects that represent printed characters such as letters and digits. %There is no requirement that the data type of %characters be disjoint from other data types; implementations are %encouraged to have a separate character data type, but may choose to %represent characters as integers, strings, or some other type. Characters are written using the notation \sharpsign\backwhack\hyper{character} or \sharpsign\backwhack\hyper{character name}. For example: $$ \begin{tabular}{ll} {\tt \#\backwhack{}a}&; lower case letter\\ {\tt \#\backwhack{}A}&; upper case letter\\ {\tt \#\backwhack{}(}&; left parenthesis\\ {\tt \#\backwhack{} }&; the space character\\ {\tt \#\backwhack{}space}&; the preferred way to write a space\\ {\tt \#\backwhack{}newline}&; the newline character\\ \end{tabular} $$ Case is significant in \sharpsign\backwhack\hyper{character}, but not in \sharpsign\backwhack\hyper{character name}. If \hyper{character} in \sharpsign\backwhack\hyper{character} is alphabetic, then the character following \hyper{character} must be a delimiter character such as a space or parenthesis. This rule resolves the ambiguous case where, for example, the sequence of characters ``{\tt\sharpsign\backwhack space}'' could be taken to be either a representation of the space character or a representation of the character ``{\tt\sharpsign\backwhack s}'' followed by a representation of the symbol ``{\tt pace}.'' \todo{Fix} Characters written in the \sharpsign\backwhack{} notation are self-evaluating. That is, they do not have to be quoted in programs. %The \sharpsign\backwhack{} %notation is not an essential part of Scheme, however. Even implementations %that support the \sharpsign\backwhack{} notation for input do not have to %support it for output. \vest Some of the procedures that operate on characters ignore the difference between upper case and lower case. The procedures that ignore case have \hbox{``{\tt -ci}''} (for ``case insensitive'') embedded in their names. \begin{entry}{% \proto{char?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is a character, otherwise returns \schfalse. \end{entry} \begin{entry}{% \proto{char=?}{ \vari{char} \varii{char}}{essential procedure} \proto{char?}{ \vari{char} \varii{char}}{essential procedure} \proto{char<=?}{ \vari{char} \varii{char}}{essential procedure} \proto{char>=?}{ \vari{char} \varii{char}}{essential procedure}} \label{characterequality} \nodomain{Both \vari{char} and \varii{char} must be characters.} These procedures impose a total ordering on the set of characters. It is guaranteed that under this ordering: \begin{itemize} \item The upper case characters are in order. For example, {\cf (char?}{ \vari{char} \varii{char}}{essential procedure} \proto{char-ci<=?}{ \vari{char} \varii{char}}{essential procedure} \proto{char-ci>=?}{ \vari{char} \varii{char}}{essential procedure}} \nodomain{Both \vari{char} and \varii{char} must be characters.} These procedures are similar to \ide{char=?}\ et cetera, but they treat upper case and lower case letters as the same. For example, {\cf (char-ci=?\ \#\backwhack{}A \#\backwhack{}a)} returns \schtrue. Some implementations may generalize these procedures to take more than two arguments, as with the corresponding numerical predicates. \end{entry} \begin{entry}{% \proto{char-alphabetic?}{ char}{essential procedure} \proto{char-numeric?}{ char}{essential procedure} \proto{char-whitespace?}{ char}{essential procedure} \proto{char-upper-case?}{ letter}{essential procedure} \proto{char-lower-case?}{ letter}{essential procedure}} These procedures return \schtrue{} if their arguments are alphabetic, numeric, whitespace, upper case, or lower case characters, respectively, otherwise they return \schfalse. The following remarks, which are specific to the ASCII character set, are intended only as a guide: The alphabetic characters are the 52 upper and lower case letters. The numeric characters are the ten decimal digits. The whitespace characters are space, tab, line feed, form feed, and carriage return. \end{entry} %%R4%%\begin{entry}{% %\proto{char-upper-case?}{ letter}{essential procedure} %\proto{char-lower-case?}{ letter}{essential procedure}} % %\domain{\var{Letter} must be an alphabetic character.} %These procedures return \schtrue{} if their arguments are upper case or %lower case characters, respectively, otherwise they return \schfalse. %\end{entry} \begin{entry}{% \proto{char->integer}{ char}{essential procedure} \proto{integer->char}{ \vr{n}}{essential procedure}} Given a character, \ide{char\coerce{}integer} returns an exact integer representation of the character. Given an exact integer that is the image of a character under \ide{char\coerce{}integer}, \ide{integer\coerce{}char} returns that character. These procedures implement injective order isomorphisms between the set of characters under the \ide{char<=?}\ ordering and some subset of the integers under the \ide{<=}\ ordering. That is, if \begin{scheme} (char<=? \vr{a} \vr{b}) \evalsto \schtrue {\rm{}and} % (<= \vr{x} \vr{y}) \evalsto \schtrue% \end{scheme} \noindent and \vr{x} and \vr{y} are in the domain of \ide{integer\coerce{}char}, then \begin{scheme} (<= (char\coerce{}integer \vr{a}) (char\coerce{}integer \vr{b})) \ev \schtrue (char<=? (integer\coerce{}char \vr{x}) (integer\coerce{}char \vr{y})) \ev \schtrue% \end{scheme} \end{entry} \begin{entry}{% \proto{char-upcase}{ char}{essential procedure} \proto{char-downcase}{ char}{essential procedure}} \nodomain{\var{Char} must be a character.} These procedures return a character \varii{char} such that {\cf (char-ci=? \var{char} \varii{char})}. In addition, if \var{char} is alphabetic, then the result of \ide{char-upcase} is upper case and the result of \ide{char-downcase} is lower case. \end{entry} \section{Strings} \label{stringsection} Strings are sequences of characters. %In some implementations of Scheme %they are immutable; other implementations provide destructive procedures %such as \ide{string-set!}\ that alter string objects. \vest Strings are written as sequences of characters enclosed within doublequotes ({\cf "}). A doublequote can be written inside a string only by escaping it with a backslash (\backwhack{}), as in \begin{scheme} "The word \backwhack{}"recursion\backwhack{}" has many meanings."% \end{scheme} A backslash can be written inside a string only by escaping it with another backslash. Scheme does not specify the effect of a backslash within a string that is not followed by a doublequote or backslash. \vest A string constant may continue from one line to the next, but the exact contents of such a string are unspecified. % this is %usually a bad idea because %the exact effect may vary from one computer %system to another. \vest The {\em length} of a string is the number of characters that it contains. This number is a non-negative integer that is fixed when the string is created. The \defining{valid indexes} of a string are the exact non-negative integers less than the length of the string. The first character of a string has index 0, the second has index 1, and so on. \vest In phrases such as ``the characters of \var{string} beginning with index \var{start} and ending with index \var{end},'' it is understood that the index \var{start} is inclusive and the index \var{end} is exclusive. Thus if \var{start} and \var{end} are the same index, a null substring is referred to, and if \var{start} is zero and \var{end} is the length of \var{string}, then the entire string is referred to. \vest Some of the procedures that operate on strings ignore the difference between upper and lower case. The versions that ignore case have \hbox{``{\cf -ci}''} (for ``case insensitive'') embedded in their names. \begin{entry}{% \proto{string?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is a string, otherwise returns \schfalse. \end{entry} \begin{entry}{% \proto{make-string}{ \vr{k}}{essential procedure} \proto{make-string}{ \vr{k} char}{essential procedure}} %\domain{\vr{k} must be a non-negative integer, and \var{char} must be %a character.} \ide{Make-string} returns a newly allocated string of length \vr{k}. If \var{char} is given, then all elements of the string are initialized to \var{char}, otherwise the contents of the \var{string} are unspecified. \end{entry} \begin{entry}{% \proto{string}{ char \dotsfoo}{essential procedure}} Returns a newly allocated string composed of the arguments. \end{entry} \begin{entry}{% \proto{string-length}{ string}{essential procedure}} Returns the number of characters in the given \var{string}. \end{entry} \begin{entry}{% \proto{string-ref}{ string \vr{k}}{essential procedure}} \domain{\vr{k} must be a valid index of \var{string}.} \ide{String-ref} returns character \vr{k} of \var{string} using zero-origin indexing. \end{entry} \begin{entry}{% \proto{string-set!}{ string k char}{essential procedure}} \domain{%\var{String} must be a string, \vr{k} must be a valid index of \var{string}%, and \var{char} must be a character .} \ide{String-set!} stores \var{char} in element \vr{k} of \var{string} and returns an unspecified value. % \begin{scheme} (define (f) (make-string 3 \sharpsign\backwhack{}*)) (define (g) "***") (string-set! (f) 0 \sharpsign\backwhack{}?) \ev \unspecified (string-set! (g) 0 \sharpsign\backwhack{}?) \ev \scherror (string-set! (symbol->string 'immutable) 0 \sharpsign\backwhack{}?) \ev \scherror% \end{scheme} \end{entry} \begin{entry}{% \proto{string=?}{ \vari{string} \varii{string}}{essential procedure} \proto{string-ci=?}{ \vari{string} \varii{string}}{essential procedure}} Returns \schtrue{} if the two strings are the same length and contain the same characters in the same positions, otherwise returns \schfalse. \ide{String-ci=?}\ treats upper and lower case letters as though they were the same character, but \ide{string=?}\ treats upper and lower case as distinct characters. \end{entry} \begin{entry}{% \proto{string?}{ \vari{string} \varii{string}}{essential procedure} \proto{string<=?}{ \vari{string} \varii{string}}{essential procedure} \proto{string>=?}{ \vari{string} \varii{string}}{essential procedure} \proto{string-ci?}{ \vari{string} \varii{string}}{essential procedure} \proto{string-ci<=?}{ \vari{string} \varii{string}}{essential procedure} \proto{string-ci>=?}{ \vari{string} \varii{string}}{essential procedure}} These procedures are the lexicographic extensions to strings of the corresponding orderings on characters. For example, \ide{stringlist}{ string}{essential procedure} \proto{list->string}{ chars}{essential procedure}} \ide{String\coerce{}list} returns a newly allocated list of the characters that make up the given string. \ide{List\coerce{}string} returns a newly allocated string formed from the characters in the list \var{chars}. \ide{String\coerce{}list} and \ide{list\coerce{}string} are inverses so far as \ide{equal?}\ is concerned. %Implementations that provide %destructive operations on strings should ensure that the result of %\ide{list\coerce{}string} is newly allocated. \end{entry} \begin{entry}{% \proto{string-copy}{ string}{procedure}} Returns a newly allocated copy of the given \var{string}. \end{entry} \begin{entry}{% \proto{string-fill!}{ string char}{procedure}} Stores \var{char} in every element of the given \var{string} and returns an unspecified value. % \end{entry} \section{Vectors} \label{vectorsection} Vectors are heterogenous structures whose elements are indexed by integers. A vector typically occupies less space than a list of the same length, and the average time required to access a randomly chosen element is typically less for the vector than for the list. \vest The {\em length} of a vector is the number of elements that it contains. This number is a non-negative integer that is fixed when the vector is created. The {\em valid indexes}\index{valid indexes} of a vector are the exact non-negative integers less than the length of the vector. The first element in a vector is indexed by zero, and the last element is indexed by one less than the length of the vector. Vectors are written using the notation {\tt\#(\var{obj} \dotsfoo)}. For example, a vector of length 3 containing the number zero in element 0, the list {\cf(2 2 2 2)} in element 1, and the string {\cf "Anna"} in element 2 can be written as following: \begin{scheme} \#(0 (2 2 2 2) "Anna")% \end{scheme} Note that this is the external representation of a vector, not an expression evaluating to a vector. Like list constants, vector constants must be quoted: \begin{scheme} '\#(0 (2 2 2 2) "Anna") \lev \#(0 (2 2 2 2) "Anna")% \end{scheme} \todo{Pitman sez: The visual similarity to lists is bound to be confusing to some. Elaborate on the distinction.} \begin{entry}{% \proto{vector?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is a vector, otherwise returns \schfalse. \end{entry} \begin{entry}{% \proto{make-vector}{ k}{essential procedure} \proto{make-vector}{ k fill}{procedure}} Returns a newly allocated vector of \var{k} elements. If a second argument is given, then each element is initialized to \var{fill}. Otherwise the initial contents of each element is unspecified. \end{entry} \begin{entry}{% \proto{vector}{ obj \dotsfoo}{essential procedure}} Returns a newly allocated vector whose elements contain the given arguments. Analogous to \ide{list}. \begin{scheme} (vector 'a 'b 'c) \ev \#(a b c)% \end{scheme} \end{entry} \begin{entry}{% \proto{vector-length}{ vector}{essential procedure}} Returns the number of elements in \var{vector}. \end{entry} \begin{entry}{% \proto{vector-ref}{ vector k}{essential procedure}} \domain{\vr{k} must be a valid index of \var{vector}.} \ide{Vector-ref} returns the contents of element \vr{k} of \var{vector}. \begin{scheme} (vector-ref '\#(1 1 2 3 5 8 13 21) 5) \lev 8 (vector-ref '\#(1 1 2 3 5 8 13 21) (inexact->exact (round (* 2 (acos -1))))) \lev 13% \end{scheme} \end{entry} \begin{entry}{% \proto{vector-set!}{ vector k obj}{essential procedure}} \domain{\vr{k} must be a valid index of \var{vector}.} \ide{Vector-set!} stores \var{obj} in element \vr{k} of \var{vector}. The value returned by \ide{vector-set!}\ is unspecified. % \begin{scheme} (let ((vec (vector 0 '(2 2 2 2) "Anna"))) (vector-set! vec 1 '("Sue" "Sue")) vec) \lev \#(0 ("Sue" "Sue") "Anna") (vector-set! '\#(0 1 2) 1 "doe") \lev \scherror ; constant vector% \end{scheme} \end{entry} \begin{entry}{% \proto{vector->list}{ vector}{essential procedure} \proto{list->vector}{ list}{essential procedure}} \ide{Vector->list} returns a newly allocated list of the objects contained in the elements of \var{vector}. \ide{List->vector} returns a newly created vector initialized to the elements of the list \var{list}. \begin{scheme} (vector->list '\#(dah dah didah)) \lev (dah dah didah) (list->vector '(dididit dah)) \lev \#(dididit dah)% \end{scheme} \end{entry} \begin{entry}{% \proto{vector-fill!}{ vector fill}{procedure}} Stores \var{fill} in every element of \var{vector}. The value returned by \ide{vector-fill!}\ is unspecified. % \end{entry} \section{Control features} \label{proceduresection} % Intro flushed; not very a propos any more. % Procedures should be discussed somewhere, however. This chapter describes various primitive procedures which control the flow of program execution in special ways. The \ide{procedure?}\ predicate is also described here. \todo{{\tt Procedure?} doesn't belong in a section with the name ``control features.'' What to do?} \begin{entry}{% \proto{procedure?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is a procedure, otherwise returns \schfalse. \begin{scheme} (procedure? car) \ev \schtrue (procedure? 'car) \ev \schfalse (procedure? (lambda (x) (* x x))) \ev \schtrue (procedure? '(lambda (x) (* x x))) \ev \schfalse (call-with-current-continuation procedure?) \ev \schtrue% \end{scheme} \end{entry} \begin{entry}{% \proto{apply}{ proc args}{essential procedure} \proto{apply}{ proc \vari{arg} $\ldots$ args}{procedure}} \domain{\var{Proc} must be a procedure and \var{args} must be a list.} The first (essential) form calls \var{proc} with the elements of \var{args} as the actual arguments. The second form is a generalization of the first that calls \var{proc} with the elements of the list {\cf(append (list \vari{arg} \dotsfoo) \var{args})} as the actual arguments. \begin{scheme} (apply + (list 3 4)) \ev 7 (define compose (lambda (f g) (lambda args (f (apply g args))))) ((compose sqrt *) 12 75) \ev 30% \end{scheme} \end{entry} \begin{entry}{% \proto{map}{ proc \vari{list} \varii{list} \dotsfoo}{essential procedure}} \domain{The \var{list}s must be lists, and \var{proc} must be a procedure taking as many arguments as there are {\it list}s. If more than one \var{list} is given, then they must all be the same length.} \ide{Map} applies \var{proc} element-wise to the elements of the \var{list}s and returns a list of the results, in order from left to right. The dynamic order in which \var{proc} is applied to the elements of the \var{list}s is unspecified. \begin{scheme} (map cadr '((a b) (d e) (g h))) \lev (b e h) (map (lambda (n) (expt n n)) '(1 2 3 4 5)) \lev (1 4 27 256 3125) (map + '(1 2 3) '(4 5 6)) \ev (5 7 9) (let ((count 0)) (map (lambda (ignored) (set! count (+ count 1)) count) '(a b c))) \ev \unspecified% \end{scheme} \end{entry} \begin{entry}{% \proto{for-each}{ proc \vari{list} \varii{list} \dotsfoo}{essential procedure}} The arguments to \ide{for-each} are like the arguments to \ide{map}, but \ide{for-each} calls \var{proc} for its side effects rather than for its values. Unlike \ide{map}, \ide{for-each} is guaranteed to call \var{proc} on the elements of the \var{list}s in order from the first element to the last, and the value returned by \ide{for-each} is unspecified. \begin{scheme} (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v) \ev \#(0 1 4 9 16)% \end{scheme} \end{entry} \begin{entry}{% \proto{force}{ promise}{procedure}} Forces the value of \var{promise} (see \ide{delay}, section~\ref{delay}).\index{promise} If no value has been computed for the promise, then a value is computed and returned. The value of the promise is cached (or ``memoized'') so that if it is forced a second time, the previously computed value is returned. % without any recomputation. % [As pointed out by Marc Feeley, the "without any recomputation" % isn't necessarily true. --Will] \begin{scheme} (force (delay (+ 1 2))) \ev 3 (let ((p (delay (+ 1 2)))) (list (force p) (force p))) \ev (3 3) (define a-stream (letrec ((next (lambda (n) (cons n (delay (next (+ n 1))))))) (next 0))) (define head car) (define tail (lambda (stream) (force (cdr stream)))) (head (tail (tail a-stream))) \ev 2% \end{scheme} \ide{Force} and \ide{delay} are mainly intended for programs written in functional style. The following examples should not be considered to illustrate good programming style, but they illustrate the property that only one value is computed for a promise, no matter how many times it is forced. % the value of a promise is computed at most once. % [As pointed out by Marc Feeley, it may be computed more than once, % but as I observed we can at least insist that only one value be % used! -- Will] \begin{scheme} (define count 0) (define p (delay (begin (set! count (+ count 1)) (if (> count x) count (force p))))) (define x 5) p \ev {\it{}a promise} (force p) \ev 6 p \ev {\it{}a promise, still} (begin (set! x 10) (force p)) \ev 6% \end{scheme} Here is a possible implementation of \ide{delay} and \ide{force}. Promises are implemented here as procedures of no arguments, and \ide{force} simply calls its argument: \begin{scheme} (define force (lambda (object) (object)))% \end{scheme} We define the expression \begin{scheme} (delay \hyper{expression})% \end{scheme} to have the same meaning as the procedure call \begin{scheme} (make-promise (lambda () \hyper{expression}))\rm,% \end{scheme} where \ide{make-promise} is defined as follows: % \begin{scheme} % (define make-promise % (lambda (proc) % (let ((already-run? \schfalse) (result \schfalse)) % (lambda () % (cond ((not already-run?) % (set! result (proc)) % (set! already-run? \schtrue))) % result))))% % \end{scheme} \begin{scheme} (define make-promise (lambda (proc) (let ((result-ready? \schfalse) (result \schfalse)) (lambda () (if result-ready? result (let ((x (proc))) (if result-ready? result (begin (set! result-ready? \schtrue) (set! result x) result))))))))% \end{scheme} \begin{rationale} A promise may refer to its own value, as in the last example above. Forcing such a promise may cause the promise to be forced a second time before the value of the first force has been computed. This complicates the definition of \ide{make-promise}. \end{rationale} Various extensions to this semantics of \ide{delay} and \ide{force} are supported in some implementations: \begin{itemize} \item Calling \ide{force} on an object that is not a promise may simply return the object. \item It may be the case that there is no means by which a promise can be operationally distinguished from its forced value. That is, expressions like the following may evaluate to either \schtrue{} or to \schfalse{}, depending on the implementation: \begin{scheme} (eqv? (delay 1) 1) \ev \unspecified (pair? (delay (cons 1 2))) \ev \unspecified% \end{scheme} \item Some implementations may implement ``implicit forcing,'' where the value of a promise is forced by primitive procedures like \ide{cdr} and \ide{+}: \begin{scheme} (+ (delay (* 3 7)) 13) \ev 34% \end{scheme} \end{itemize} \end{entry} \begin{entry}{% \proto{call-with-current-continuation}{ proc}{essential procedure}} \label{continuations} \domain{\var{Proc} must be a procedure of one argument.} The procedure \ide{call-with-current-continuation} packages up the current continuation (see the rationale below) as an ``escape procedure''\mainindex{escape procedure} and passes it as an argument to \var{proc}. The escape procedure is a Scheme procedure of one argument that, if it is later passed a value, will ignore whatever continuation is in effect at that later time and will give the value instead to the continuation that was in effect when the escape procedure was created. \vest The escape procedure that is passed to \var{proc} has unlimited extent just like any other procedure in Scheme. It may be stored in variables or data structures and may be called as many times as desired. \vest The following examples show only the most common uses of \ide{call-with-current-continuation}. If all real programs were as simple as these examples, there would be no need for a procedure with the power of \ide{call-with-current-continuation}. \begin{scheme} (call-with-current-continuation (lambda (exit) (for-each (lambda (x) (if (negative? x) (exit x))) '(54 0 37 -3 245 19)) \schtrue)) \ev -3 (define list-length (lambda (obj) (call-with-current-continuation (lambda (return) (letrec ((r (lambda (obj) (cond ((null? obj) 0) ((pair? obj) (+ (r (cdr obj)) 1)) (else (return \schfalse)))))) (r obj)))))) (list-length '(1 2 3 4)) \ev 4 (list-length '(a b . c)) \ev \schfalse% \end{scheme} \begin{rationale} \vest A common use of \ide{call-with-current-continuation} is for structured, non-local exits from loops or procedure bodies, but in fact \ide{call-with-current-continuation} is extremely useful for implementing a wide variety of advanced control structures. \vest Whenever a Scheme expression is evaluated there is a \defining{continuation} wanting the result of the expression. The continuation represents an entire (default) future for the computation. If the expression is evaluated at top level, for example, then the continuation might take the result, print it on the screen, prompt for the next input, evaluate it, and so on forever. Most of the time the continuation includes actions specified by user code, as in a continuation that will take the result, multiply it by the value stored in a local variable, add seven, and give the answer to the top level continuation to be printed. Normally these ubiquitous continuations are hidden behind the scenes and programmers don't think much about them. On rare occasions, however, a programmer may need to deal with continuations explicitly. \ide{Call-with-current-continuation} allows Scheme programmers to do that by creating a procedure that acts just like the current continuation. \vest Most programming languages incorporate one or more special-purpose escape constructs with names like {\tt exit}, \hbox{\ide{return}}, or even {\tt goto}. In 1965, however, Peter Landin~\cite{Landin65} invented a general purpose escape operator called the J-operator. John Reynolds~\cite{Reynolds72} described a simpler but equally powerful construct in 1972. The \ide{catch} special form described by Sussman and Steele in the 1975 report on Scheme is exactly the same as Reynolds's construct, though its name came from a less general construct in MacLisp. Several Scheme implementors noticed that the full power of the \ide{catch} construct could be provided by a procedure instead of by a special syntactic construct, and the name \ide{call-with-current-continuation} was coined in 1982. This name is descriptive, but opinions differ on the merits of such a long name, and some people use the name \ide{call/cc} instead. \end{rationale} \end{entry} \section{Input and output} \subsection{Ports} \label{portsection} Ports represent input and output devices. To Scheme, an input port is a Scheme object that can deliver characters upon command, while an output port is a Scheme object that can accept characters. \mainindex{port} \todo{Haase: Mention that there are alternatives to files?} \begin{entry}{% \proto{call-with-input-file}{ string proc}{essential procedure} \proto{call-with-output-file}{ string proc}{essential procedure}} \domain{\var{Proc} should be a procedure of one argument, and \var{string} should be a string naming a file. For \ide{call-with-input-file}, the file must already exist; for \ide{call-with-output-file}, the effect is unspecified if the file already exists.} These procedures call \var{proc} with one argument: the port obtained by opening the named file for input or output. If the file cannot be opened, an error is signalled. If the procedure returns, then the port is closed automatically and the value yielded by the procedure is returned. If the procedure does not return, then the port will not be closed automatically unless it is possible to prove that the port will never again be used for a read or write operation. %Scheme %will not close the port unless it can prove that the port will never %again be used for a read or write operation. \begin{rationale} Because Scheme's escape procedures have unlimited extent, it is possible to escape from the current continuation but later to escape back in. If implementations were permitted to close the port on any escape from the current continuation, then it would be impossible to write portable code using both \ide{call-with-current-continuation} and \ide{call-with-input-file} or \ide{call-with-output-file}. \todo{Pitman wants more said here; maybe encourage users to call {\tt close-foo-port}; maybe talk about process switches (?).} \end{rationale} \end{entry} \begin{entry}{% \proto{input-port?}{ obj}{essential procedure} \proto{output-port?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is an input port or output port respectively, otherwise returns \schfalse. \todo{Won't necessarily return true after port is closed.} \end{entry} \begin{entry}{% \proto{current-input-port}{}{essential procedure} \proto{current-output-port}{}{essential procedure}} Returns the current default input or output port. \end{entry} \begin{entry}{% \proto{with-input-from-file}{ string thunk}{procedure} \proto{with-output-to-file}{ string thunk}{procedure}} \domain{\var{Thunk} must be a procedure of no arguments, and \var{string} must be a string naming a file. For \ide{with-input-from-file}, the file must already exist; for \ide{with-output-to-file}, the effect is unspecified if the file already exists.} The file is opened for input or output, an input or output port connected to it is made the default value returned by \ide{current-input-port} or \ide{current-output-port}, and the \var{thunk} is called with no arguments. When the \var{thunk} returns, the port is closed and the previous default is restored. \ide{With-input-from-file} and \ide{with-output-to-file} return the value yielded by \var{thunk}. If an escape procedure is used to escape from the continuation of these procedures, their behavior is implementation dependent. \todo{Kelsey sez he'd hate to try to implement this.} \todo{OK this with authors??} %current continuation changes in such a way %as to make it doubtful that the \var{thunk} will ever return. \todo{Freeman: Throughout this section I wanted to see ``the value of {\tt(current-input-port)}'' instead of ``the value returned by {\tt current-input-port}''. (Same for {\tt current-output-port}.)} \end{entry} \begin{entry}{% \proto{open-input-file}{ filename}{essential procedure}} Takes a string naming an existing file and returns an input port capable of delivering characters from the file. If the file cannot be opened, an error is signalled. \end{entry} \begin{entry}{% \proto{open-output-file}{ filename}{essential procedure}} Takes a string naming an output file to be created and returns an output port capable of writing characters to a new file by that name. If the file cannot be opened, an error is signalled. If a file with the given name already exists, the effect is unspecified. \end{entry} \begin{entry}{% \proto{close-input-port}{ port}{essential procedure} \proto{close-output-port}{ port}{essential procedure}} Closes the file associated with \var{port}, rendering the \var{port} incapable of delivering or accepting characters. \todo{But maybe a no-op on some ports, e.g. terminals or editor buffers.} These routines have no effect if the file has already been closed. The value returned is unspecified. \todo{Ramsdell: Some note is needed explaining why there are two different close procedures.} \todo{A port isn't necessarily still a port after it has been closed?} \end{entry} \subsection{Input} \label{inputsection} \noindent \hbox{ } %??? \vspace{-5ex} \todo{The input routines have some things in common, maybe explain here.} \begin{entry}{% \proto{read}{}{essential procedure} \proto{read}{ port}{essential procedure}} \ide{Read} converts external representations of Scheme objects into the objects themselves. That is, it is a parser for the nonterminal \meta{datum} (see sections~\ref{datum} and \ref{listsection}). \ide{Read} returns the next object parsable from the given input \var{port}, updating \var{port} to point to the first character past the end of the external representation of the object. \vest If an end of file is encountered in the input before any characters are found that can begin an object, then an end of file object is returned. \todo{} The port remains open, and further attempts to read will also return an end of file object. If an end of file is encountered after the beginning of an object's external representation, but the external representation is incomplete and therefore not parsable, an error is signalled. The \var{port} argument may be omitted, in which case it defaults to the value returned by \ide{current-input-port}. It is an error to read from a closed port. \end{entry} \begin{entry}{% \proto{read-char}{}{essential procedure} \proto{read-char}{ port}{essential procedure}} Returns the next character available from the input \var{port}, updating the \var{port} to point to the following character. If no more characters are available, an end of file object is returned. \var{Port} may be omitted, in which case it defaults to the value returned by \ide{current-input-port}. \end{entry} \begin{entry}{% \proto{peek-char}{}{essential procedure} \proto{peek-char}{ port}{essential procedure}} Returns the next character available from the input \var{port}, {\em without} updating the \var{port} to point to the following character. If no more characters are available, an end of file object is returned. \var{Port} may be omitted, in which case it defaults to the value returned by \ide{current-input-port}. \begin{note} The value returned by a call to \ide{peek-char} is the same as the value that would have been returned by a call to \ide{read-char} with the same \var{port}. The only difference is that the very next call to \ide{read-char} or \ide{peek-char} on that \var{port} will return the value returned by the preceding call to \ide{peek-char}. In particular, a call to \ide{peek-char} on an interactive port will hang waiting for input whenever a call to \ide{read-char} would have hung. \end{note} \end{entry} \begin{entry}{% \proto{eof-object?}{ obj}{essential procedure}} Returns \schtrue{} if \var{obj} is an end of file object, otherwise returns \schfalse. The precise set of end of file objects will vary among implementations, but in any case no end of file object will ever be an object that can be read in using \ide{read}. \end{entry} \begin{entry}{% \proto{char-ready?}{}{procedure} \proto{char-ready?}{ port}{procedure}} Returns \schtrue{} if a character is ready on the input \var{port} and returns \schfalse{} otherwise. If \ide{char-ready} returns \schtrue{} then the next \ide{read-char} operation on the given \var{port} is guaranteed not to hang. If the \var{port} is at end of file then \ide{char-ready?}\ returns \schtrue. \var{Port} may be omitted, in which case it defaults to the value returned by \ide{current-input-port}. \begin{rationale} \ide{Char-ready?}\ exists to make it possible for a program to accept characters from interactive ports without getting stuck waiting for input. Any input editors associated with such ports must ensure that characters whose existence has been asserted by \ide{char-ready?}\ cannot be rubbed out. If \ide{char-ready?}\ were to return \schfalse{} at end of file, a port at end of file would be indistinguishable from an interactive port that has no ready characters. \end{rationale} \end{entry} \subsection{Output} \label{outputsection} % We've got to put something here to fix the indentation!! \noindent \hbox{} \vspace{-5ex} \begin{entry}{% \proto{write}{ obj}{essential procedure} \proto{write}{ obj port}{essential procedure}} Writes a written representation of \var{obj} to the given \var{port}. Strings that appear in the written representation are enclosed in doublequotes, and within those strings backslash and doublequote characters are escaped by backslashes. \ide{Write} returns an unspecified value. The \var{port} argument may be omitted, in which case it defaults to the value returned by \ide{current-output-port}. \end{entry} \begin{entry}{% \proto{display}{ obj}{essential procedure} \proto{display}{ obj port}{essential procedure}} Writes a representation of \var{obj} to the given \var{port}. Strings that appear in the written representation are not enclosed in doublequotes, and no characters are escaped within those strings. Character objects appear in the representation as if written by \ide{write-char} instead of by \ide{write}. \ide{Display} returns an unspecified value. The \var{port} argument may be omitted, in which case it defaults to the value returned by \ide{current-output-port}. \begin{rationale} \ide{Write} is intended for producing mach\-ine-readable output and \ide{display} is for producing human-readable output. Implementations that allow ``slashification'' within symbols will probably want \ide{write} but not \ide{display} to slashify funny characters in symbols. \end{rationale} \end{entry} \begin{entry}{% \proto{newline}{}{essential procedure} \proto{newline}{ port}{essential procedure}} Writes an end of line to \var{port}. Exactly how this is done differs from one operating system to another. Returns an unspecified value. The \var{port} argument may be omitted, in which case it defaults to the value returned by \ide{current-output-port}. \end{entry} \begin{entry}{% \proto{write-char}{ char}{essential procedure} \proto{write-char}{ char port}{essential procedure}} Writes the character \var{char} (not an external representation of the character) to the given \var{port} and returns an unspecified value. The \var{port} argument may be omitted, in which case it defaults to the value returned by \ide{current-output-port}. \end{entry} \subsection{System interface} Questions of system interface generally fall outside of the domain of this report. However, the following operations are important enough to deserve description here. \begin{entry}{% \proto{load}{ filename}{essential procedure}} \todo{Fix} \domain{\var{Filename} should be a string naming an existing file containing Scheme source code.} The \ide{load} procedure reads expressions and definitions from the file and evaluates them sequentially. It is unspecified whether the results of the expressions are printed. The \ide{load} procedure does not affect the values returned by \ide{current-input-port} and \ide{current-output-port}. \ide{Load} returns an unspecified value. \begin{rationale} For portability, \ide{load} must operate on source files. Its operation on other kinds of files necessarily varies among implementations. \end{rationale} \end{entry} \begin{entry}{% \proto{transcript-on}{ filename}{procedure}\nopagebreak{} \proto{transcript-off}{}{procedure}} \domain{\var{Filename} must be a string naming an output file to be created.} The effect of \ide{transcript-on} is to open the named file for output, and to cause a transcript of subsequent interaction between the user and the Scheme system to be written to the file. The transcript is ended by a call to \ide{transcript-off}, which closes the transcript file. Only one transcript may be in progress at any time, though some implementations may relax this restriction. The values returned by these procedures are unspecified. %\begin{note} %These procedures are redundant in some systems, but %systems that need them should provide them. %\end{note} \end{entry} scheme2c-2012.10.14/doc/r4rs/prog.tex000066400000000000000000000112631203736146400167340ustar00rootroot00000000000000\chapter{Program structure} \label{programchapter} \section{Programs} A Scheme program consists of a sequence of expressions and definitions. Expressions are described in chapter~\ref{expressionchapter}; definitions are the subject of the rest of the present chapter. Programs are typically stored in files or entered interactively to a running Scheme system, although other paradigms are possible; questions of user interface lie outside the scope of this report. (Indeed, Scheme would still be useful as a notation for expressing computational methods even in the absence of a mechanical implementation.) Definitions occurring at the top level of a program can be interpreted declaratively. They cause bindings to be created in the top level environment. Expressions occurring at the top level of a program are interpreted imperatively; they are executed in order when the program is invoked or loaded, and typically perform some kind of initialization. \todo{Cromarty, etc.: disclaimer about top level?} \section{Definitions} Definitions are valid in some, but not all, contexts where expressions are allowed. They are valid only at the top level of a \hyper{program} and, in some implementations, at the beginning of a \hyper{body}. \mainindex{definition} A definition should have one of the following forms:\mainschindex{define} \begin{itemize} \item {\tt(define \hyper{variable} \hyper{expression})} This syntax is essential. \item{\tt(define (\hyper{variable} \hyper{formals}) \hyper{body})} This syntax is not essential. \hyper{Formals} should be either a sequence of zero or more variables, or a sequence of one or more variables followed by a space-delimited period and another variable (as in a lambda expression). This form is equivalent to \begin{scheme} (define \hyper{variable} (lambda (\hyper{formals}) \hyper{body}))\rm.% \end{scheme} \item{\tt(define (\hyper{variable} .\ \hyper{formal}) \hyper{body})} This syntax is not essential. \hyper{Formal} should be a single variable. This form is equivalent to \begin{scheme} (define \hyper{variable} (lambda \hyper{formal} \hyper{body}))\rm.% \end{scheme} \item {\tt(begin \hyperi{definition} \dotsfoo)} This syntax is essential. This form is equivalent to the set of definitions that form the body of the \ide{begin}. \end{itemize} \subsection{Top level definitions} At the top level of a program, a definition \begin{scheme} (define \hyper{variable} \hyper{expression})% \end{scheme} has essentially the same effect as the assignment expression \begin{scheme} (\ide{set!}\ \hyper{variable} \hyper{expression})% \end{scheme} if \hyper{variable} is bound. If \hyper{variable} is not bound, however, then the definition will bind \hyper{variable} to a new location before performing the assignment, whereas it would be an error to perform a \ide{set!}\ on an unbound\index{unbound} variable. \begin{scheme} (define add3 (lambda (x) (+ x 3))) (add3 3) \ev 6 (define first car) (first '(1 2)) \ev 1% \end{scheme} All Scheme implementations must support top level definitions. Some implementations of Scheme use an initial environment in which all possible variables are bound to locations, most of which contain undefined values. Top level definitions in such an implementation are truly equivalent to assignments. \todo{Rozas: equal time for opposition semantics?} \subsection{Internal definitions} \label{internaldefines} Some implementations of Scheme permit definitions to occur at the beginning of a \hyper{body} (that is, the body of a \ide{lambda}, \ide{let}, \ide{let*}, \ide{letrec}, or \ide{define} expression). Such definitions are known as {\em internal definitions} \mainindex{internal definition} as opposed to the top level definitions described above. The variable defined by an internal definition is local to the \hyper{body}. That is, \hyper{variable} is bound rather than assigned, and the region of the binding is the entire \hyper{body}. For example, \begin{scheme} (let ((x 5)) (define foo (lambda (y) (bar x y))) (define bar (lambda (a b) (+ (* a b) a))) (foo (+ x 3))) \ev 45% \end{scheme} A \hyper{body} containing internal definitions can always be converted into a completely equivalent \ide{letrec} expression. For example, the \ide{let} expression in the above example is equivalent to \begin{scheme} (let ((x 5)) (letrec ((foo (lambda (y) (bar x y))) (bar (lambda (a b) (+ (* a b) a)))) (foo (+ x 3))))% \end{scheme} Just as for the equivalent \ide{letrec} expression, it must be possible to evaluate each \hyper{expression} of every internal definition in a \hyper{body} without assigning or referring to the value of any \hyper{variable} being defined. scheme2c-2012.10.14/doc/r4rs/r4rs.aux000066400000000000000000000515351203736146400166620ustar00rootroot00000000000000\relax \citation{Scheme75} \citation{Scheme78} \citation{Rabbit} \citation{Rees82,MITScheme,Scheme311} \citation{SICP} \citation{RRRS} \citation{R3RS} \@writefile{toc}{\string\contentsline\space {chapter}{Introduction}{2}} \newlabel{historysection}{{}{2}} \@writefile{toc}{\string\contentsline\space {chapter}{\string\numberline\space {1}Overview of Scheme}{3}} \@writefile{lof}{\string\addvspace\space {10pt}} \@writefile{lot}{\string\addvspace\space {10pt}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {1.1}Semantics}{3}} \newlabel{semanticsection}{{1.1}{3}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {1.2}Syntax}{3}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {1.3}Notation and terminology}{3}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {1.3.1}Essential and non-essential features}{3}} \newlabel{essentialsection}{{1.3.1}{3}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {1.3.2}Error situations and unspecified behavior}{3}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {1.3.3}Entry format}{4}} \newlabel{typeconventions}{{1.3.3}{4}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {1.3.4}Evaluation examples}{4}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {1.3.5}Naming conventions}{4}} \@writefile{toc}{\string\contentsline\space {chapter}{\string\numberline\space {2}Lexical conventions}{5}} \@writefile{lof}{\string\addvspace\space {10pt}} \@writefile{lot}{\string\addvspace\space {10pt}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {2.1}Identifiers}{5}} \newlabel{syntaxsection}{{2.1}{5}} \newlabel{keywordsection}{{2.1}{5}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {2.2}Whitespace and comments}{5}} \newlabel{;}{{2.2}{5}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {2.3}Other notations}{5}} \@writefile{toc}{\string\contentsline\space {chapter}{\string\numberline\space {3}Basic concepts}{6}} \@writefile{lof}{\string\addvspace\space {10pt}} \@writefile{lot}{\string\addvspace\space {10pt}} \newlabel{basicchapter}{{3}{6}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {3.1}Variables and regions}{6}} \newlabel{specialformsection}{{3.1}{6}} \newlabel{variablesection}{{3.1}{6}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {3.2}True and false}{6}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {3.3}External representations}{6}} \newlabel{externalreps}{{3.3}{6}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {3.4}Disjointness of types}{7}} \newlabel{disjointness}{{3.4}{7}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {3.5}Storage model}{7}} \newlabel{storagemodel}{{3.5}{7}} \@writefile{toc}{\string\contentsline\space {chapter}{\string\numberline\space {4}Expressions}{7}} \@writefile{lof}{\string\addvspace\space {10pt}} \@writefile{lot}{\string\addvspace\space {10pt}} \newlabel{expressionchapter}{{4}{7}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {4.1}Primitive expression types}{7}} \newlabel{primitivexps}{{4.1}{7}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.1.1}Variable references}{7}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.1.2}Literal expressions}{7}} \newlabel{literalsection}{{4.1.2}{7}} \newlabel{quote}{{4.1.2}{7}} \newlabel{'}{{4.1.2}{7}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.1.3}Procedure calls}{8}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.1.4}Lambda expression{}s}{8}} \newlabel{lamba}{{4.1.4}{8}} \newlabel{lambda}{{4.1.4}{8}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.1.5}Conditionals}{8}} \newlabel{if}{{4.1.5}{8}} \newlabel{if}{{4.1.5}{8}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.1.6}Assignments}{9}} \newlabel{set!}{{4.1.6}{9}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {4.2}Derived expression types}{9}} \newlabel{derivedexps}{{4.2}{9}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.2.1}Conditionals}{9}} \newlabel{cond}{{4.2.1}{9}} \newlabel{else}{{4.2.1}{9}} \newlabel{=>}{{4.2.1}{9}} \newlabel{case}{{4.2.1}{9}} \newlabel{and}{{4.2.1}{9}} \newlabel{or}{{4.2.1}{9}} \citation{SICP} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.2.2}Binding constructs}{10}} \newlabel{let}{{4.2.2}{10}} \newlabel{let*}{{4.2.2}{10}} \newlabel{letrec}{{4.2.2}{10}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.2.3}Sequencing}{10}} \newlabel{begin}{{4.2.3}{10}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.2.4}Iteration}{11}} \newlabel{do}{{4.2.4}{11}} \newlabel{let}{{4.2.4}{11}} \newlabel{namedlet}{{4.2.4}{11}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.2.5}Delayed evaluation}{11}} \newlabel{delay}{{4.2.5}{11}} \newlabel{delay}{{4.2.5}{11}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {4.2.6}Quasiquotation}{11}} \newlabel{quasiquotesection}{{4.2.6}{11}} \newlabel{quasiquote}{{4.2.6}{11}} \newlabel{,}{{4.2.6}{11}} \newlabel{`}{{4.2.6}{12}} \@writefile{toc}{\string\contentsline\space {chapter}{\string\numberline\space {5}Program structure}{12}} \@writefile{lof}{\string\addvspace\space {10pt}} \@writefile{lot}{\string\addvspace\space {10pt}} \newlabel{programchapter}{{5}{12}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {5.1}Programs}{12}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {5.2}Definitions}{12}} \newlabel{define}{{5.2}{12}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {5.2.1}Top level definitions}{12}} \citation{IEEEScheme} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {5.2.2}Internal definitions}{13}} \newlabel{internaldefines}{{5.2.2}{13}} \@writefile{toc}{\string\contentsline\space {chapter}{\string\numberline\space {6}Standard procedures}{13}} \@writefile{lof}{\string\addvspace\space {10pt}} \@writefile{lot}{\string\addvspace\space {10pt}} \newlabel{initialenv}{{6}{13}} \newlabel{builtinchapter}{{6}{13}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.1}Booleans}{13}} \newlabel{booleansection}{{6.1}{13}} \newlabel{not}{{6.1}{13}} \newlabel{boolean?}{{6.1}{13}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.2}Equivalence predicates}{13}} \newlabel{equivalencesection}{{6.2}{13}} \newlabel{eqv?}{{6.2}{13}} \newlabel{eq?}{{6.2}{15}} \newlabel{equal?}{{6.2}{15}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.3}Pairs and lists}{15}} \newlabel{listsection}{{6.3}{15}} \newlabel{pair?}{{6.3}{16}} \newlabel{cons}{{6.3}{16}} \newlabel{car}{{6.3}{16}} \newlabel{cdr}{{6.3}{16}} \newlabel{set-car!}{{6.3}{16}} \newlabel{set-cdr!}{{6.3}{16}} \newlabel{caar}{{6.3}{16}} \newlabel{cadr}{{6.3}{16}} \newlabel{cdddar}{{6.3}{16}} \newlabel{cddddr}{{6.3}{16}} \newlabel{null?}{{6.3}{16}} \newlabel{list?}{{6.3}{16}} \newlabel{list}{{6.3}{17}} \newlabel{length}{{6.3}{17}} \newlabel{append}{{6.3}{17}} \newlabel{reverse}{{6.3}{17}} \newlabel{list-tail}{{6.3}{17}} \newlabel{list-ref}{{6.3}{17}} \newlabel{memq}{{6.3}{17}} \newlabel{memv}{{6.3}{17}} \newlabel{member}{{6.3}{17}} \newlabel{assq}{{6.3}{17}} \newlabel{assv}{{6.3}{17}} \newlabel{assoc}{{6.3}{17}} \citation{Pitman83} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.4}Symbols}{18}} \newlabel{symbolsection}{{6.4}{18}} \newlabel{symbol?}{{6.4}{18}} \newlabel{symbol->string}{{6.4}{18}} \newlabel{string->symbol}{{6.4}{18}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.5}Numbers}{18}} \newlabel{numbersection}{{6.5}{18}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.5.1}Numerical types}{19}} \newlabel{numericaltypes}{{6.5.1}{19}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.5.2}Exactness}{19}} \newlabel{exactly}{{6.5.2}{19}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.5.3}Implementation restrictions}{19}} \newlabel{restrictions}{{6.5.3}{19}} \citation{IEEE} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.5.4}Syntax of numerical constants}{20}} \newlabel{numbernotations}{{6.5.4}{20}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.5.5}Numerical operations}{20}} \newlabel{number?}{{6.5.5}{20}} \newlabel{complex?}{{6.5.5}{20}} \newlabel{real?}{{6.5.5}{20}} \newlabel{rational?}{{6.5.5}{20}} \newlabel{integer?}{{6.5.5}{20}} \newlabel{exact?}{{6.5.5}{21}} \newlabel{inexact?}{{6.5.5}{21}} \newlabel{=}{{6.5.5}{21}} \newlabel{<}{{6.5.5}{21}} \newlabel{>}{{6.5.5}{21}} \newlabel{<=}{{6.5.5}{21}} \newlabel{>=}{{6.5.5}{21}} \newlabel{zero?}{{6.5.5}{21}} \newlabel{positive?}{{6.5.5}{21}} \newlabel{negative?}{{6.5.5}{21}} \newlabel{odd?}{{6.5.5}{21}} \newlabel{even?}{{6.5.5}{21}} \newlabel{max}{{6.5.5}{21}} \newlabel{min}{{6.5.5}{21}} \newlabel{+}{{6.5.5}{21}} \newlabel{*}{{6.5.5}{21}} \newlabel{-}{{6.5.5}{21}} \newlabel{-}{{6.5.5}{21}} \newlabel{-}{{6.5.5}{21}} \newlabel{/}{{6.5.5}{21}} \newlabel{/}{{6.5.5}{21}} \newlabel{/}{{6.5.5}{21}} \newlabel{abs}{{6.5.5}{21}} \newlabel{quotient}{{6.5.5}{22}} \newlabel{remainder}{{6.5.5}{22}} \newlabel{modulo}{{6.5.5}{22}} \newlabel{gcd}{{6.5.5}{22}} \newlabel{lcm}{{6.5.5}{22}} \newlabel{numerator}{{6.5.5}{22}} \newlabel{denominator}{{6.5.5}{22}} \newlabel{floor}{{6.5.5}{22}} \newlabel{ceiling}{{6.5.5}{22}} \newlabel{truncate}{{6.5.5}{22}} \newlabel{round}{{6.5.5}{22}} \newlabel{rationalize}{{6.5.5}{22}} \citation{CLtL} \citation{Penfield81} \citation{howtoprint,howtoread} \newlabel{exp}{{6.5.5}{23}} \newlabel{log}{{6.5.5}{23}} \newlabel{sin}{{6.5.5}{23}} \newlabel{cos}{{6.5.5}{23}} \newlabel{tan}{{6.5.5}{23}} \newlabel{asin}{{6.5.5}{23}} \newlabel{acos}{{6.5.5}{23}} \newlabel{atan}{{6.5.5}{23}} \newlabel{atan}{{6.5.5}{23}} \newlabel{sqrt}{{6.5.5}{23}} \newlabel{expt}{{6.5.5}{23}} \newlabel{make-rectangular}{{6.5.5}{23}} \newlabel{make-polar}{{6.5.5}{23}} \newlabel{real-part}{{6.5.5}{23}} \newlabel{imag-part}{{6.5.5}{23}} \newlabel{magnitude}{{6.5.5}{23}} \newlabel{angle}{{6.5.5}{23}} \newlabel{exact->inexact}{{6.5.5}{23}} \newlabel{inexact->exact}{{6.5.5}{23}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.5.6}Numerical input and output}{23}} \newlabel{number->string}{{6.5.6}{23}} \newlabel{number->string}{{6.5.6}{23}} \newlabel{string->number}{{6.5.6}{24}} \newlabel{string->number}{{6.5.6}{24}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.6}Characters}{24}} \newlabel{charactersection}{{6.6}{24}} \newlabel{char?}{{6.6}{24}} \newlabel{char=?}{{6.6}{24}} \newlabel{char?}{{6.6}{24}} \newlabel{char<=?}{{6.6}{24}} \newlabel{char>=?}{{6.6}{24}} \newlabel{characterequality}{{6.6}{24}} \newlabel{char-ci=?}{{6.6}{25}} \newlabel{char-ci?}{{6.6}{25}} \newlabel{char-ci<=?}{{6.6}{25}} \newlabel{char-ci>=?}{{6.6}{25}} \newlabel{char-alphabetic?}{{6.6}{25}} \newlabel{char-numeric?}{{6.6}{25}} \newlabel{char-whitespace?}{{6.6}{25}} \newlabel{char-upper-case?}{{6.6}{25}} \newlabel{char-lower-case?}{{6.6}{25}} \newlabel{char->integer}{{6.6}{25}} \newlabel{integer->char}{{6.6}{25}} \newlabel{char-upcase}{{6.6}{25}} \newlabel{char-downcase}{{6.6}{25}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.7}Strings}{25}} \newlabel{stringsection}{{6.7}{25}} \newlabel{string?}{{6.7}{25}} \newlabel{make-string}{{6.7}{25}} \newlabel{make-string}{{6.7}{25}} \newlabel{string}{{6.7}{25}} \newlabel{string-length}{{6.7}{25}} \newlabel{string-ref}{{6.7}{25}} \newlabel{string-set!}{{6.7}{26}} \newlabel{string=?}{{6.7}{26}} \newlabel{string-ci=?}{{6.7}{26}} \newlabel{string?}{{6.7}{26}} \newlabel{string<=?}{{6.7}{26}} \newlabel{string>=?}{{6.7}{26}} \newlabel{string-ci?}{{6.7}{26}} \newlabel{string-ci<=?}{{6.7}{26}} \newlabel{string-ci>=?}{{6.7}{26}} \newlabel{substring}{{6.7}{26}} \newlabel{string-append}{{6.7}{26}} \newlabel{string->list}{{6.7}{26}} \newlabel{list->string}{{6.7}{26}} \newlabel{string-copy}{{6.7}{26}} \newlabel{string-fill!}{{6.7}{26}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.8}Vectors}{26}} \newlabel{vectorsection}{{6.8}{26}} \newlabel{vector?}{{6.8}{26}} \newlabel{make-vector}{{6.8}{26}} \newlabel{make-vector}{{6.8}{26}} \newlabel{vector}{{6.8}{27}} \newlabel{vector-length}{{6.8}{27}} \newlabel{vector-ref}{{6.8}{27}} \newlabel{vector-set!}{{6.8}{27}} \newlabel{vector->list}{{6.8}{27}} \newlabel{list->vector}{{6.8}{27}} \newlabel{vector-fill!}{{6.8}{27}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.9}Control features}{27}} \newlabel{proceduresection}{{6.9}{27}} \newlabel{procedure?}{{6.9}{27}} \newlabel{apply}{{6.9}{27}} \newlabel{apply}{{6.9}{27}} \newlabel{map}{{6.9}{27}} \newlabel{for-each}{{6.9}{28}} \newlabel{force}{{6.9}{28}} \newlabel{call-with-current-continuation}{{6.9}{28}} \newlabel{continuations}{{6.9}{28}} \citation{Landin65} \citation{Reynolds72} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {6.10}Input and output}{29}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.10.1}Ports}{29}} \newlabel{portsection}{{6.10.1}{29}} \newlabel{call-with-input-file}{{6.10.1}{29}} \newlabel{call-with-output-file}{{6.10.1}{29}} \newlabel{input-port?}{{6.10.1}{29}} \newlabel{output-port?}{{6.10.1}{29}} \newlabel{current-input-port}{{6.10.1}{30}} \newlabel{current-output-port}{{6.10.1}{30}} \newlabel{with-input-from-file}{{6.10.1}{30}} \newlabel{with-output-to-file}{{6.10.1}{30}} \newlabel{open-input-file}{{6.10.1}{30}} \newlabel{open-output-file}{{6.10.1}{30}} \newlabel{close-input-port}{{6.10.1}{30}} \newlabel{close-output-port}{{6.10.1}{30}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.10.2}Input}{30}} \newlabel{inputsection}{{6.10.2}{30}} \newlabel{read}{{6.10.2}{30}} \newlabel{read}{{6.10.2}{30}} \newlabel{read-char}{{6.10.2}{30}} \newlabel{read-char}{{6.10.2}{30}} \newlabel{peek-char}{{6.10.2}{30}} \newlabel{peek-char}{{6.10.2}{30}} \newlabel{eof-object?}{{6.10.2}{30}} \newlabel{char-ready?}{{6.10.2}{30}} \newlabel{char-ready?}{{6.10.2}{30}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.10.3}Output}{31}} \newlabel{outputsection}{{6.10.3}{31}} \newlabel{write}{{6.10.3}{31}} \newlabel{write}{{6.10.3}{31}} \newlabel{display}{{6.10.3}{31}} \newlabel{display}{{6.10.3}{31}} \newlabel{newline}{{6.10.3}{31}} \newlabel{newline}{{6.10.3}{31}} \newlabel{write-char}{{6.10.3}{31}} \newlabel{write-char}{{6.10.3}{31}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {6.10.4}System interface}{31}} \newlabel{load}{{6.10.4}{31}} \newlabel{transcript-on}{{6.10.4}{31}} \newlabel{transcript-off}{{6.10.4}{31}} \@writefile{toc}{\string\contentsline\space {chapter}{\string\numberline\space {7}Formal syntax and semantics}{32}} \@writefile{lof}{\string\addvspace\space {10pt}} \@writefile{lot}{\string\addvspace\space {10pt}} \newlabel{formalchapter}{{7}{32}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {7.1}Formal syntax}{32}} \newlabel{BNF}{{7.1}{32}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.1.1}Lexical structure}{32}} \newlabel{extendedalphas}{{7.1.1}{32}} \newlabel{identifiersyntax}{{7.1.1}{32}} \newlabel{numbersyntax}{{7.1.1}{32}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.1.2}External representations}{33}} \newlabel{datumsyntax}{{7.1.2}{33}} \newlabel{datum}{{7.1.2}{33}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.1.3}Expressions}{33}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.1.4}Quasiquotations}{33}} \citation{Stoy77} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.1.5}Programs and definitions}{34}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {7.2}Formal semantics}{34}} \newlabel{formalsemanticssection}{{7.2}{34}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.2.1}Abstract syntax}{34}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.2.2}Domain equations}{34}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.2.3}Semantic functions}{34}} \@writefile{toc}{\string\contentsline\space {subsection}{\string\numberline\space {7.2.4}Auxiliary functions}{35}} \@writefile{toc}{\string\contentsline\space {section}{\string\numberline\space {7.3}Derived expression types}{36}} \newlabel{derivedsection}{{7.3}{36}} \citation{R3RS} \citation{IEEEScheme} \@writefile{toc}{\string\contentsline\space {chapter}{Notes}{38}} \newlabel{differences}{{7.3}{38}} \@writefile{toc}{\string\contentsline\space {chapter}{Example}{39}} \@writefile{toc}{\string\contentsline\space {chapter}{Appendix: Macros}{40}} \newlabel{bindsyntax}{{7.3}{40}} \newlabel{let-syntax}{{7.3}{41}} \newlabel{letrec-syntax}{{7.3}{41}} \newlabel{define-syntax}{{7.3}{41}} \newlabel{patternlanguage}{{7.3}{42}} \newlabel{syntax-rules}{{7.3}{42}} \newlabel{lowlevelmacros}{{7.3}{43}} \newlabel{syntax}{{7.3}{44}} \newlabel{identifier?}{{7.3}{44}} \newlabel{unwrap-syntax}{{7.3}{44}} \newlabel{free-identifier=?}{{7.3}{44}} \newlabel{bound-identifier=?}{{7.3}{45}} \newlabel{identifier->symbol}{{7.3}{45}} \newlabel{generate-identifier}{{7.3}{45}} \newlabel{generate-identifier}{{7.3}{45}} \newlabel{construct-identifier}{{7.3}{45}} \citation{Kohlbecker86} \citation{hygienic} \citation{Bawden88} \citation{Dybvig87} \citation{macrosthatwork} \bibcite{Abelson88}{1} \bibcite{SICP}{2} \bibcite{Adams88}{3} \bibcite{Bartley86}{4} \bibcite{Scheme81}{5} \bibcite{Bawden88}{6} \bibcite{Clinger84}{7} \bibcite{RRRS}{8} \bibcite{Clinger88}{9} \bibcite{howtoread}{10} \bibcite{Clinger85}{11} \bibcite{Clinger88b}{12} \bibcite{macrosthatwork}{13} \bibcite{Curtis90}{14} \bibcite{Dybvig87}{15} \bibcite{Dybvig86}{16} \bibcite{Dybvig88}{17} \bibcite{Dybvig88}{18} \bibcite{Dybvig88}{19} \bibcite{Eisenberg85}{20} \bibcite{Eisenberg88}{21} \bibcite{Eisenberg90}{22} \bibcite{Feeley86}{23} \bibcite{Feeley87}{24} \bibcite{Feeley90}{25} \@writefile{toc}{\string\contentsline\space {chapter}{Bibliography and references}{47}} \bibcite{Felleisen87b}{26} \bibcite{Felleisen86b}{27} \bibcite{Felleisen86c}{28} \bibcite{Felleisen87}{29} \bibcite{Felleisen87d}{30} \bibcite{Felleisen86}{31} \bibcite{Felleisen87c}{32} \bibcite{Felleisen88}{33} \bibcite{Scheme311}{34} \citation{Scheme84} \bibcite{Franco90}{35} \bibcite{Lisper}{36} \bibcite{littlelisper}{37} \bibcite{Friedman85}{38} \bibcite{Friedman84}{39} \bibcite{Scheme84}{40} \bibcite{Friedman84b}{41} \bibcite{Haynes86}{42} \bibcite{Engines}{43} \bibcite{Haynes87b}{44} \bibcite{Haynes87a}{45} \bibcite{Haynes86}{46} \bibcite{Henderson82}{47} \bibcite{Dybvig88}{48} \bibcite{IEEE}{49} \bibcite{IEEEScheme}{50} \bibcite{Kohlbecker86}{51} \bibcite{hygienic}{52} \bibcite{Kranz86}{53} \bibcite{Kranz88}{54} \bibcite{Landin65}{55} \bibcite{McDermott80}{56} \bibcite{MITScheme}{57} \bibcite{Muchnick80}{58} \bibcite{Naur63}{59} \bibcite{Penfield81}{60} \bibcite{Pitman85}{61} \bibcite{Pitman83}{62} \bibcite{Pitman80}{63} \bibcite{Plebanthesis}{64} \bibcite{Rees89}{65} \bibcite{Rees82}{66} \bibcite{Rees84}{67} \bibcite{R3RS}{68} \bibcite{Reynolds72}{69} \bibcite{Rozas84}{70} \bibcite{schflow}{71} \bibcite{Sitaram90}{72} \bibcite{Smith84}{73} \bibcite{Springer89}{74} \bibcite{Srivastava85}{75} \bibcite{Stallman80}{76} \bibcite{Declarative}{77} \bibcite{Debunking}{78} \bibcite{Macaroni}{79} \bibcite{Rabbit}{80} \bibcite{renamegoto}{81} \bibcite{CLoverview}{82} \bibcite{CLtL}{83} \bibcite{Imperative}{84} \bibcite{Scheme78}{85} \bibcite{TAOTI}{86} \bibcite{DOALBP}{87} \bibcite{Dream}{88} \bibcite{howtoprint}{89} \bibcite{Sussman82}{90} \bibcite{Scheme75}{91} \bibcite{Scheme79}{92} \bibcite{Stoy77}{93} \bibcite{TI85}{94} \bibcite{Vegdahl89}{95} \bibcite{Wand78}{96} \bibcite{Wand80}{97} \bibcite{Wand86}{98} \bibcite{tower}{99} \bibcite{Wand78}{100} \bibcite{Wand88}{101} \@writefile{toc}{\string\contentsline\space {chapter}{Alphabetic index of definitions of concepts,\hfil \penalty 0 \hbox {\string\phspace\space *{2em} keywords, and procedures}}{52}} scheme2c-2012.10.14/doc/r4rs/r4rs.idx000066400000000000000000000707021203736146400166460ustar00rootroot00000000000000(index-entry "object" "rm" main 3) (index-entry "read" "tt" aux 3) (index-entry "read" "tt" aux 3) (index-entry "essential" "rm" main 3) (index-entry "error" "rm" main 3) (index-entry "implementation restriction" "rm" main 4) (index-entry "unspecified" "rm" main 4) (index-entry "?" "tt" aux 4) (index-entry "?" "tt" aux 4) (index-entry "!" "tt" aux 4) (index-entry "!" "tt" aux 4) (index-entry "->" "tt" aux 4) (index-entry "list->vector" "tt" aux 4) (index-entry "->" "tt" aux 5) (index-entry "Foo" "tt" aux 5) (index-entry "FOO" "tt" aux 5) (index-entry "identifier" "rm" main 5) (index-entry "+" "tt" aux 5) (index-entry "-" "tt" aux 5) (index-entry "..." "tt" aux 5) (index-entry "syntactic keyword" "rm" aux 5) (index-entry "keyword" "rm" aux 5) (index-entry "variable" "rm" aux 5) (index-entry "Whitespace" "rm" main 5) (index-entry "comment" "rm" main 5) (index-entry ";" "tt" main 5) (index-entry "keyword" "rm" aux 6) (index-entry "syntactic keyword" "rm" aux 6) (index-entry "identifier" "rm" aux 6) (index-entry "variable" "rm" main 6) (index-entry "binding" "rm" main 6) (index-entry "binding construct" "rm" main 6) (index-entry "lambda expression{}" "rm" aux 6) (index-entry "let" "tt" aux 6) (index-entry "let*" "tt" aux 6) (index-entry "letrec" "tt" aux 6) (index-entry "do" "tt" aux 6) (index-entry "region" "rm" main 6) (index-entry "unbound" "rm" main 6) (index-entry "bound" "rm" main 6) (index-entry "top level environment" "rm" aux 6) (index-entry "true" "rm" main 6) (index-entry "false" "rm" main 6) (index-entry "quote" "tt" aux 6) (index-entry "read" "tt" aux 6) (index-entry "write" "tt" aux 6) (index-entry "type" "rm" main 7) (index-entry "location" "rm" main 7) (index-entry "car" "tt" aux 7) (index-entry "vector-ref" "tt" aux 7) (index-entry "string-ref" "tt" aux 7) (index-entry "eqv?" "tt" aux 7) (index-entry "constant" "rm" aux 7) (index-entry "mutable" "rm" aux 7) (index-entry "immutable" "rm" aux 7) (index-entry "symbol->string" "tt" aux 7) (index-entry "variable" "rm" aux 7) (index-entry "unbound" "rm" aux 7) (index-entry "quote" "tt" main 7) (index-entry "'" "tt" main 7) (index-entry "constant" "rm" aux 7) (index-entry "set-car!" "tt" aux 7) (index-entry "string-set!" "tt" aux 7) (index-entry "constant" "rm" aux 7) (index-entry "call" "rm" main 8) (index-entry "procedure call" "rm" main 8) (index-entry "+" "tt" aux 8) (index-entry "*" "tt" aux 8) (index-entry "combination" "rm" main 8) (index-entry "lambda" "tt" main 8) (index-entry "eqv?" "tt" aux 8) (index-entry "eq?" "tt" aux 8) (index-entry "if" "tt" main 8) (index-entry "if" "tt" main 8) (index-entry "if" "tt" aux 8) (index-entry "true" "rm" aux 8) (index-entry "set!" "tt" main 9) (index-entry "region" "rm" aux 9) (index-entry "set!" "tt" aux 9) (index-entry "set!" "tt" aux 9) (index-entry "cond" "tt" main 9) (index-entry "else" "tt" main 9) (index-entry "=>" "tt" main 9) (index-entry "cond" "tt" aux 9) (index-entry "true" "rm" aux 9) (index-entry "cond" "tt" aux 9) (index-entry "case" "tt" main 9) (index-entry "else" "tt" aux 9) (index-entry "case" "tt" aux 9) (index-entry "eqv?" "tt" aux 9) (index-entry "case" "tt" aux 9) (index-entry "case" "tt" aux 9) (index-entry "case" "tt" aux 9) (index-entry "and" "tt" main 9) (index-entry "or" "tt" main 9) (index-entry "let" "tt" aux 10) (index-entry "let*" "tt" aux 10) (index-entry "letrec" "tt" aux 10) (index-entry "region" "rm" aux 10) (index-entry "let" "tt" aux 10) (index-entry "let*" "tt" aux 10) (index-entry "letrec" "tt" aux 10) (index-entry "let" "tt" main 10) (index-entry "region" "rm" aux 10) (index-entry "let" "tt" aux 10) (index-entry "let*" "tt" main 10) (index-entry "Let*" "tt" aux 10) (index-entry "let" "tt" aux 10) (index-entry "region" "rm" aux 10) (index-entry "let*" "tt" aux 10) (index-entry "letrec" "tt" main 10) (index-entry "letrec" "tt" aux 10) (index-entry "region" "rm" aux 10) (index-entry "letrec" "tt" aux 10) (index-entry "letrec" "tt" aux 10) (index-entry "begin" "tt" main 10) (index-entry "sequence" "tt" aux 11) (index-entry "begin" "tt" aux 11) (index-entry "do" "tt" main 11) (index-entry "Do" "tt" aux 11) (index-entry "Do" "tt" aux 11) (index-entry "do" "tt" aux 11) (index-entry "do" "tt" aux 11) (index-entry "region" "rm" aux 11) (index-entry "do" "tt" aux 11) (index-entry "do" "tt" aux 11) (index-entry "let" "tt" main 11) (index-entry "let" "tt" aux 11) (index-entry "let" "tt" aux 11) (index-entry "do" "tt" aux 11) (index-entry "let" "tt" aux 11) (index-entry "let" "tt" aux 11) (index-entry "delay" "tt" main 11) (index-entry "delay" "tt" aux 11) (index-entry "force" "tt" aux 11) (index-entry "lazy evaluation" "rm" main 11) (index-entry "call by need" "rm" main 11) (index-entry "promise" "rm" main 11) (index-entry "force" "tt" aux 11) (index-entry "force" "tt" aux 11) (index-entry "delay" "tt" aux 11) (index-entry "quasiquote" "tt" main 11) (index-entry "backquote" "rm" aux 11) (index-entry "comma" "rm" aux 11) (index-entry "," "tt" main 11) (index-entry "at-sign" "rm" aux 11) (index-entry "foo" "tt" aux 12) (index-entry "write" "tt" aux 12) (index-entry "`" "tt" main 12) (index-entry "quasiquote" "tt" aux 12) (index-entry "unquote" "tt" aux 12) (index-entry "unquote-splicing" "tt" aux 12) (index-entry "definition" "rm" main 12) (index-entry "define" "tt" main 12) (index-entry "begin" "tt" aux 12) (index-entry "set!" "tt" aux 12) (index-entry "set!" "tt" aux 12) (index-entry "unbound" "rm" aux 12) (index-entry "lambda" "tt" aux 13) (index-entry "let" "tt" aux 13) (index-entry "let*" "tt" aux 13) (index-entry "letrec" "tt" aux 13) (index-entry "define" "tt" aux 13) (index-entry "internal definition" "rm" main 13) (index-entry "letrec" "tt" aux 13) (index-entry "let" "tt" aux 13) (index-entry "letrec" "tt" aux 13) (index-entry "initial environment" "rm" main 13) (index-entry "top level environment" "rm" main 13) (index-entry "abs" "tt" aux 13) (index-entry "+" "tt" aux 13) (index-entry "t" "sharpfoo" aux 13) (index-entry "f" "sharpfoo" aux 13) (index-entry "if" "tt" aux 13) (index-entry "cond" "tt" aux 13) (index-entry "and" "tt" aux 13) (index-entry "or" "tt" aux 13) (index-entry "do" "tt" aux 13) (index-entry "true" "rm" aux 13) (index-entry "false" "rm" aux 13) (index-entry "true" "rm" aux 13) (index-entry "false" "rm" aux 13) (index-entry "nil" "tt" aux 13) (index-entry "not" "tt" main 13) (index-entry "Not" "tt" aux 13) (index-entry "boolean?" "tt" main 13) (index-entry "Boolean?" "tt" aux 13) (index-entry "predicate" "rm" main 13) (index-entry "equivalence predicate" "rm" main 13) (index-entry "eq?" "tt" aux 13) (index-entry "equal?" "tt" aux 13) (index-entry "Eqv?" "tt" aux 13) (index-entry "eq?" "tt" aux 13) (index-entry "eqv?" "tt" main 13) (index-entry "eqv?" "tt" aux 13) (index-entry "eqv?" "tt" aux 13) (index-entry "eqv?" "tt" aux 13) (index-entry "eqv?" "tt" aux 14) (index-entry "=" "tt" aux 14) (index-entry "exact" "rm" aux 14) (index-entry "inexact" "rm" aux 14) (index-entry "char=?" "tt" aux 14) (index-entry "eqv?" "tt" aux 14) (index-entry "=" "tt" aux 14) (index-entry "char=?" "tt" aux 14) (index-entry "eqv?" "tt" aux 14) (index-entry "eqv?" "tt" aux 14) (index-entry "eqv?" "tt" aux 14) (index-entry "Gen-counter" "tt" aux 14) (index-entry "Gen-loser" "tt" aux 14) (index-entry "eqv?" "tt" aux 14) (index-entry "eqv?" "tt" aux 15) (index-entry "eq?" "tt" main 15) (index-entry "Eq?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "Eq?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "Eq?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "Eq?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "eq?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "eq?" "tt" aux 15) (index-entry "Eq?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "equal?" "tt" main 15) (index-entry "Equal?" "tt" aux 15) (index-entry "eqv?" "tt" aux 15) (index-entry "equal?" "tt" aux 15) (index-entry "Equal?" "tt" aux 15) (index-entry "pair" "rm" main 15) (index-entry "dotted pair" "rm" main 15) (index-entry "cons" "tt" aux 15) (index-entry "car" "tt" aux 15) (index-entry "cdr" "tt" aux 15) (index-entry "set-car!" "tt" aux 15) (index-entry "set-cdr!" "tt" aux 15) (index-entry "empty list" "rm" aux 15) (index-entry "empty list" "rm" main 15) (index-entry "empty list" "rm" aux 15) (index-entry "improper list" "rm" main 16) (index-entry "set-cdr!" "tt" aux 16) (index-entry "read" "tt" aux 16) (index-entry "'" "tt" aux 16) (index-entry "," "tt" aux 16) (index-entry "quote" "tt" aux 16) (index-entry "quasiquote" "tt" aux 16) (index-entry "unquote" "tt" aux 16) (index-entry "unquote-splicing" "tt" aux 16) (index-entry "read" "tt" aux 16) (index-entry "pair?" "tt" main 16) (index-entry "Pair?" "tt" aux 16) (index-entry "cons" "tt" main 16) (index-entry "eqv?" "tt" aux 16) (index-entry "car" "tt" main 16) (index-entry "empty list" "rm" aux 16) (index-entry "cdr" "tt" main 16) (index-entry "set-car!" "tt" main 16) (index-entry "set-car!" "tt" aux 16) (index-entry "set-cdr!" "tt" main 16) (index-entry "set-cdr!" "tt" aux 16) (index-entry "caar" "tt" main 16) (index-entry "cadr" "tt" main 16) (index-entry "cdddar" "tt" main 16) (index-entry "cddddr" "tt" main 16) (index-entry "car" "tt" aux 16) (index-entry "cdr" "tt" aux 16) (index-entry "caddr" "tt" aux 16) (index-entry "null?" "tt" main 16) (index-entry "empty list" "rm" aux 16) (index-entry "list?" "tt" main 16) (index-entry "list" "tt" main 17) (index-entry "length" "tt" main 17) (index-entry "append" "tt" main 17) (index-entry "reverse" "tt" main 17) (index-entry "list-tail" "tt" main 17) (index-entry "List-tail" "tt" aux 17) (index-entry "list-ref" "tt" main 17) (index-entry "memq" "tt" main 17) (index-entry "memv" "tt" main 17) (index-entry "member" "tt" main 17) (index-entry "Memq" "tt" aux 17) (index-entry "eq?" "tt" aux 17) (index-entry "memv" "tt" aux 17) (index-entry "eqv?" "tt" aux 17) (index-entry "member" "tt" aux 17) (index-entry "equal?" "tt" aux 17) (index-entry "assq" "tt" main 17) (index-entry "assv" "tt" main 17) (index-entry "assoc" "tt" main 17) (index-entry "Assq" "tt" aux 17) (index-entry "eq?" "tt" aux 17) (index-entry "assv" "tt" aux 17) (index-entry "eqv?" "tt" aux 17) (index-entry "assoc" "tt" aux 17) (index-entry "equal?" "tt" aux 17) (index-entry "memq" "tt" aux 17) (index-entry "memv" "tt" aux 17) (index-entry "member" "tt" aux 17) (index-entry "assq" "tt" aux 17) (index-entry "assv" "tt" aux 17) (index-entry "assoc" "tt" aux 17) (index-entry "eqv?" "tt" aux 18) (index-entry "identifier" "rm" aux 18) (index-entry "read" "tt" aux 18) (index-entry "write" "tt" aux 18) (index-entry "eqv?" "tt" aux 18) (index-entry "string\discretionary {->}{}{->}{}symbol" "tt" aux 18) (index-entry "symbol?" "tt" main 18) (index-entry "symbol->string" "tt" main 18) (index-entry "read" "tt" aux 18) (index-entry "string\discretionary {->}{}{->}{}symbol" "tt" aux 18) (index-entry "string\discretionary {->}{}{->}{}symbol" "tt" aux 18) (index-entry "string-set!" "tt" aux 18) (index-entry "string->symbol" "tt" main 18) (index-entry "symbol\discretionary {->}{}{->}{}string" "tt" aux 18) (index-entry "number" "rm" aux 18) (index-entry "numerical types" "rm" aux 19) (index-entry "number?" "tt" aux 19) (index-entry "complex?" "tt" aux 19) (index-entry "real?" "tt" aux 19) (index-entry "rational?" "tt" aux 19) (index-entry "integer?" "tt" aux 19) (index-entry "exactness" "rm" main 19) (index-entry "+" "tt" aux 19) (index-entry "inexact->exact" "tt" aux 19) (index-entry "implementation restriction" "rm" aux 19) (index-entry "length" "tt" aux 19) (index-entry "vector-length" "tt" aux 19) (index-entry "string-length" "tt" aux 19) (index-entry "/" "tt" aux 20) (index-entry "sqrt" "tt" aux 20) (index-entry "sqrt" "tt" aux 20) (index-entry "b" "sharpfoo" aux 20) (index-entry "o" "sharpfoo" aux 20) (index-entry "d" "sharpfoo" aux 20) (index-entry "x" "sharpfoo" aux 20) (index-entry "e" "sharpfoo" aux 20) (index-entry "i" "sharpfoo" aux 20) (index-entry "s" "tt" aux 20) (index-entry "f" "tt" aux 20) (index-entry "d" "tt" aux 20) (index-entry "l" "tt" aux 20) (index-entry "e" "tt" aux 20) (index-entry "number?" "tt" main 20) (index-entry "complex?" "tt" main 20) (index-entry "real?" "tt" main 20) (index-entry "rational?" "tt" main 20) (index-entry "integer?" "tt" main 20) (index-entry "rational?" "tt" aux 21) (index-entry "real?" "tt" aux 21) (index-entry "complex?" "tt" aux 21) (index-entry "number?" "tt" aux 21) (index-entry "exact?" "tt" main 21) (index-entry "inexact?" "tt" main 21) (index-entry "=" "tt" main 21) (index-entry "<" "tt" main 21) (index-entry ">" "tt" main 21) (index-entry "<=" "tt" main 21) (index-entry ">=" "tt" main 21) (index-entry "=" "tt" aux 21) (index-entry "zero?" "tt" aux 21) (index-entry "zero?" "tt" main 21) (index-entry "positive?" "tt" main 21) (index-entry "negative?" "tt" main 21) (index-entry "odd?" "tt" main 21) (index-entry "even?" "tt" main 21) (index-entry "max" "tt" main 21) (index-entry "min" "tt" main 21) (index-entry "min" "tt" aux 21) (index-entry "max" "tt" aux 21) (index-entry "+" "tt" main 21) (index-entry "*" "tt" main 21) (index-entry "-" "tt" main 21) (index-entry "-" "tt" main 21) (index-entry "-" "tt" main 21) (index-entry "/" "tt" main 21) (index-entry "/" "tt" main 21) (index-entry "/" "tt" main 21) (index-entry "abs" "tt" main 21) (index-entry "Abs" "tt" aux 21) (index-entry "quotient" "tt" main 22) (index-entry "remainder" "tt" main 22) (index-entry "modulo" "tt" main 22) (index-entry "quotient" "tt" aux 22) (index-entry "Remainder" "tt" aux 22) (index-entry "modulo" "tt" aux 22) (index-entry "remainder" "tt" aux 22) (index-entry "modulo" "tt" aux 22) (index-entry "gcd" "tt" main 22) (index-entry "lcm" "tt" main 22) (index-entry "numerator" "tt" main 22) (index-entry "denominator" "tt" main 22) (index-entry "floor" "tt" main 22) (index-entry "ceiling" "tt" main 22) (index-entry "truncate" "tt" main 22) (index-entry "round" "tt" main 22) (index-entry "Floor" "tt" aux 22) (index-entry "Ceiling" "tt" aux 22) (index-entry "Truncate" "tt" aux 22) (index-entry "Round" "tt" aux 22) (index-entry "Round" "tt" aux 22) (index-entry "inexact->exact" "tt" aux 22) (index-entry "rationalize" "tt" main 22) (index-entry "Rationalize" "tt" aux 22) (index-entry "simplest rational" "rm" main 22) (index-entry "exp" "tt" main 23) (index-entry "log" "tt" main 23) (index-entry "sin" "tt" main 23) (index-entry "cos" "tt" main 23) (index-entry "tan" "tt" main 23) (index-entry "asin" "tt" main 23) (index-entry "acos" "tt" main 23) (index-entry "atan" "tt" main 23) (index-entry "atan" "tt" main 23) (index-entry "Log" "tt" aux 23) (index-entry "Asin" "tt" aux 23) (index-entry "acos" "tt" aux 23) (index-entry "atan" "tt" aux 23) (index-entry "atan" "tt" aux 23) (index-entry "sqrt" "tt" main 23) (index-entry "expt" "tt" main 23) (index-entry "make-rectangular" "tt" main 23) (index-entry "make-polar" "tt" main 23) (index-entry "real-part" "tt" main 23) (index-entry "imag-part" "tt" main 23) (index-entry "magnitude" "tt" main 23) (index-entry "angle" "tt" main 23) (index-entry "make-rectangular" "tt" aux 23) (index-entry "make-polar" "tt" aux 23) (index-entry "real-part" "tt" aux 23) (index-entry "imag-part" "tt" aux 23) (index-entry "magnitude" "tt" aux 23) (index-entry "angle" "tt" aux 23) (index-entry "angle" "tt" aux 23) (index-entry "Magnitude" "tt" aux 23) (index-entry "abs" "tt" aux 23) (index-entry "abs" "tt" aux 23) (index-entry "magnitude" "tt" aux 23) (index-entry "exact->inexact" "tt" main 23) (index-entry "inexact->exact" "tt" main 23) (index-entry "Exact\discretionary {->}{}{->}{}inexact" "tt" aux 23) (index-entry "Inexact\discretionary {->}{}{->}{}exact" "tt" aux 23) (index-entry "number->string" "tt" main 23) (index-entry "number->string" "tt" main 23) (index-entry "number\discretionary {->}{}{->}{}string" "tt" aux 23) (index-entry "number\discretionary {->}{}{->}{}string" "tt" aux 24) (index-entry "string->number" "tt" main 24) (index-entry "string->number" "tt" main 24) (index-entry "string->number" "tt" aux 24) (index-entry "string->number" "tt" aux 24) (index-entry "String->number" "tt" aux 24) (index-entry "string->number" "tt" aux 24) (index-entry "string->number" "tt" aux 24) (index-entry "string->number" "tt" aux 24) (index-entry "string->number" "tt" aux 24) (index-entry "char?" "tt" main 24) (index-entry "char=?" "tt" main 24) (index-entry "char?" "tt" main 24) (index-entry "char<=?" "tt" main 24) (index-entry "char>=?" "tt" main 24) (index-entry "char-ci=?" "tt" main 25) (index-entry "char-ci?" "tt" main 25) (index-entry "char-ci<=?" "tt" main 25) (index-entry "char-ci>=?" "tt" main 25) (index-entry "char=?" "tt" aux 25) (index-entry "char-alphabetic?" "tt" main 25) (index-entry "char-numeric?" "tt" main 25) (index-entry "char-whitespace?" "tt" main 25) (index-entry "char-upper-case?" "tt" main 25) (index-entry "char-lower-case?" "tt" main 25) (index-entry "char->integer" "tt" main 25) (index-entry "integer->char" "tt" main 25) (index-entry "char\discretionary {->}{}{->}{}integer" "tt" aux 25) (index-entry "char\discretionary {->}{}{->}{}integer" "tt" aux 25) (index-entry "integer\discretionary {->}{}{->}{}char" "tt" aux 25) (index-entry "char<=?" "tt" aux 25) (index-entry "<=" "tt" aux 25) (index-entry "integer\discretionary {->}{}{->}{}char" "tt" aux 25) (index-entry "char-upcase" "tt" main 25) (index-entry "char-downcase" "tt" main 25) (index-entry "char-upcase" "tt" aux 25) (index-entry "char-downcase" "tt" aux 25) (index-entry "valid indexes" "rm" main 25) (index-entry "string?" "tt" main 25) (index-entry "make-string" "tt" main 25) (index-entry "make-string" "tt" main 25) (index-entry "Make-string" "tt" aux 25) (index-entry "string" "tt" main 25) (index-entry "string-length" "tt" main 25) (index-entry "string-ref" "tt" main 25) (index-entry "String-ref" "tt" aux 25) (index-entry "string-set!" "tt" main 26) (index-entry "String-set!" "tt" aux 26) (index-entry "string=?" "tt" main 26) (index-entry "string-ci=?" "tt" main 26) (index-entry "String-ci=?" "tt" aux 26) (index-entry "string=?" "tt" aux 26) (index-entry "string?" "tt" main 26) (index-entry "string<=?" "tt" main 26) (index-entry "string>=?" "tt" main 26) (index-entry "string-ci?" "tt" main 26) (index-entry "string-ci<=?" "tt" main 26) (index-entry "string-ci>=?" "tt" main 26) (index-entry "stringlist" "tt" main 26) (index-entry "list->string" "tt" main 26) (index-entry "String\discretionary {->}{}{->}{}list" "tt" aux 26) (index-entry "List\discretionary {->}{}{->}{}string" "tt" aux 26) (index-entry "String\discretionary {->}{}{->}{}list" "tt" aux 26) (index-entry "list\discretionary {->}{}{->}{}string" "tt" aux 26) (index-entry "equal?" "tt" aux 26) (index-entry "string-copy" "tt" main 26) (index-entry "string-fill!" "tt" main 26) (index-entry "valid indexes" "rm" aux 26) (index-entry "vector?" "tt" main 26) (index-entry "make-vector" "tt" main 26) (index-entry "make-vector" "tt" main 26) (index-entry "vector" "tt" main 27) (index-entry "list" "tt" aux 27) (index-entry "vector-length" "tt" main 27) (index-entry "vector-ref" "tt" main 27) (index-entry "Vector-ref" "tt" aux 27) (index-entry "vector-set!" "tt" main 27) (index-entry "Vector-set!" "tt" aux 27) (index-entry "vector-set!" "tt" aux 27) (index-entry "vector->list" "tt" main 27) (index-entry "list->vector" "tt" main 27) (index-entry "Vector->list" "tt" aux 27) (index-entry "List->vector" "tt" aux 27) (index-entry "vector-fill!" "tt" main 27) (index-entry "vector-fill!" "tt" aux 27) (index-entry "procedure?" "tt" aux 27) (index-entry "procedure?" "tt" main 27) (index-entry "apply" "tt" main 27) (index-entry "apply" "tt" main 27) (index-entry "map" "tt" main 27) (index-entry "Map" "tt" aux 27) (index-entry "for-each" "tt" main 28) (index-entry "for-each" "tt" aux 28) (index-entry "map" "tt" aux 28) (index-entry "for-each" "tt" aux 28) (index-entry "map" "tt" aux 28) (index-entry "for-each" "tt" aux 28) (index-entry "for-each" "tt" aux 28) (index-entry "force" "tt" main 28) (index-entry "delay" "tt" aux 28) (index-entry "promise" "rm" aux 28) (index-entry "Force" "tt" aux 28) (index-entry "delay" "tt" aux 28) (index-entry "delay" "tt" aux 28) (index-entry "force" "tt" aux 28) (index-entry "force" "tt" aux 28) (index-entry "make-promise" "tt" aux 28) (index-entry "make-promise" "tt" aux 28) (index-entry "delay" "tt" aux 28) (index-entry "force" "tt" aux 28) (index-entry "force" "tt" aux 28) (index-entry "cdr" "tt" aux 28) (index-entry "+" "tt" aux 28) (index-entry "call-with-current-continuation" "tt" main 28) (index-entry "call-with-current-continuation" "tt" aux 28) (index-entry "escape procedure" "rm" main 28) (index-entry "call-with-current-continuation" "tt" aux 29) (index-entry "call-with-current-continuation" "tt" aux 29) (index-entry "call-with-current-continuation" "tt" aux 29) (index-entry "call-with-current-continuation" "tt" aux 29) (index-entry "continuation" "rm" main 29) (index-entry "Call-with-current-continuation" "tt" aux 29) (index-entry "return" "tt" aux 29) (index-entry "catch" "tt" aux 29) (index-entry "catch" "tt" aux 29) (index-entry "call-with-current-continuation" "tt" aux 29) (index-entry "call/cc" "tt" aux 29) (index-entry "port" "rm" main 29) (index-entry "call-with-input-file" "tt" main 29) (index-entry "call-with-output-file" "tt" main 29) (index-entry "call-with-input-file" "tt" aux 29) (index-entry "call-with-output-file" "tt" aux 29) (index-entry "call-with-current-continuation" "tt" aux 29) (index-entry "call-with-input-file" "tt" aux 29) (index-entry "call-with-output-file" "tt" aux 29) (index-entry "input-port?" "tt" main 29) (index-entry "output-port?" "tt" main 29) (index-entry "current-input-port" "tt" main 30) (index-entry "current-output-port" "tt" main 30) (index-entry "with-input-from-file" "tt" main 30) (index-entry "with-output-to-file" "tt" main 30) (index-entry "with-input-from-file" "tt" aux 30) (index-entry "with-output-to-file" "tt" aux 30) (index-entry "current-input-port" "tt" aux 30) (index-entry "current-output-port" "tt" aux 30) (index-entry "With-input-from-file" "tt" aux 30) (index-entry "with-output-to-file" "tt" aux 30) (index-entry "open-input-file" "tt" main 30) (index-entry "open-output-file" "tt" main 30) (index-entry "close-input-port" "tt" main 30) (index-entry "close-output-port" "tt" main 30) (index-entry "read" "tt" main 30) (index-entry "read" "tt" main 30) (index-entry "Read" "tt" aux 30) (index-entry "Read" "tt" aux 30) (index-entry "current-input-port" "tt" aux 30) (index-entry "read-char" "tt" main 30) (index-entry "read-char" "tt" main 30) (index-entry "current-input-port" "tt" aux 30) (index-entry "peek-char" "tt" main 30) (index-entry "peek-char" "tt" main 30) (index-entry "current-input-port" "tt" aux 30) (index-entry "peek-char" "tt" aux 30) (index-entry "read-char" "tt" aux 30) (index-entry "read-char" "tt" aux 30) (index-entry "peek-char" "tt" aux 30) (index-entry "peek-char" "tt" aux 30) (index-entry "peek-char" "tt" aux 30) (index-entry "read-char" "tt" aux 30) (index-entry "eof-object?" "tt" main 30) (index-entry "read" "tt" aux 30) (index-entry "char-ready?" "tt" main 30) (index-entry "char-ready?" "tt" main 30) (index-entry "char-ready" "tt" aux 30) (index-entry "read-char" "tt" aux 30) (index-entry "char-ready?" "tt" aux 30) (index-entry "current-input-port" "tt" aux 30) (index-entry "Char-ready?" "tt" aux 30) (index-entry "char-ready?" "tt" aux 31) (index-entry "char-ready?" "tt" aux 31) (index-entry "write" "tt" main 31) (index-entry "write" "tt" main 31) (index-entry "Write" "tt" aux 31) (index-entry "current-output-port" "tt" aux 31) (index-entry "display" "tt" main 31) (index-entry "display" "tt" main 31) (index-entry "write-char" "tt" aux 31) (index-entry "write" "tt" aux 31) (index-entry "Display" "tt" aux 31) (index-entry "current-output-port" "tt" aux 31) (index-entry "Write" "tt" aux 31) (index-entry "display" "tt" aux 31) (index-entry "write" "tt" aux 31) (index-entry "display" "tt" aux 31) (index-entry "newline" "tt" main 31) (index-entry "newline" "tt" main 31) (index-entry "current-output-port" "tt" aux 31) (index-entry "write-char" "tt" main 31) (index-entry "write-char" "tt" main 31) (index-entry "current-output-port" "tt" aux 31) (index-entry "load" "tt" main 31) (index-entry "load" "tt" aux 31) (index-entry "load" "tt" aux 31) (index-entry "current-input-port" "tt" aux 31) (index-entry "current-output-port" "tt" aux 31) (index-entry "Load" "tt" aux 31) (index-entry "load" "tt" aux 31) (index-entry "transcript-on" "tt" main 31) (index-entry "transcript-off" "tt" main 31) (index-entry "transcript-on" "tt" aux 31) (index-entry "transcript-off" "tt" aux 31) (index-entry "token" "rm" aux 32) (index-entry "identifier" "rm" aux 32) (index-entry "comment" "rm" aux 32) (index-entry "keyword" "rm" aux 32) (index-entry "syntactic keyword" "rm" aux 32) (index-entry "variable" "rm" aux 32) (index-entry "i" "sharpfoo" aux 32) (index-entry "e" "sharpfoo" aux 32) (index-entry "b" "sharpfoo" aux 32) (index-entry "o" "sharpfoo" aux 32) (index-entry "x" "sharpfoo" aux 32) (index-entry "read" "tt" aux 33) (index-entry "lambda" "tt" aux 34) (index-entry "lambda" "tt" aux 35) (index-entry "if" "tt" aux 35) (index-entry "set!" "tt" aux 35) (index-entry "<" "tt" aux 36) (index-entry "+" "tt" aux 36) (index-entry "car" "tt" aux 36) (index-entry "set-car!" "tt" aux 36) (index-entry "set-car!" "tt" aux 36) (index-entry "apply" "tt" aux 36) (index-entry "values-list" "tt" aux 36) (index-entry "call-with-current-continuation" "tt" aux 36) (index-entry "lambda" "tt" aux 36) (index-entry "if" "tt" aux 36) (index-entry "set!" "tt" aux 36) (index-entry "memv" "tt" aux 37) (index-entry "let" "tt" aux 37) (index-entry "begin" "tt" aux 37) (index-entry "do" "tt" aux 37) (index-entry "do" "tt" aux 37) (index-entry "do" "tt" aux 37) (index-entry "do" "tt" aux 37) (index-entry "force" "tt" aux 38) (index-entry "boolean?" "tt" aux 38) (index-entry "pair?" "tt" aux 38) (index-entry "symbol?" "tt" aux 38) (index-entry "number?" "tt" aux 38) (index-entry "char?" "tt" aux 38) (index-entry "string?" "tt" aux 38) (index-entry "vector?" "tt" aux 38) (index-entry "procedure?" "tt" aux 38) (index-entry "lambda" "tt" aux 38) (index-entry "let" "tt" aux 38) (index-entry "letrec" "tt" aux 38) (index-entry "do" "tt" aux 38) (index-entry "begin" "tt" aux 38) (index-entry "eqv?" "tt" aux 38) (index-entry "Rationalize" "tt" aux 38) (index-entry "number->string" "tt" aux 38) (index-entry "string->number" "tt" aux 38) (index-entry "Integer->char" "tt" aux 38) (index-entry "force" "tt" aux 38) (index-entry "t" "tt" aux 38) (index-entry "nil" "tt" aux 38) (index-entry "approximate" "tt" aux 38) (index-entry "last-pair" "tt" aux 38) (index-entry "list?" "tt" aux 38) (index-entry "peek-char" "tt" aux 38) (index-entry "case" "tt" aux 38) (index-entry "and" "tt" aux 38) (index-entry "or" "tt" aux 38) (index-entry "quasiquote" "tt" aux 38) (index-entry "append" "tt" aux 38) (index-entry "+" "tt" aux 38) (index-entry "*" "tt" aux 38) (index-entry "-" "tt" aux 38) (index-entry "/" "tt" aux 38) (index-entry "=" "tt" aux 38) (index-entry "<" "tt" aux 38) (index-entry ">" "tt" aux 38) (index-entry "<=" "tt" aux 38) (index-entry ">=" "tt" aux 38) (index-entry "map" "tt" aux 38) (index-entry "for-each" "tt" aux 38) (index-entry "Integrate-system" "tt" aux 39) (index-entry "integrate-system" "tt" aux 39) (index-entry "Runge-Kutta-4" "tt" aux 39) (index-entry "Runge-Kutta-4" "tt" aux 39) (index-entry "Map-streams" "tt" aux 39) (index-entry "map" "tt" aux 39) (index-entry "integrate-system" "tt" aux 39) (index-entry "macro" "rm" main 40) (index-entry "syntactic keyword" "rm" aux 40) (index-entry "keyword" "rm" aux 40) (index-entry "macro keyword" "rm" aux 40) (index-entry "macro use" "rm" aux 40) (index-entry "macro transformer" "rm" aux 40) (index-entry "keyword" "rm" aux 40) (index-entry "hygienic" "rm" main 40) (index-entry "referentially transparent" "rm" main 40) (index-entry "let-syntax" "tt" main 41) (index-entry "letrec-syntax" "tt" main 41) (index-entry "define-syntax" "tt" main 41) (index-entry "syntax-rules" "tt" main 42) (index-entry "syntax" "tt" main 44) (index-entry "identifier?" "tt" main 44) (index-entry "unwrap-syntax" "tt" main 44) (index-entry "free-identifier=?" "tt" main 44) (index-entry "bound-identifier=?" "tt" main 45) (index-entry "identifier->symbol" "tt" main 45) (index-entry "generate-identifier" "tt" main 45) (index-entry "generate-identifier" "tt" main 45) (index-entry "construct-identifier" "tt" main 45) scheme2c-2012.10.14/doc/r4rs/r4rs.tex000066400000000000000000000016101203736146400166520ustar00rootroot00000000000000\documentstyle[twoside]{algol60} \pagestyle{headings} \showboxdepth=0 \makeindex \input{commands} \def\theevenhead{Revised$^{4}$ Scheme} \begin{document} \hfil {\bf 2 November 1991}%\today{} ***} \input{first} \par \input{intro} \par \vskip 2ex \clearchapterstar{Description of the language} %\unskip\vskip -2ex % \chapter*{Description of the language}\unskip\vskip -2ex \input{struct} \par \input{lex} \par \input{basic} \par \input{expr} \par \input{prog} \par \input{procs} \par \vfill\eject \input{syn} \par \input{sem} \par \input{derive} \par \vfill%%R4%%\eject \input{notes} \par \vfill\eject \input{example} \par \vfill\eject \input{macros} \par \vfill\eject \input{bib} \par \newpage \begin{theindex} The principal entry for each term, procedure, or keyword is listed first, separated from the other entries by a semicolon. \bigskip \input{index} \end{theindex} \end{document} scheme2c-2012.10.14/doc/r4rs/r4rs.toc000066400000000000000000000120261203736146400166420ustar00rootroot00000000000000\contentsline {chapter}{Introduction}{2} \contentsline {chapter}{\numberline {1}Overview of Scheme}{3} \contentsline {section}{\numberline {1.1}Semantics}{3} \contentsline {section}{\numberline {1.2}Syntax}{3} \contentsline {section}{\numberline {1.3}Notation and terminology}{3} \contentsline {subsection}{\numberline {1.3.1}Essential and non-essential features}{3} \contentsline {subsection}{\numberline {1.3.2}Error situations and unspecified behavior}{3} \contentsline {subsection}{\numberline {1.3.3}Entry format}{4} \contentsline {subsection}{\numberline {1.3.4}Evaluation examples}{4} \contentsline {subsection}{\numberline {1.3.5}Naming conventions}{4} \contentsline {chapter}{\numberline {2}Lexical conventions}{5} \contentsline {section}{\numberline {2.1}Identifiers}{5} \contentsline {section}{\numberline {2.2}Whitespace and comments}{5} \contentsline {section}{\numberline {2.3}Other notations}{5} \contentsline {chapter}{\numberline {3}Basic concepts}{6} \contentsline {section}{\numberline {3.1}Variables and regions}{6} \contentsline {section}{\numberline {3.2}True and false}{6} \contentsline {section}{\numberline {3.3}External representations}{6} \contentsline {section}{\numberline {3.4}Disjointness of types}{7} \contentsline {section}{\numberline {3.5}Storage model}{7} \contentsline {chapter}{\numberline {4}Expressions}{7} \contentsline {section}{\numberline {4.1}Primitive expression types}{7} \contentsline {subsection}{\numberline {4.1.1}Variable references}{7} \contentsline {subsection}{\numberline {4.1.2}Literal expressions}{7} \contentsline {subsection}{\numberline {4.1.3}Procedure calls}{8} \contentsline {subsection}{\numberline {4.1.4}Lambda expression{}s}{8} \contentsline {subsection}{\numberline {4.1.5}Conditionals}{8} \contentsline {subsection}{\numberline {4.1.6}Assignments}{9} \contentsline {section}{\numberline {4.2}Derived expression types}{9} \contentsline {subsection}{\numberline {4.2.1}Conditionals}{9} \contentsline {subsection}{\numberline {4.2.2}Binding constructs}{10} \contentsline {subsection}{\numberline {4.2.3}Sequencing}{10} \contentsline {subsection}{\numberline {4.2.4}Iteration}{11} \contentsline {subsection}{\numberline {4.2.5}Delayed evaluation}{11} \contentsline {subsection}{\numberline {4.2.6}Quasiquotation}{11} \contentsline {chapter}{\numberline {5}Program structure}{12} \contentsline {section}{\numberline {5.1}Programs}{12} \contentsline {section}{\numberline {5.2}Definitions}{12} \contentsline {subsection}{\numberline {5.2.1}Top level definitions}{12} \contentsline {subsection}{\numberline {5.2.2}Internal definitions}{13} \contentsline {chapter}{\numberline {6}Standard procedures}{13} \contentsline {section}{\numberline {6.1}Booleans}{13} \contentsline {section}{\numberline {6.2}Equivalence predicates}{13} \contentsline {section}{\numberline {6.3}Pairs and lists}{15} \contentsline {section}{\numberline {6.4}Symbols}{18} \contentsline {section}{\numberline {6.5}Numbers}{18} \contentsline {subsection}{\numberline {6.5.1}Numerical types}{19} \contentsline {subsection}{\numberline {6.5.2}Exactness}{19} \contentsline {subsection}{\numberline {6.5.3}Implementation restrictions}{19} \contentsline {subsection}{\numberline {6.5.4}Syntax of numerical constants}{20} \contentsline {subsection}{\numberline {6.5.5}Numerical operations}{20} \contentsline {subsection}{\numberline {6.5.6}Numerical input and output}{23} \contentsline {section}{\numberline {6.6}Characters}{24} \contentsline {section}{\numberline {6.7}Strings}{25} \contentsline {section}{\numberline {6.8}Vectors}{26} \contentsline {section}{\numberline {6.9}Control features}{27} \contentsline {section}{\numberline {6.10}Input and output}{29} \contentsline {subsection}{\numberline {6.10.1}Ports}{29} \contentsline {subsection}{\numberline {6.10.2}Input}{30} \contentsline {subsection}{\numberline {6.10.3}Output}{31} \contentsline {subsection}{\numberline {6.10.4}System interface}{31} \contentsline {chapter}{\numberline {7}Formal syntax and semantics}{32} \contentsline {section}{\numberline {7.1}Formal syntax}{32} \contentsline {subsection}{\numberline {7.1.1}Lexical structure}{32} \contentsline {subsection}{\numberline {7.1.2}External representations}{33} \contentsline {subsection}{\numberline {7.1.3}Expressions}{33} \contentsline {subsection}{\numberline {7.1.4}Quasiquotations}{33} \contentsline {subsection}{\numberline {7.1.5}Programs and definitions}{34} \contentsline {section}{\numberline {7.2}Formal semantics}{34} \contentsline {subsection}{\numberline {7.2.1}Abstract syntax}{34} \contentsline {subsection}{\numberline {7.2.2}Domain equations}{34} \contentsline {subsection}{\numberline {7.2.3}Semantic functions}{34} \contentsline {subsection}{\numberline {7.2.4}Auxiliary functions}{35} \contentsline {section}{\numberline {7.3}Derived expression types}{36} \contentsline {chapter}{Notes}{38} \contentsline {chapter}{Example}{39} \contentsline {chapter}{Appendix: Macros}{40} \contentsline {chapter}{Bibliography and references}{47} \contentsline {chapter}{Alphabetic index of definitions of concepts,\hfil \penalty 0 \hbox {\phspace *{2em} keywords, and procedures}}{52} scheme2c-2012.10.14/doc/r4rs/sem.tex000066400000000000000000000572541203736146400165630ustar00rootroot00000000000000%\vfill\eject \section{Formal semantics} \label{formalsemanticssection} \bgroup \newcommand{\sembrack}[1]{[\![#1]\!]} \newcommand{\fun}[1]{\hbox{\it #1}} \newenvironment{semfun}{\begin{tabbing}$}{$\end{tabbing}} \newcommand\LOC{{\tt{}L}} \newcommand\NAT{{\tt{}N}} \newcommand\TRU{{\tt{}T}} \newcommand\SYM{{\tt{}Q}} \newcommand\CHR{{\tt{}H}} \newcommand\NUM{{\tt{}R}} \newcommand\FUN{{\tt{}F}} \newcommand\EXP{{\tt{}E}} \newcommand\STV{{\tt{}E}} \newcommand\STO{{\tt{}S}} \newcommand\ENV{{\tt{}U}} \newcommand\ANS{{\tt{}A}} \newcommand\ERR{{\tt{}X}} \newcommand\EC{{\tt{}K}} \newcommand\CC{{\tt{}C}} \newcommand\MSC{{\tt{}M}} \newcommand\PAI{\hbox{\EXP$_{\rm p}$}} \newcommand\VEC{\hbox{\EXP$_{\rm v}$}} \newcommand\STR{\hbox{\EXP$_{\rm s}$}} \newcommand\elt{\downarrow} \newcommand\drop{\dagger} %\newcommand\injekt{\hbox{ \rm in }} %\newcommand\projekt{\,\vert\,} This section provides a formal denotational semantics for the primitive expressions of Scheme and selected built-in procedures. The concepts and notation used here are described in~\cite{Stoy77}; the notation is summarized below: \begin{tabular}{ll} $\langle\,\ldots\,\rangle$ & sequence formation \\ $s \elt k$ & $k$th member of the sequence $s$ (1-based) \\ $\#s$ & length of sequence $s$ \\ $s \:\S\: t$ & concatenation of sequences $s$ and $t$ \\ $s \drop k$ & drop the first $k$ members of sequence $s$ \\ $t \rightarrow a, b$ & McCarthy conditional ``if $t$ then $a$ else $b$'' \\ $\rho[x/i]$ & substitution ``$\rho$ with $x$ for $i$'' \\ $x\hbox{ \rm in }{\tt{}D}$ & injection of $x$ into domain ${\tt{}D}$ \\ $x\,\vert\,{\tt{}D}$ & projection of $x$ to domain ${\tt{}D}$ \end{tabular} The reason that expression continuations take sequences of values instead of single values is to simplify the formal treatment of procedure calls and to make it easy to add multiple return values. The boolean flag associated with pairs, vectors, and strings will be true for mutable objects and false for immutable objects. The order of evaluation within a call is unspecified. We mimic that here by applying arbitrary permutations {\it permute} and {\it unpermute}, which must be inverses, to the arguments in a call before and after they are evaluated. This is not quite right since it suggests, incorrectly, that the order of evaluation is constant throughout a program (for any given number of arguments), but it is a closer approximation to the intended semantics than a left-to-right evaluation would be. The storage allocator {\it new} is implementation-dependent, but it must obey the following axiom: if \hbox{$\fun{new}\:\sigma\:\elem\:\LOC$}, then $\sigma\:(\fun{new}\:\sigma\:\vert\:\LOC)\elt 2 = {\it false}$. \def\P{\hbox{\rm P}} \def\I{\hbox{\rm I}} \def\Ksem{\hbox{$\cal K$}} \def\Esem{\hbox{$\cal E$}} The definition of $\Ksem$ is omitted because an accurate definition of $\Ksem$ would complicate the semantics without being very interesting. If \P{} is a program in which all variables are defined before being referenced or assigned, then the meaning of \P{} is $$\Esem\sembrack{\hbox{\tt((\ide{lambda} (\arbno{\I}) \P') \hyper{undefined} \dotsfoo)}}$$ where \arbno{\I} is the sequence of variables defined in \P, $\P'$ is the sequence of expressions obtained by replacing every definition in \P{} by an assignment, \hyper{undefined} is an expression that evaluates to \fun{undefined}, and $\Esem$ is the semantic function that assigns meaning to expressions. %The semantics in this section was translated by machine from an %executable version of the semantics written in Scheme itself. %[This was once true, but then I modified the semantics without %going back to the executable version. -- Will] \subsection{Abstract syntax} \def\K{\hbox{\rm K}} \def\I{\hbox{\rm I}} \def\E{\hbox{\rm E}} \def\C{\hbox{$\Gamma$}} \def\Con{\hbox{\rm Con}} \def\Ide{\hbox{\rm Ide}} \def\Exp{\hbox{\rm Exp}} \def\Com{\hbox{\rm Com}} \def\|{$\vert$} \begin{tabular}{r@{ }c@{ }l@{\qquad}l} \K & \elem & \Con & constants, including quotations \\ \I & \elem & \Ide & identifiers (variables) \\ \E & \elem & \Exp & expressions\\ \C & \elem & \Com{} $=$ \Exp & commands \end{tabular} \setbox0=\hbox{\tt\Exp{} \goesto{}} %\tt for spacing \setbox1=\hbox to 1\wd0{\hfil \|} \begin{grammar} \Exp{} \goesto{} \K{} \| \I{} \| (\E$_0$ \arbno{\E}) \copy1{} (lambda (\arbno{\I}) \arbno{\C} \E$_0$) \copy1{} (lambda (\arbno{\I} {\bf.}\ \I) \arbno{\C} \E$_0$) \copy1{} (lambda \I{} \arbno{\C} \E$_0$) \copy1{} (if \E$_0$ \E$_1$ \E$_2$) \| (if \E$_0$ \E$_1$) \copy1{} (set! \I{} \E) \end{grammar} \subsection{Domain equations} \begin{tabular}{@{}r@{ }c@{ }l@{ }l@{ }ll} $\alpha$ & \elem & \LOC & & & locations \\ $\nu$ & \elem & \NAT & & & natural numbers \\ & & \TRU &=& $\{$\it false, true$\}$ & booleans \\ & & \SYM & & & symbols \\ & & \CHR & & & characters \\ & & \NUM & & & numbers \\ & & \PAI &=& $\LOC \times \LOC \times \TRU$ & pairs \\ & & \VEC &=& $\arbno{\LOC} \times \TRU$ & vectors \\ & & \STR &=& $\arbno{\LOC} \times \TRU$ & strings \\ & & \MSC &=& \makebox[0pt][l]{$\{$\it false, true, null, undefined, unspecified$\}$} \\ & & & & & miscellaneous \\ $\phi$ & \elem & \FUN &=& $\LOC\times(\arbno{\EXP} \to \EC \to \CC)$ & procedure values \\ $\epsilon$ & \elem & \EXP &=& \makebox[0pt][l]{$\SYM+\CHR+\NUM+\PAI+\VEC+\STR+\MSC+\FUN$}\\ & & & & & expressed values \\ % & & \STV &=& \EXP & stored values \\ $\sigma$ & \elem & \STO &=& $\LOC\to(\STV\times\TRU)$ & stores \\ $\rho$ & \elem & \ENV &=& $\Ide\to\LOC$ & environments \\ $\theta$ & \elem & \CC &=& $\STO\to\ANS$ & command continuations \\ $\kappa$ & \elem & \EC &=& $\arbno{\EXP}\to\CC$ & expression continuations \\ & & \ANS & & & answers \\ & & \ERR & & & errors \end{tabular} \subsection{Semantic functions} \def\Ksem{\hbox{$\cal K$}} \def\Esem{\hbox{$\cal E$}} \def\Csem{\hbox{$\cal C$}} \begin{tabular}{@{}r@{ }l} $\Ksem:$ & $\Con\to\EXP$ \\ $\Esem:$ & $\Exp\to\ENV\to\EC\to\CC$ \\ $\arbno{\Esem}:$ & $\arbno{\Exp}\to\ENV\to\EC\to\CC$ \\ $\Csem:$ & $\arbno{\Com}\to\ENV\to\CC\to\CC$ \end{tabular} % thin \, medium \> [or \:] thick \; \renewcommand{\:}{\mskip\medmuskip} \newcommand{\wrong}[1]{\fun{wrong }\hbox{\rm``#1''}} \newcommand{\go}[1]{\hbox{\hspace*{#1em}}} \bgroup\small \vspace{1ex} Definition of \Ksem{} deliberately omitted. \begin{semfun} \Esem\sembrack{\K} = \lambda\rho\kappa\:.\:\fun{send}\,(\Ksem\sembrack{\K})\,\kappa \end{semfun} \begin{semfun} \Esem\sembrack{\I} = \lambda\rho\kappa\:.\:\fun{hold}\: $\=$(\fun{lookup}\:\rho\:\I)$\\ \>$(\fun{single}(\lambda\epsilon\:.\: $\=$\epsilon = \fun{undefined}\rightarrow$\\ \> \> \go{2}$\wrong{undefined variable},$\\ \> \>\go{1}$\fun{send}\:\epsilon\:\kappa)) \end{semfun} \begin{semfun} \Esem\sembrack{\hbox{\tt($\E_0$ \arbno{\E})}} =$\\ \go{1}$\lambda\rho\kappa\:.\:\arbno{\Esem} $\=$(\fun{permute}(\langle\E_0\rangle\:\S\:\arbno{\E}))$\\ \>$\rho\:$\\ \>$(\lambda\arbno{\epsilon}\:.\: ($\=$(\lambda\arbno{\epsilon}\:.\: \fun{applicate}\:(\arbno{\epsilon}\elt 1) \:(\arbno{\epsilon}\drop 1) \:\kappa)$\\ \> \>$(\fun{unpermute}\:\arbno{\epsilon}))) \end{semfun} \begin{semfun} \Esem\sembrack{\hbox{\tt(\ide{lambda} (\arbno{\I}) \arbno{\C} $\E_0$)}} =$\\ \go{1}$\lambda\rho\kappa\:.\:\lambda\sigma\:.\:$\\ \go{2}$\fun{new}\:\sigma\:\elem\:\LOC\rightarrow$\\ \go{3}$\fun{send}\: $\=$(\langle $\=$\fun{new}\:\sigma\,\vert\,\LOC,$\\ \> \>$\lambda\arbno{\epsilon}\kappa^\prime\:.\: $\=$\#\arbno{\epsilon} = \#{\arbno{\I}}\rightarrow$\\ \> \> \>$\go{1}\fun{tievals} $\=$(\lambda\arbno{\alpha}\:.\: $\=$(\lambda\rho^\prime\:.\:\Csem\sembrack{\arbno{\C}}\rho^\prime (\Esem\sembrack{\E_0}\rho^\prime\kappa^\prime))$\\ \> \> \> \> \>$(\fun{extends}\:\rho\:{\arbno{\I}}\:\arbno{\alpha}))$\\ \> \> \> \>$\arbno{\epsilon},$\\ \> \> \>\go{1}$\wrong{wrong number of arguments}\rangle$\\ \> \>$\hbox{ \rm in }\EXP)$\\ \>$\kappa$\\ \>$(\fun{update}\:(\fun{new}\:\sigma\,\vert\,\LOC) \:\fun{unspecified} \:\sigma),$\\ \go{3}$\wrong{out of memory}\:\sigma \end{semfun} \begin{semfun} \Esem\sembrack{\hbox{\tt(lambda (\arbno{\I} {\bf.}\ \I) \arbno{\C} $\E_0$)}} =$\\ \go{1}$\lambda\rho\kappa\:.\:\lambda\sigma\:.\:$\\ \go{2}$\fun{new}\:\sigma\:\elem\:\LOC\rightarrow$\\ \go{3}$\fun{send}\: $\=$(\langle $\=$\fun{new}\:\sigma\,\vert\,\LOC,$\\ \> \>$\lambda\arbno{\epsilon}\kappa^\prime\:.\: $\=$\#\arbno{\epsilon} \geq \#\arbno{\I}\rightarrow$\\ \> \> \>\go{1}$\fun{tievalsrest}$\\ \> \> \>\go{2}\=$(\lambda\arbno{\alpha}\:.\: $\=$(\lambda\rho^\prime\:.\:\Csem\sembrack{\arbno{\C}}\rho^\prime (\Esem\sembrack{\E_0}\rho^\prime\kappa^\prime))$\\ \> \> \> \> \>$(\fun{extends}\:\rho \:(\arbno{\I}\:\S\:\langle\I\rangle) \:\arbno{\alpha}))$\\ \> \> \> \>$\arbno{\epsilon}$\\ \> \> \> \>$(\#\arbno{\I}),$\\ \> \> \>\go{1}$\wrong{too few arguments}\rangle\hbox{ \rm in }\EXP)$\\ \>$\kappa$\\ \>$(\fun{update}\:(\fun{new}\:\sigma\,\vert\,\LOC) \:\fun{unspecified} \:\sigma),$\\ \go{3}$\wrong{out of memory}\:\sigma \end{semfun} \begin{semfun} \Esem\sembrack{\hbox{\tt(lambda \I{} \arbno{\C} $\E_0$)}} = \Esem\sembrack{\hbox{\tt(lambda ({\bf.}\ \I) \arbno{\C} $\E_0$)}} \end{semfun} \begin{semfun} \Esem\sembrack{\hbox{\tt(\ide{if} $\E_0$ $\E_1$ $\E_2$)}} =$\\ \go{1}$\lambda\rho\kappa\:.\: \Esem\sembrack{\E_0}\:\rho\:(\fun{single}\:(\lambda\epsilon\:.\: $\=$\fun{truish}\:\epsilon\rightarrow\Esem\sembrack{\E_1}\rho\kappa,$\\ \>\go{1}$\Esem\sembrack{\E_2}\rho\kappa)) \end{semfun} \begin{semfun} \Esem\sembrack{\hbox{\tt(if $\E_0$ $\E_1$)}} =$\\ \go{1}$\lambda\rho\kappa\:.\: \Esem\sembrack{\E_0}\:\rho\:(\fun{single}\:(\lambda\epsilon\:.\: $\=$\fun{truish}\:\epsilon\rightarrow\Esem\sembrack{\E_1}\rho\kappa,$\\ \>\go{1}$\fun{send}\:\fun{unspecified}\:\kappa)) \end{semfun} Here and elsewhere, any expressed value other than {\it undefined} may be used in place of {\it unspecified}. \begin{semfun} \Esem\sembrack{\hbox{\tt(\ide{set!} \I{} \E)}} =$\\ \go{1}$\lambda\rho\kappa\:.\:\Esem\sembrack{\E}\:\rho\: (\fun{single}(\lambda\epsilon\:.\:\fun{assign}\: $\=$(\fun{lookup}\:\rho\:\I)$\\ \>$\epsilon$\\ \>$(\fun{send}\:\fun{unspecified}\:\kappa))) \end{semfun} \begin{semfun} \arbno{\Esem}\sembrack{\:} = \lambda\rho\kappa\:.\:\kappa\langle\:\rangle \end{semfun} \begin{semfun} \arbno{\Esem}\sembrack{\E_0\:\arbno{\E}} =$\\ \go{1}$\lambda\rho\kappa\:.\: \Esem\sembrack{\E_0}\:\rho\: (\fun{single} (\lambda\epsilon_0\:.\:\arbno{\Esem}\sembrack{\arbno{\E}} \:\rho\:(\lambda\arbno{\epsilon}\:.\: \kappa\:(\langle\epsilon_0\rangle\:\S\:\arbno{\epsilon})))) \end{semfun} \begin{semfun} \Csem\sembrack{\:} = \lambda\rho\theta\,.\:\theta \end{semfun} \begin{semfun} \Csem\sembrack{\C_0\:\arbno{\C}} = \lambda\rho\theta\:.\:\Esem\sembrack{\C_0}\:\rho\:(\lambda\arbno{\epsilon}\:.\: \Csem\sembrack{\arbno{\C}}\rho\theta) \end{semfun} \egroup % end smallish \subsection{Auxiliary functions} \bgroup\small \begin{semfun} \fun{lookup} : \ENV \to \Ide \to \LOC$\\$ \fun{lookup} = \lambda\rho\I\:.\:\rho\I \end{semfun} \begin{semfun} \fun{extends} : \ENV \to \arbno{\Ide} \to \arbno{\LOC} \to \ENV$\\$ \fun{extends} =$\\ \go{1}$\lambda\rho\arbno{\I}\arbno{\alpha}\:.\: $\=$\#\arbno{\I}=0\rightarrow\rho,$\\ \>$\go{1}\fun{extends}\:(\rho[(\arbno{\alpha}\elt 1)/(\arbno{\I}\elt 1)]) \:(\arbno{\I}\drop 1) \:(\arbno{\alpha}\drop 1) \end{semfun} \begin{semfun} \fun{wrong} : \ERR \to \CC \hbox{\qquad [implementation-dependent]} \end{semfun} \begin{semfun} \fun{send} : \EXP \to \EC \to \CC$\\$ \fun{send} = \lambda\epsilon\kappa\:.\:\kappa\langle\epsilon\rangle \end{semfun} \begin{semfun} \fun{single} : (\EXP \to \CC) \to \EC$\\$ \fun{single} =$\\ \go{1}$\lambda\psi\arbno{\epsilon}\:.\: $\=$\#\arbno{\epsilon}=1\rightarrow\psi(\arbno{\epsilon}\elt 1),$\\ \>$\go{1}\wrong{wrong number of return values} \end{semfun} \begin{semfun} \fun{new} : \STO \to (\LOC + \{ \fun{error} \}) \hbox{\qquad [implementation-dependent]} \end{semfun} \begin{semfun} \fun{hold} : \LOC \to \EC \to \CC$\\$ \fun{hold} = \lambda\alpha\kappa\sigma\:.\:\fun{send}\,(\sigma\alpha\elt 1)\kappa\sigma \end{semfun} \begin{semfun} \fun{assign} : \LOC \to \EXP \to \CC \to \CC$\\$ \fun{assign} = \lambda\alpha\epsilon\theta\sigma\:.\:\theta(\fun{update}\:\alpha\epsilon\sigma) \end{semfun} \begin{semfun} \fun{update} : \LOC \to \EXP \to \STO \to \STO$\\$ \fun{update} = \lambda\alpha\epsilon\sigma\:.\:\sigma[\langle\epsilon,\fun{true}\rangle/\alpha] \end{semfun} \begin{semfun} \fun{tievals} : (\arbno{\LOC} \to \CC) \to \arbno{\EXP} \to \CC$\\$ \fun{tievals} =$\\ \go{1}$\lambda\psi\arbno{\epsilon}\sigma\:.\: $\=$\#\arbno{\epsilon}=0\rightarrow\psi\langle\:\rangle\sigma,$\\ \>$\fun{new}\:\sigma\:\elem\:\LOC\rightarrow\fun{tievals}\, $\=$(\lambda\arbno{\alpha}\:.\:\psi(\langle\fun{new}\:\sigma\:\vert\:\LOC\rangle \:\S\:\arbno{\alpha}))$\\ \> \>$(\arbno{\epsilon}\drop 1)$\\ \> \>$(\fun{update}(\fun{new}\:\sigma\:\vert\:\LOC) (\arbno{\epsilon}\elt 1) \sigma),$\\ \>$\go{1}\wrong{out of memory}\sigma \end{semfun} \begin{semfun} \fun{tievalsrest} : (\arbno{\LOC} \to \CC) \to \arbno{\EXP} \to \NAT \to \CC$\\$ \fun{tievalsrest} =$\\ \go{1}$\lambda\psi\arbno{\epsilon}\nu\:.\:\fun{list}\: $\=$(\fun{dropfirst}\:\arbno{\epsilon}\nu)$\\ \>$(\fun{single}(\lambda\epsilon\:.\:\fun{tievals}\:\psi\: ((\fun{takefirst}\:\arbno{\epsilon}\nu)\:\S\:\langle\epsilon\rangle))) \end{semfun} \begin{semfun} \fun{dropfirst} = \lambda l n \:.\: n=0 \rightarrow l, \fun{dropfirst}\,(l \drop 1)(n - 1) \end{semfun} \begin{semfun} \fun{takefirst} = \lambda l n \:.\: n=0 \rightarrow \langle\:\rangle, \langle l \elt 1\rangle\:\S\:(\fun{takefirst}\,(l \drop 1)(n - 1)) \end{semfun} \begin{semfun} \fun{truish} : \EXP \to \TRU$\\$ \fun{truish} = \lambda\epsilon\:.\: % (\epsilon = \fun{false}\vee\epsilon = \fun{null})\rightarrow \epsilon = \fun{false}\rightarrow \fun{false}, \fun{true} \end{semfun} \begin{semfun} \fun{permute} : \arbno{\Exp} \to \arbno{\Exp} \hbox{\qquad [implementation-dependent]} \end{semfun} \begin{semfun} \fun{unpermute} : \arbno{\EXP} \to \arbno{\EXP} \hbox{\qquad [inverse of \fun{permute}]} \end{semfun} \begin{semfun} \fun{applicate} : \EXP \to \arbno{\EXP} \to \EC \to \CC$\\$ \fun{applicate} =$\\ \go{1}$\lambda\epsilon\arbno{\epsilon}\kappa\:.\: $\=$\epsilon\:\elem\:\FUN\rightarrow(\epsilon\:\vert\:\FUN\elt 2)\arbno{\epsilon}\kappa, \wrong{bad procedure} \end{semfun} \begin{semfun} \fun{onearg} : (\EXP \to \EC \to \CC) \to (\arbno{\EXP} \to \EC \to \CC)$\\$ \fun{onearg} =$\\ \go{1}$\lambda\zeta\arbno{\epsilon}\kappa\:.\: $\=$\#\arbno{\epsilon}=1\rightarrow\zeta(\arbno{\epsilon}\elt 1)\kappa,$\\ \>$\go{1}\wrong{wrong number of arguments} \end{semfun} \begin{semfun} \fun{twoarg} : (\EXP \to \EXP \to \EC \to \CC) \to (\arbno{\EXP} \to \EC \to \CC)$\\$ \fun{twoarg} =$\\ \go{1}$\lambda\zeta\arbno{\epsilon}\kappa\:.\: $\=$\#\arbno{\epsilon}=2\rightarrow\zeta(\arbno{\epsilon}\elt 1)(\arbno{\epsilon}\elt 2)\kappa,$\\ \>$\go{1}\wrong{wrong number of arguments} \end{semfun} \begin{semfun} \fun{list} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{list} =$\\ \go{1}$\lambda\arbno{\epsilon}\kappa\:.\: $\=$\#\arbno{\epsilon}=0\rightarrow\fun{send}\:\fun{null}\:\kappa,$\\ \>$\go{1}\fun{list}\,(\arbno{\epsilon}\drop 1) (\fun{single}(\lambda\epsilon\:.\: \fun{cons}\langle\arbno{\epsilon}\elt 1,\epsilon\rangle\kappa)) \end{semfun} \begin{semfun} \fun{cons} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{cons} =$\\ \go{1}$\fun{twoarg}\,(\lambda\epsilon_1\epsilon_2\kappa\sigma\:.\: $\=$\fun{new}\:\sigma\:\elem\:\LOC\rightarrow$\\ \> \go{1} \=$(\lambda\sigma^\prime\:.\: $\=$\fun{new}\:\sigma^\prime\:\elem\:\LOC\rightarrow$\\ \> \> \>$\go{1}\fun{send}\, $\=$($\=$\langle\fun{new}\:\sigma\:\vert\:\LOC, \fun{new}\:\sigma^\prime\:\vert\:\LOC, \fun{true}\rangle$\\ \> \> \> \> \>$\hbox{ \rm in }\EXP)$\\ \> \> \> \>$\kappa$\\ \> \> \> \>$(\fun{update}(\fun{new}\:\sigma^\prime\:\vert\:\LOC) \epsilon_2 \sigma^\prime),$\\ \> \> \>$\go{1}\wrong{out of memory}\sigma^\prime)$\\ \> \>$(\fun{update}(\fun{new}\:\sigma\:\vert\:\LOC)\epsilon_1\sigma),$\\ \>$\go{1}\wrong{out of memory}\sigma) \end{semfun} \begin{semfun} \fun{less} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{less} =$\\ \go{1}$\fun{twoarg}\,(\lambda\epsilon_1\epsilon_2\kappa\:.\: $\=$(\epsilon_1\:\elem\:\NUM\wedge\epsilon_2\:\elem\:\NUM)\rightarrow$\\ \>$\go{1}\fun{send}\, (\epsilon_1\:\vert\:\NUM<\epsilon_2\:\vert\:\NUM\rightarrow \fun{true}, \fun{false}) \kappa,$\\ \>$\go{1}\wrong{non-numeric argument to \ide{<}}) \end{semfun} \begin{semfun} \fun{add} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{add} =$\\ \go{1}$\fun{twoarg}\,(\lambda\epsilon_1\epsilon_2\kappa\:.\: $\=$(\epsilon_1\:\elem\:\NUM\wedge\epsilon_2\:\elem\:\NUM)\rightarrow$\\ \>$\go{1}\fun{send}\, $\=$((\epsilon_1\:\vert\:\NUM+\epsilon_2\:\vert\:\NUM)\hbox{ \rm in }\EXP) \kappa,$\\ \>$\go{1}\wrong{non-numeric argument to \ide{+}}) \end{semfun} \begin{semfun} \fun{car} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{car} =$\\ \go{1}$\fun{onearg}\,(\lambda\epsilon\kappa\:.\: $\=$\epsilon\:\elem\:\PAI\rightarrow \fun{hold}\, (\epsilon\:\vert\:\PAI\elt 1) \kappa,$\\ \>$\go{1}\wrong{non-pair argument to \ide{car}}) \end{semfun} \begin{semfun} \fun{cdr} : \arbno{\EXP} \to \EC \to \CC %$\\$ \hbox{\qquad [similar to \fun{car}]} \end{semfun} \begin{semfun} \fun{setcar} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{setcar} =$\\ \go{1}$\fun{twoarg}\,(\lambda\epsilon_1\epsilon_2\kappa\:.\: $\=$\epsilon_1\:\elem\:\PAI\rightarrow$\\ \>$(\epsilon_1\:\vert\:\PAI\elt 3)\rightarrow \fun{assign}\,$\=$(\epsilon_1\:\vert\:\PAI\elt 1)$\\ \> \>$\epsilon_2$\\ \> \>$(\fun{send}\:\fun{unspecified}\:\kappa),$\\ \>$\wrong{immutable argument to \ide{set-car!}},$\\ \>$\wrong{non-pair argument to \ide{set-car!}}) \end{semfun} \begin{semfun} \fun{eqv} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{eqv} =$\\ \go{1}$\fun{twoarg}\,(\lambda\epsilon_1\epsilon_2\kappa\:.\: $\=$(\epsilon_1\:\elem\:\MSC\wedge\epsilon_2\:\elem\:\MSC)\rightarrow$\\ \>$\go{1}\fun{send}\, $\=$(\epsilon_1\:\vert\:\MSC = \epsilon_2\:\vert\:\MSC\rightarrow\fun{true}, \fun{false})\kappa,$\\ \>$(\epsilon_1\:\elem\:\SYM\wedge\epsilon_2\:\elem\:\SYM)\rightarrow$\\ \>$\go{1}\fun{send}\, $\=$(\epsilon_1\:\vert\:\SYM = \epsilon_2\:\vert\:\SYM\rightarrow\fun{true}, \fun{false})\kappa,$\\ \>$(\epsilon_1\:\elem\:\CHR\wedge\epsilon_2\:\elem\:\CHR)\rightarrow$\\ \>$\go{1}\fun{send}\, $\=$(\epsilon_1\:\vert\:\CHR = \epsilon_2\:\vert\:\CHR \rightarrow\fun{true}, \fun{false})\kappa,$\\ \>$(\epsilon_1\:\elem\:\NUM\wedge\epsilon_2\:\elem\:\NUM)\rightarrow$\\ \>$\go{1}\fun{send}\, $\=$(\epsilon_1\:\vert\:\NUM=\epsilon_2\:\vert\:\NUM\rightarrow\fun{true}, \fun{false})\kappa,$\\ \>$(\epsilon_1\:\elem\:\PAI\wedge\epsilon_2\:\elem\:\PAI)\rightarrow$\\ \>$\go{1}\fun{send}\, $\=$($\=$(\lambda{p_1}{p_2}\:.\: ($\=$({p_1}\elt 1) = ({p_2}\elt 1)\wedge$\\ \> \> \> \>$({p_1}\elt 2) = ({p_2}\elt 2)) \rightarrow\fun{true},$\\ \> \> \> \>$\go{1}\fun{false})$\\ \> \> \>$(\epsilon_1\:\vert\:\PAI)$\\ \> \> \>$(\epsilon_2\:\vert\:\PAI))$\\ \> \>$\kappa,$\\ \>$(\epsilon_1\:\elem\:\VEC\wedge\epsilon_2\:\elem\:\VEC)\rightarrow %\fun{send}\, % $\=$((\#(\epsilon_1\:\vert\:\VEC)=\#(\epsilon_2\:\vert\:\VEC) % \wedge\hbox{\rm Y}(\lambda\fun{loop}\:.\:\lambda\fun{v1}\fun{v2}\:.\: % $\=$\#\fun{v1}=0\rightarrow\fun{true},$\\ % \> \> \>$(\fun{v1}\elt 1) = (\fun{v2}\elt 1)\rightarrow % \fun{loop}(\fun{v1}\drop 1)(\fun{v2}\drop 1),$\\ % \> \> \>$\go{1}\fun{false})(\epsilon_1\:\vert\:\VEC)(\epsilon_2\:\vert\:\VEC)) % \rightarrow\fun{true},$\\ % \> \>$\go{1}\fun{false})\kappa \ldots,$\\ \>$(\epsilon_1\:\elem\:\STR\wedge\epsilon_2\:\elem\:\STR)\rightarrow %\fun{send}\, % $\=$((\#(\epsilon_1\:\vert\:\STR)=\#(\epsilon_2\:\vert\:\STR)\wedge % \hbox{\rm Y}(\lambda\fun{loop}\:.\:\lambda\fun{v1}\fun{v2}\:.\: % $\=$\#\fun{v1}=0\rightarrow\fun{true},$\\ % \> \> \>$(\fun{v1}\elt 1) = (\fun{v2}\elt 1)\rightarrow % \fun{loop}(\fun{v1}\drop 1)(\fun{v2}\drop 1),$\\ % \> \> \>$\go{1}\fun{false})(\epsilon_1\:\vert\:\STR)(\epsilon_2\:\vert\:\STR)) % \rightarrow\fun{true},$\\ % \> \>$\go{1}\fun{false})\kappa \ldots,$\\ \>$(\epsilon_1\:\elem\:\FUN\wedge\epsilon_2\:\elem\:\FUN)\rightarrow$\\ \>$\go{1}\fun{send}\, $\=$((\epsilon_1\:\vert\:\FUN\elt 1) = (\epsilon_2\:\vert\:\FUN\elt 1) \rightarrow\fun{true}, \fun{false})$\\ \> \>$\kappa,$\\ \>$\go{1}\fun{send}\,\:\fun{false}\:\kappa) \end{semfun} \begin{semfun} \fun{apply} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{apply} =$\\ \go{1}$\fun{twoarg}\,(\lambda\epsilon_1\epsilon_2\kappa\:.\: $\=$\epsilon_1\:\elem\:\FUN\rightarrow \fun{valueslist}\,\langle\epsilon_2\rangle (\lambda\arbno{\epsilon}\:.\:\fun{applicate}\:\epsilon_1\arbno{\epsilon}\kappa),$\\ \>$\go{1}\wrong{bad procedure argument to \ide{apply}}) \end{semfun} \begin{semfun} \fun{valueslist} : \arbno{\EXP} \to \EC \to \CC$\\$ \fun{valueslist} =$\\ \go{1}$\fun{onearg}\,(\lambda\epsilon\kappa\:.\: $\=$\epsilon\:\elem\:\PAI\rightarrow$\\ \>$\go{1}\fun{cdr} $\=$\langle\epsilon\rangle$\\ \> \>$(\lambda\arbno{\epsilon}\:.\: $\=$\fun{valueslist}\:$\\ \> \> \>$\arbno{\epsilon}$\\ \> \> \>$(\lambda\arbno{\epsilon}\:.\:\fun{car}\langle\epsilon\rangle (\fun{single}(\lambda\epsilon\:.\: \kappa(\langle\epsilon\rangle\:\S\:\arbno{\epsilon}))))),$\\ \>$\epsilon = \fun{null}\rightarrow\kappa\langle\:\rangle,$\\ \>$\go{1}\wrong{non-list argument to \ide{values-list}}) \end{semfun} \begin{semfun} \fun{cwcc} : \arbno{\EXP} \to \EC \to \CC \hbox{\qquad [\ide{call-with-current-continuation}]}$\\$ \fun{cwcc} =$\\ \go{1}$\fun{onearg}\,(\lambda\epsilon\kappa\:.\: $\=$\epsilon\:\elem\:\FUN\rightarrow$\\ \>$\go{1}(\lambda\sigma\:.\: $\=$\fun{new}\:\sigma\:\elem\:\LOC\rightarrow$\\ \> \>$\go{1}\fun{applicate}\: $\=$\epsilon$\\ \> \> \>$\langle\langle\fun{new}\:\sigma\:\vert\:\LOC, \lambda\arbno{\epsilon}\kappa^\prime\:.\: \kappa\arbno{\epsilon}\rangle \hbox{ \rm in }\EXP\rangle$\\ \> \> \>$\kappa$\\ \> \> \>$(\fun{update}\, $\=$(\fun{new}\:\sigma\:\vert\:\LOC)$\\ \> \> \> \>$\fun{unspecified}$\\ \> \> \> \>$\sigma),$\\ \> \>$\go{1}\wrong{out of memory}\,\sigma),$\\ \>$\go{1}\wrong{bad procedure argument}) \end{semfun} \egroup % end smallish \egroup scheme2c-2012.10.14/doc/r4rs/struct.tex000066400000000000000000000260151203736146400173120ustar00rootroot00000000000000% 1. Structure of the language \chapter{Overview of Scheme} \section{Semantics} \label{semanticsection} This section gives an overview of Scheme's semantics. A detailed informal semantics is the subject of chapters~\ref{basicchapter} through~\ref{builtinchapter}. For reference purposes, section~\ref{formalsemanticssection} provides a formal semantics of Scheme. \vest Following Algol, Scheme is a statically scoped programming language. Each use of a variable is associated with a lexically apparent binding of that variable. \vest Scheme has latent as opposed to manifest types. Types are associated with values (also called objects\mainindex{object}) rather than with variables. (Some authors refer to languages with latent types as weakly typed or dynamically typed languages.) Other languages with latent types are APL, Snobol, and other dialects of Lisp. Languages with manifest types (sometimes referred to as strongly typed or statically typed languages) include Algol 60, Pascal, and~C. \vest All objects created in the course of a Scheme computation, including procedures and continuations, have unlimited extent. No Scheme object is ever destroyed. The reason that implementations of Scheme do not (usually!)\ run out of storage is that they are permitted to reclaim the storage occupied by an object if they can prove that the object cannot possibly matter to any future computation. Other languages in which most objects have unlimited extent include APL and other Lisp dialects. \vest Implementations of Scheme are required to be properly tail-recursive. This allows the execution of an iterative computation in constant space, even if the iterative computation is described by a syntactically recursive procedure. Thus with a tail-recursive implementation, iteration can be expressed using the ordinary procedure-call mechanics, so that special iteration constructs are useful only as syntactic sugar. \vest Scheme procedures are objects in their own right. Procedures can be created dynamically, stored in data structures, returned as results of procedures, and so on. Other languages with these properties include Common Lisp and ML. \todo{Rozas: Scheme had them first.} \vest One distinguishing feature of Scheme is that continuations, which in most other languages only operate behind the scenes, also have ``first-class'' status. Continuations are useful for implementing a wide variety of advanced control constructs, including non-local exits, backtracking, and coroutines. See section~\ref{continuations}. \vest Arguments to Scheme procedures are always passed by value, which means that the actual argument expressions are evaluated before the procedure gains control, whether the procedure needs the result of the evaluation or not. ML, C, and APL are three other languages that always pass arguments by value. This is distinct from the lazy-evaluation semantics of Haskell, or the call-by-name semantics of Algol 60, where an argument expression is not evaluated unless its value is needed by the procedure. \todo{Lisp's call by value should be explained more accurately. What's funny is that all values are references.} \vest Scheme's model of arithmetic is designed to remain as independent as possible of the particular ways in which numbers are represented within a computer. In Scheme, every integer is a rational number, every rational is a real, and every real is a complex number. Thus the distinction between integer and real arithmetic, so important to many programming languages, does not appear in Scheme. In its place is a distinction between exact arithmetic, which corresponds to the mathematical ideal, and inexact arithmetic on approximations. As in Common Lisp, exact arithmetic is not limited to integers. \section{Syntax} Scheme, like most dialects of Lisp, employs a fully parenthesized prefix notation for programs and (other) data; the grammar of Scheme generates a sublanguage of the language used for data. An important consequence of this simple, uniform representation is the susceptibility of Scheme programs and data to uniform treatment by other Scheme programs. The \ide{read} procedure performs syntactic as well as lexical decomposition of the data it reads. The \ide{read} procedure parses its input as data (section~\ref{datumsyntax}), not as program. The formal syntax of Scheme is described in section~\ref{BNF}. \section{Notation and terminology} \subsection{Essential and non-essential features} \label{essentialsection} It is required that every implementation of Scheme support features that are marked as being \defining{essential}. Features not explicitly marked as essential are not essential. Implementations are free to omit non-essential features of Scheme or to add extensions, provided the extensions are not in conflict with the language reported here. In particular, implementations must support portable code by providing a syntactic mode that preempts no lexical conventions of this report and reserves no identifiers other than those listed as syntactic keywords in section~\ref{keywordsection}. \subsection{Error situations and unspecified behavior} \mainindex{error} When speaking of an error situation, this report uses the phrase ``an error is signalled'' to indicate that implementations must detect and report the error. If such wording does not appear in the discussion of an error, then implementations are not required to detect or report the error, though they are encouraged to do so. An error situation that implementations are not required to detect is usually referred to simply as ``an error.'' \vest For example, it is an error for a procedure to be passed an argument that the procedure is not explicitly specified to handle, even though such domain errors are seldom mentioned in this report. Implementations may extend a procedure's domain of definition to include such arguments. \vest This report uses the phrase ``may report a violation of an implementation restriction'' to indicate circumstances under which an implementation is permitted to report that it is unable to continue execution of a correct program because of some restriction imposed by the implementation. Implementation restrictions are of course discouraged, but implementations are encouraged to report violations of implementation restrictions.\mainindex{implementation restriction} \vest For example, an implementation may report a violation of an implementation restriction if it does not have enough storage to run a program. \vest If the value of an expression is said to be ``unspecified,'' then the expression must evaluate to some object without signalling an error, but the value depends on the implementation; this report explicitly does not say what value should be returned. \mainindex{unspecified} \todo{Talk about unspecified behavior vs. unspecified values.} \todo{Look at KMP's situations paper.} \subsection{Entry format} Chapters~\ref{expressionchapter} and~\ref{builtinchapter} are organized into entries. Each entry describes one language feature or a group of related features, where a feature is either a syntactic construct or a built-in procedure. An entry begins with one or more header lines of the form \noindent\pproto{\var{template}}{essential \var{category}}\unpenalty if the feature is an essential feature, or simply \noindent\pproto{\var{template}}{\var{category}}\unpenalty if the feature is not an essential feature. If \var{category} is ``\exprtype'', the entry describes an expression type, and the header line gives the syntax of the expression type. Components of expressions are designated by syntactic variables, which are written using angle brackets, for example, \hyper{expression}, \hyper{variable}. Syntactic variables should be understood to denote segments of program text; for example, \hyper{expression} stands for any string of characters which is a syntactically valid expression. The notation \begin{tabbing} \qquad \hyperi{thing} $\ldots$ \end{tabbing} indicates zero or more occurrences of a \hyper{thing}, and \begin{tabbing} \qquad \hyperi{thing} \hyperii{thing} $\ldots$ \end{tabbing} indicates one or more occurrences of a \hyper{thing}. If \var{category} is ``procedure'', then the entry describes a procedure, and the header line gives a template for a call to the procedure. Argument names in the template are \var{italicized}. Thus the header line \noindent\pproto{(vector-ref \var{vector} \var{k})}{essential procedure}\unpenalty indicates that the essential built-in procedure {\tt vector-ref} takes two arguments, a vector \var{vector} and an exact non-negative integer \var{k} (see below). The header lines \noindent% \pproto{(make-vector \var{k})}{essential procedure} \pproto{(make-vector \var{k} \var{fill})}{procedure}\unpenalty indicate that in all implementations, the {\tt make-vector} procedure must be defined to take one argument, and some implementations will extend it to take two arguments. \label{typeconventions} It is an error for an operation to be presented with an argument that it is not specified to handle. For succinctness, we follow the convention that if an argument name is also the name of a type listed in section~\ref{disjointness}, then that argument must be of the named type. For example, the header line for {\tt vector-ref} given above dictates that the first argument to {\tt vector-ref} must be a vector. The following naming conventions also imply type restrictions: \newcommand{\foo}[1]{\vr{#1}, \vri{#1}, $\ldots$ \vrj{#1}, $\ldots$} $$ \begin{tabular}{ll} \var{obj}&any object\\ \foo{list}&list (see section~\ref{listsection})\\ \foo{z}&complex number\\ \foo{x}&real number\\ \foo{y}&real number\\ \foo{q}&rational number\\ \foo{n}&integer\\ \foo{k}&exact non-negative integer\\ \end{tabular} $$ \todo{Provide an example entry??} \subsection{Evaluation examples} The symbol ``\evalsto'' used in program examples should be read ``evaluates to.'' For example, \begin{scheme} (* 5 8) \ev 40% \end{scheme} means that the expression {\tt(* 5 8)} evaluates to the object {\tt 40}. Or, more precisely: the expression given by the sequence of characters ``{\tt(* 5 8)}'' evaluates, in the initial environment, to an object that may be represented externally by the sequence of characters ``{\tt 40}''. See section~\ref{externalreps} for a discussion of external representations of objects. \subsection{Naming conventions} By convention, the names of procedures that always return a boolean value usually end in ``\ide{?}''. Such procedures are called predicates.\schindex{?} By convention, the names of procedures that store values into previously allocated locations (see section~\ref{storagemodel}) usually end in ``\ide{!}''. Such procedures are called mutation procedures. By convention, the value returned by a mutation procedure is unspecified. \schindex{!} By convention, ``\ide{->}'' appears within the names of procedures that take an object of one type and return an analogous object of another type. For example, \ide{list->vector} takes a list and returns a vector whose elements are the same as those of the list.\schindex{->} \todo{Terms that need defining: thunk, command (what else?).}scheme2c-2012.10.14/doc/r4rs/syn.tex000066400000000000000000000260711203736146400166010ustar00rootroot00000000000000\chapter{Formal syntax and semantics} \label{formalchapter} This chapter provides formal descriptions of what has already been described informally in previous chapters of this report. \todo{Allow grammar to say that else clause needn't be last?} \section{Formal syntax} \label{BNF} This section provides a formal syntax for Scheme written in an extended BNF. The syntax for the entire language, including features which are not essential, is given here. All spaces in the grammar are for legibility. Case is insignificant; for example, {\cf \#x1A} and {\cf \#X1a} are equivalent. \meta{empty} stands for the empty string. The following extensions to BNF are used to make the description more concise: \arbno{\meta{thing}} means zero or more occurrences of \meta{thing}; and \atleastone{\meta{thing}} means at least one \meta{thing}. \subsection{Lexical structure} This section describes how individual tokens\index{token} (identifiers, numbers, etc.) are formed from sequences of characters. The following sections describe how expressions and programs are formed from sequences of tokens. \meta{Intertoken space} may occur on either side of any token, but not within a token. \vest Tokens which require implicit termination (identifiers, numbers, characters, and dot) may be terminated by any \meta{delimiter}, but not necessarily by anything else. \begin{grammar}% \meta{token} \: \meta{identifier} \| \meta{boolean} \| \meta{number}\index{identifier} \> \| \meta{character} \| \meta{string} \> \| ( \| ) \| \sharpsign( \| \singlequote{} \| \backquote{} \| , \| ,@ \| {\bf.} \meta{delimiter} \: \meta{whitespace} \| ( \| ) \| " \| ; \meta{whitespace} \: \meta{space or newline} \meta{comment} \: ; \= $\langle$\rm all subsequent characters up to a \>\ \rm line break$\rangle$\index{comment} \meta{atmosphere} \: \meta{whitespace} \| \meta{comment} \meta{intertoken space} \: \arbno{\meta{atmosphere}}% \end{grammar} \label{extendedalphas} \label{identifiersyntax} % This is a kludge, but \multicolumn doesn't work in tabbing environments. \setbox0\hbox{\cf\meta{variable} \goesto{} $\langle$} \begin{grammar}% \meta{identifier} \: \meta{initial} \arbno{\meta{subsequent}} \> \| \meta{peculiar identifier} \meta{initial} \: \meta{letter} \| \meta{special initial} \meta{letter} \: a \| b \| c \| ... \| z \meta{special initial} \: ! \| \$ \| \% \| \verb"&" \| * \| / \| : \| < \| = \> \| > \| ? \| \verb"~" \| \verb"_" \| \verb"^" \meta{subsequent} \: \meta{initial} \| \meta{digit} \> \| \meta{special subsequent} \meta{digit} \: 0 \| 1 \| 2 \| 3 \| 4 \| 5 \| 6 \| 7 \| 8 \| 9 \meta{special subsequent} \: .\ \| + \| - \meta{peculiar identifier} \: + \| - \| ... %\| 1+ \| -1+ \meta{syntactic keyword} \: \meta{expression keyword}\index{keyword}\index{syntactic keyword} \> \| else \| => \| define \> \| unquote \| unquote-splicing \meta{expression keyword} \: quote \| lambda \| if \> \| set! \| begin \| cond \| and \| or \| case \> \| let \| let* \| letrec \| do \| delay \> \| quasiquote \copy0\rm any \meta{identifier} that isn't\index{variable} \hbox to 1\wd0{\hfill}\ \rm also a \meta{syntactic keyword}$\rangle$ \meta{boolean} \: \schtrue{} \| \schfalse{} \meta{character} \: \#\backwhack{} \meta{any character} \> \| \#\backwhack{} \meta{character name} \meta{character name} \: space \| newline \todo{Explain what happens in the ambiguous case.} \meta{string} \: " \arbno{\meta{string element}} " \meta{string element} \: \meta{any character other than \doublequote{} or \backwhack} \> \| \backwhack\doublequote{} \| \backwhack\backwhack % \end{grammar} \label{numbersyntax} \begin{grammar}% \meta{number} \: \meta{num $2$}% \| \meta{num $8$} \> \| \meta{num $10$}% \| \meta{num $16$} \end{grammar} The following rules for \meta{num $R$}, \meta{complex $R$}, \meta{real $R$}, \meta{ureal $R$}, \meta{uinteger $R$}, and \meta{prefix $R$} should be replicated for \hbox{$R = 2, 8, 10,$} and $16$. There are no rules for \meta{decimal $2$}, \meta{decimal $8$}, and \meta{decimal $16$}, which means that numbers containing decimal points or exponents must be in decimal radix. \todo{Mark Meyer and David Bartley want to fix this. (What? -- Will)} \begin{grammar}% \meta{num $R$} \: \meta{prefix $R$} \meta{complex $R$} \meta{complex $R$} \: % \meta{real $R$} % \| \meta{real $R$} @ \meta{real $R$} \> \| \meta{real $R$} + \meta{ureal $R$} i % \| \meta{real $R$} - \meta{ureal $R$} i \> \| \meta{real $R$} + i % \| \meta{real $R$} - i \> \| + \meta{ureal $R$} i % \| - \meta{ureal $R$} i % \| + i % \| - i \meta{real $R$} \: \meta{sign} \meta{ureal $R$} \meta{ureal $R$} \: % \meta{uinteger $R$} \> \| \meta{uinteger $R$} / \meta{uinteger $R$} \> \| \meta{decimal $R$} \meta{decimal $10$} \: % \meta{uinteger $10$} \meta{suffix} \> \| . \atleastone{\meta{digit $10$}} \arbno{\#} \meta{suffix} \> \| \atleastone{\meta{digit $10$}} . \arbno{\meta{digit $10$}} \arbno{\#} \meta{suffix} \> \| \atleastone{\meta{digit $10$}} \atleastone{\#} . \arbno{\#} \meta{suffix} \meta{uinteger $R$} \: \atleastone{\meta{digit $R$}} \arbno{\#} \meta{prefix $R$} \: % \meta{radix $R$} \meta{exactness} \> \| \meta{exactness} \meta{radix $R$} \end{grammar} \begin{grammar}% \meta{suffix} \: \meta{empty} \> \| \meta{exponent marker} \meta{sign} \atleastone{\meta{digit $10$}} \meta{exponent marker} \: e \| s \| f \| d \| l \meta{sign} \: \meta{empty} \| + \| - \meta{exactness} \: \meta{empty} \| \#i\sharpindex{i} \| \#e\sharpindex{e} \meta{radix 2} \: \#b\sharpindex{b} \meta{radix 8} \: \#o\sharpindex{o} \meta{radix 10} \: \meta{empty} \| \#d \meta{radix 16} \: \#x\sharpindex{x} \meta{digit 2} \: 0 \| 1 \meta{digit 8} \: 0 \| 1 \| 2 \| 3 \| 4 \| 5 \| 6 \| 7 \meta{digit 10} \: \meta{digit} \meta{digit 16} \: \meta{digit $10$} \| a \| b \| c \| d \| e \| f % \end{grammar} \todo{Mark Meyer of TI sez, shouldn't we allow {\tt 1e3/2}?} \subsection{External representations} \label{datumsyntax} \meta{Datum} is what the \ide{read} procedure (section~\ref{read}) successfully parses. Note that any string that parses as an \meta{ex\-pres\-sion} will also parse as a \meta{datum}. \label{datum} \begin{grammar}% \meta{datum} \: \meta{simple datum} \| \meta{compound datum} \meta{simple datum} \: \meta{boolean} \| \meta{number} \> \| \meta{character} \| \meta{string} \| \meta{symbol} \meta{symbol} \: \meta{identifier} \meta{compound datum} \: \meta{list} \| \meta{vector} \meta{list} \: (\arbno{\meta{datum}}) \| (\atleastone{\meta{datum}} .\ \meta{datum}) \> \| \meta{abbreviation} \meta{abbreviation} \: \meta{abbrev prefix} \meta{datum} \meta{abbrev prefix} \: ' \| ` \| , \| ,@ \meta{vector} \: \#(\arbno{\meta{datum}}) % \end{grammar} \subsection{Expressions} \begin{grammar}% \meta{expression} \: \meta{variable} \> \| \meta{literal} \> \| \meta{procedure call} \> \| \meta{lambda expression} \> \| \meta{conditional} \> \| \meta{assignment} \> \| \meta{derived expression} \meta{literal} \: \meta{quotation} \| \meta{self-evaluating} \meta{self-evaluating} \: \meta{boolean} \| \meta{number} \> \| \meta{character} \| \meta{string} \meta{quotation} \: '\meta{datum} \| (quote \meta{datum}) \meta{procedure call} \: (\meta{operator} \arbno{\meta{operand}}) \meta{operator} \: \meta{expression} \meta{operand} \: \meta{expression} \meta{lambda expression} \: (lambda \meta{formals} \meta{body}) \meta{formals} \: (\arbno{\meta{variable}}) \| \meta{variable} \> \| (\atleastone{\meta{variable}} .\ \meta{variable}) \meta{body} \: \arbno{\meta{definition}} \meta{sequence} \meta{sequence} \: \arbno{\meta{command}} \meta{expression} \meta{command} \: \meta{expression} \meta{conditional} \: (if \meta{test} \meta{consequent} \meta{alternate}) \meta{test} \: \meta{expression} \meta{consequent} \: \meta{expression} \meta{alternate} \: \meta{expression} \| \meta{empty} \meta{assignment} \: (set! \meta{variable} \meta{expression}) \meta{derived expression} \: \> \> (cond \atleastone{\meta{cond clause}}) \> \| (cond \arbno{\meta{cond clause}} (else \meta{sequence})) \> \| (c\=ase \meta{expression} \> \>\atleastone{\meta{case clause}}) \> \| (c\=ase \meta{expression} \> \>\arbno{\meta{case clause}} \> \>(else \meta{sequence})) \> \| (and \arbno{\meta{test}}) \> \| (or \arbno{\meta{test}}) \> \| (let (\arbno{\meta{binding spec}}) \meta{body}) \> \| (let \meta{variable} (\arbno{\meta{binding spec}}) \meta{body}) \> \| (let* (\arbno{\meta{binding spec}}) \meta{body}) \> \| (letrec (\arbno{\meta{binding spec}}) \meta{body}) \> \| (begin \meta{sequence}) \> \| (d\=o \=(\arbno{\meta{iteration spec}}) \> \> \>(\meta{test} \meta{sequence}) \> \>\arbno{\meta{command}}) \> \| (delay \meta{expression}) \> \| \meta{quasiquotation} \meta{cond clause} \: (\meta{test} \meta{sequence}) \> \| (\meta{test}) \> \| (\meta{test} => \meta{recipient}) \meta{recipient} \: \meta{expression} \meta{case clause} \: ((\arbno{\meta{datum}}) \meta{sequence}) \meta{binding spec} \: (\meta{variable} \meta{expression}) \meta{iteration spec} \: (\meta{variable} \meta{init} \meta{step}) \> \| (\meta{variable} \meta{init}) \meta{init} \: \meta{expression} \meta{step} \: \meta{expression} % \end{grammar} \subsection{Quasiquotations} The following grammar for quasiquote expressions is not context-free. It is presented as a recipe for generating an infinite number of production rules. Imagine a copy of the following rules for $D = 1, 2, 3, \ldots$. $D$ keeps track of the nesting depth. \begin{grammar}% \meta{quasiquotation} \: \meta{quasiquotation 1} \meta{template 0} \: \meta{expression} \meta{quasiquotation $D$} \: `\meta{template $D$} \> \| (quasiquote \meta{template $D$}) \meta{template $D$} \: \meta{simple datum} \> \| \meta{list template $D$} \> \| \meta{vector template $D$} \> \| \meta{unquotation $D$} \meta{list template $D$} \: (\arbno{\meta{template or splice $D$}}) \> \| (\atleastone{\meta{template or splice $D$}} .\ \meta{template $D$}) \> \| '\meta{template $D$} \> \| \meta{quasiquotation $D+1$} \meta{vector template $D$} \: \#(\arbno{\meta{template or splice $D$}}) \meta{unquotation $D$} \: ,\meta{template $D-1$} \> \| (unquote \meta{template $D-1$}) \meta{template or splice $D$} \: \meta{template $D$} \> \| \meta{splicing unquotation $D$} \meta{splicing unquotation $D$} \: ,@\meta{template $D-1$} \> \| (unquote-splicing \meta{template $D-1$}) % \end{grammar} In \meta{quasiquotation}s, a \meta{list template $D$} can sometimes be confused with either an \meta{un\-quota\-tion $D$} or a \meta{splicing un\-quo\-ta\-tion $D$}. The interpretation as an \meta{un\-quo\-ta\-tion} or \meta{splicing un\-quo\-ta\-tion $D$} takes precedence. \subsection{Programs and definitions} \begin{grammar}% \meta{program} \: \arbno{\meta{command or definition}} \meta{command or definition} \: \meta{command} \| \meta{definition} \meta{definition} \: (define \meta{variable} \meta{expression}) \> \| (define (\meta{variable} \meta{def formals}) \meta{body}) \> \| (begin \arbno{\meta{definition}}) \meta{def formals} \: \arbno{\meta{variable}} \> \| \atleastone{\meta{variable}} .\ \meta{variable} % \end{grammar} scheme2c-2012.10.14/doc/s2c.sty000066400000000000000000000002361203736146400155770ustar00rootroot00000000000000%%\newcommand{\StoC}[0]{\texttt{Scheme->C}} \newcommand{\StoC}[0]{\mbox{Scheme\texttt{->}C}} \newcommand{\RRRRS}[0]{R$^3$RS} \newcommand{\RRRRRS}[0]{R$^4$RS} scheme2c-2012.10.14/doc/s2cc.l000066400000000000000000000154271203736146400153660ustar00rootroot00000000000000.TH S2CC 1 local .SH NAME s2cc \- Scheme to C compiler .SH SYNTAX .B s2cc [ option ] ... file ... .SH DESCRIPTION The .B s2cc command (previously known as \fBscc\fR) invokes a Scheme compiler which accepts the language defined in the essential portions of .I Revised\v'-0.3m'4\v'0.3m' Report on the Algorithmic Language Scheme, with minor constraints and some additions. The compiler produces C source files which are then compiled using the system's C compiler to produce conventional \fI.o\fR and \fIa.out\fR files. The C code produced by this compiler may be intermixed with other C code or code written in other languages. .SH OPTIONS These options are accepted by \fBs2cc\fR. Other options will be assumed to be options of the system's C compiler and they will be passed to it when it is invoked. .TP 18 \fB-cc \fIC compiler\fR Compile the Scheme compiler produced C code with \fIC compiler\fR. If this flag is not supplied, then the C compiler \fIcc\fR will be used. .TP 18 .B -C Compile the Scheme programs found in the files \fIsource\fR.sc and leave the resulting code in \fIsource\fR.c files. No further operations are performed. .TP 18 \fB-I \fIdirectory\fR Specifies a directory to be searched by include for source files. .TP 18 \fB-f \fIsymbol value\fR Define the compile-time constant .I symbol to .I value. This is equivalent to the construct (define-constant .I symbol .IR value ) appearing in the Scheme source. .TP 18 .B -i Combine the source and object files into a Scheme interpreter. The module name for each Scheme source file is automatically determined. Module names for previously compiled modules must be specified using the \fB-m\fR option. .TP 18 \fB-m \fImodule-name\fR Specifies the name of a previously compiled module. Note that the Scheme compiler will downshift the alphabetic characters in the \fImodule-name\fR. Modules are initialized in the order that the \fB-m\fR flags appear. .TP 18 .B -Ob Optimize code by omitting bounds checks on vectors and strings. .TP 18 .B -Og Optimize code by omitting stack trace-back code. .TP 18 .B -On Optimize code by assuming that all numbers are fixed point. .TP 18 .B -Ot Optimize code by omitting type error checks. .TP 18 .B -pg Produce profiled code for run-time measurement using .I gprof(1). The profiled library is used in lieu of the standard Scheme library. .TP 18 \fB-scgc \fIstatflag\fR Enables garbage collection statistics. If set to 1, then garbage collection statistics will be printed. The default is 0, that will result in no statistics. .TP 18 \fB-sch \fIheap\fR Specifies the compiler's initial heap size in megabytes. The default is system dependent. .TP 18 \fB-scl \fIpercent\fR Specifies the percent of the heap allocated after a generational garbage collection that will force a full collection. The default is 40. .TP 18 \fB-scmh \fIheap\fR Specifies the compiler's maximum heap size in megabytes. The default is five times the initial size of the heap. .TP 18 \fB-LIBDIR \fIdirectory\fR Specifies a directory containing the files: predef.sc, objects.h, libs2c.a, and optionally libs2c_p.a. .TP 18 \fB-log\fR Logs information internal to the compiler to the C source file produced by the compiler. Each type of information is controlled by a flag: \fB-source\fR, \fB-macro\fR, \fB-expand\fR, \fB-closed\fR, \fB-transform\fR, \fB-lambda\fR, \fB-tree\fR, \fB-lap\fR, \fB-peep\fR. The flag \fB-log\fR is equivalent to specifying the flags: \fB-source\fR, \fB-macro\fR, \fB-expand\fR, \fB-closed\fR, \fB-transform\fR, \fB-lambda\fR, \fB-tree\fR. .SH ENVIRONMENT VARIABLES The items controlled by \fI-sc..\fR flags can also be controlled by environment variables. If both the flag and the environment variable are provided, then the flag's value will be used. .TP 18 .B SCGCINFO Controls the reporting of garbage collection statistics to the standard error file. If set to 1, then garbage collection statistics will be printed. The default setting is 0 that will not print the statistics. .TP 18 .B SCHEAP Specifies the initial size of the heap in megabytes. The default heap size is system dependent. .TP 18 .B SCLIMIT Specifies the percent of the heap allocated after a generational garbage collection that will force a full collection. The default is 40. .TP 18 .B SCMAXHEAP Specifies the maximum size of the heap in megabytes. .SH INPUT FILES Following the command options come one or more file names. .TP 18 .IR name .sc Scheme source. Scheme source files will be compiled into C files with the name \fIname\fR.c. .TP 18 .IR name .c C source. .TP 18 .IR name .s Assembly language source. .TP 18 .IR name .o Object file which may have been generated by any compiler. .TP 18 .IR name .a Object file archive which may have been generated by any compiler. .SH DIAGNOSTICS The disgnostic messages produced by the compiler are printed on the standard error file. .SH FILES .ta 2.0i /.../schemetoc/... source and documentation .br /.../libs2c.a library .br /.../libs2c_p.a profiled library (optional) .br /.../s2cc shell script .br /.../s2ccomp compiler .br /.../predef.sc predefined functions .br /.../objects.h definitions "#include'd" in the C code .br SC-TO-C.c temporary C source file .br \fIsource\fR.S2C temporary C source file .br SC-TO-C.o temporary object file .br .SH LIMITATIONS When the compiler is able to identify every call to a procedure, it is able to generate it "in-line", and perform tail calls by using "goto". This analysis covers most loops, conditional expressions, and finite state machines. For non-tail recursive calls, the code generated by the compiler uses the standard C mechanisms for procedure call and return. This therefore requires that each top-level Scheme procedure, and any Scheme procedure which has more than one call which is not tail-recursive be compiled into its own C procedure. Calls to such procedures will be tail-recursive if and only if the host C compiler optimizes tail-recursion. .SH SEE ALSO .PP Harold Abelson and Gerald Jay Sussman with Julie Sussman, .I Structure and Interpretation of Computer Programs, The MIT Press. .PP William Clinger and Jonathan Rees (Editors), .I Revised\v'-0.3m'4\v'0.3m' Report on the Algorithmic Language Scheme, LISP Pointers, Volume IV, Number 3, July-September 1991. PostScript for this file is included in the software distribution. .PP Jerry D. Smith, .I An Introduction to Scheme, Prentice Hall, Inc. Chapter notes for using this text with Scheme->C are included in the software distribution. .PP R. Kent Dybvig, .I The SCHEME Programming Language, Prentice Hall, Inc. .PP Daniel P. Friedman and Matthias Felleisen, .I The Little LISPer, MIT Press. .PP Joel F. Bartlett, .I Scheme->C a Portable Scheme-to-C Compiler, WRL Research Report 89/1. .PP Additional documentation is included in the software distribution. .PP s2ci(1) .SH QUESTIONS, COMMENTS, AND COMPLAINTS http://alioth.debian.org/projects/scheme2c/ scheme2c-2012.10.14/doc/s2ci.l000066400000000000000000000073521203736146400153720ustar00rootroot00000000000000.TH S2CI 1 local .SH NAME s2ci \- Scheme interpreter .SH SYNTAX .B s2ci [ option ] .SH DESCRIPTION The .B s2ci command (previously known as \fBsci\fR) invokes a Scheme interpreter. The language accepted by this interpreter is that defined in the essential portions of the .I Revised\v'-0.3m'4\v'0.3m' Report on the Algorithmic Language Scheme, with minor constraints and some additions. The Scheme interpreter is written in Scheme which has then been compiled using the Scheme-to-C compiler, \fBs2cc\fR. .SH OPTIONS These options are accepted by .B s2ci. .TP 15 .B -e Echo text read from the standard input file on the standard output file. .TP 15 .B -emacs Scheme interpreter is controlled by GNU emacs. .TP 15 .B -nh Do not print the interpreter version header on the standard output file. .TP 15 .B -np Do not prompt for input from the standard input file on the standard output file. .TP 15 .B -q Do not print the result of each expression evaluation. .TP 15 \fB-scgc \fIstatflag\fR Enables garbage collection statistics. If set to 1, then garbage collection statistics will be printed. The default is 0, that will result in no statistics. .TP 15 \fB-sch \fIheap\fR Specifies the initial size of the heap in megabytes. The default heap size is 4 MB. The maximum heap size allowed is 1000 MB. .TP 15 \fB-scl \fIpercent\fR Specifies the percent of the heap allocated after a generational garbage collection that will force a full collection. The default is 40%. .TP 15 \fB-scm \fImain\fR Specifies the function that should be used instead of the predefined "main". The function name must be entered in the correct case, i.e. letters typically upshifted. .TP 15 \fB-scmh \fIheap\fR Specifies the maximum heap size in megabytes. The default is five times the initial size of the heap. .SH ENVIRONMENT VARIABLES The items controlled by \fI-sc..\fR flags can also be controlled by environment variables. If both the flag and the environment variable are provided, then the flag's value will be used. .TP 15 .B SCGCINFO Controls the reporting of garbage collection statistics to the standard error file. If set to 1, then garbage collection statistics will be printed. The default setting is 0 that will not print the statistics. .TP 15 .B SCHEAP Specifies the initial size of the heap in megabytes. The default heap size is 4 MB. The maximum heap size allowed is 1000 MB. .TP 15 .B SCLIMIT Specifies the percent of the heap allocated after a generational garbage collection that will force a full collection. The default is 40%. .TP 15 .B SCMAXHEAP Specifies the maximum size of the heap in megabytes. The default value is five times the initial heap size. .SH FILES The interpreter is one a.out file with the name \fIs2ci\fR. All files associated with the interpreter are found in the directory \fI.../schemetoc/scrt\fB. .SH SEE ALSO .PP Harold Abelson and Gerald Jay Sussman with Julie Sussman, .I Structure and Interpretation of Computer Programs, The MIT Press. .PP William Clinger and Jonathan Rees (Editors), .I Revised\v'-0.3m'4\v'0.3m' Report on the Algorithmic Language Scheme, LISP Pointers, Volume IV, Number 3, July-September 1991. PostScript for this report is included in the software distribution. .PP Jerry D. Smith, .I An Introduction to Scheme, Prentice Hall, Inc. Chapter notes for using this text with Scheme->C are included in the software distribution. .PP R. Kent Dybvig, .I The SCHEME Programming Language, Prentice Hall, Inc. .PP Daniel P. Friedman and Matthias Felleisen, .I The Little LISPer, MIT Press. .PP Joel F. Bartlett, .I Scheme->C a Portable Scheme-to-C Compiler, WRL Research Report 89/1. .PP Additional documentation is included in the software distribution. .PP s2cc(1) .SH QUESTIONS, COMMENTS, AND COMPLAINTS http://alioth.debian.org/projects/scheme2c/ scheme2c-2012.10.14/doc/smithnotes.tex000066400000000000000000000352221203736146400172710ustar00rootroot00000000000000\documentclass[10pt]{article} \usepackage{fullpage} \usepackage{parskip} \usepackage{newcent} \usepackage{s2c} \title{\StoC\ notes for \emph{An Introduction to Scheme}} \author{Joel F. Bartlett} \date{} \begin{document} \maketitle \emph{An Introduction to Scheme}, by Jerry D. Smith, is a recent text on the programming language Scheme. Rather than being directed at a specific implementation of Scheme, it attempts to stick close to the dialect defined in the \emph{Revised$^4$ Report on the Algorithmic Language Scheme} that is the base for many implementations including \StoC. This document provides section notes to point out the differences between TI PC Scheme used in the text and \StoC. The user will also find it helpful to read \emph{An Introduction to \StoC\ in 19 Prompts} and have the \emph{\StoC\ Index to the Revised$^4$ Report on the Algorithmic Language Scheme} and the \emph{Revised$^4$ Report on the Algorithmic Language Scheme} available for reference. \subsection*{1.8 (((((())))))} \StoC\ does not have an internal editor. Instead, users use the editor of their choice (which may or may not have parentheses matching) and then use \textbf{load} to load the file into the Scheme system. \subsection*{1.10 PC Scheme and the Listener} This is what the interaction on page 9 looks like in \StoC: \begin{quote} \begin{verbatim} > (+ 3 2) 5 > (load "examples.sc") SQUARE "examples.sc" > (square 2) 4 > (exit) \end{verbatim} \end{quote} User input is prompted by ``\texttt{>}'', \StoC\ files end with the suffix ``.sc'', and the command primitives \textbf{\%c} and \textbf{\%d} are not supported. User input is not evaluated until the user types return. \subsection*{2.2 The Scheme Listener} \StoC\ is started by the command \textbf{s2ci}. Once the command is executed, the window looks like this: \begin{quote} \begin{verbatim} $ s2ci Scheme->C -- 01sep91jfb -- Copyright 1989 Digital Equipment Corporation > \end{verbatim} \end{quote} When the evaluation of an expression results in an error, the debugger is entered. It prints an error message followed by a procedure call traceback. It then prompts the user with ``\texttt{>>}'' to allow commands to inspect the state of the computation where the error occurred. For now, simply type control-D to return to the main read-eval-print loop. \begin{quote} \begin{verbatim} > (square 2) ***** SQUARE Top-level symbol is undefined (SQUARE 2) in ENV-0 (EVAL ...) (SCREP_REP ...) (READ-EVAL-PRINT ...) >> ^D > (load "examples.sc") SQUARE "examples.sc" > (square 2) 4 > (exit) \end{verbatim} \end{quote} \subsection*{2.3 Simple Arithmetic} Most \StoC\ systems do not have bignums. Numbers are represented as either 29-bit integers or 64-bit floating point values. Exercise for the student: Add bignums to \StoC. The boolean constant for true is \textbf{\#t} and false is \textbf{\#f}. In keeping with tradition, both the empty list \textbf{()} and \textbf{\#f} are considered to be false. It is good programming practice to not use the empty list \textbf{()} as a synonym for \textbf{\#f}, and in IEEE compliant Scheme's your program won't work as the empty list \textbf{()} is a synonym for \textbf{\#t}! \subsection*{2.4.2 Constants} The constants \textbf{\#!true}, \textbf{\#!false}, and \textbf{\#!null} are not implemented, use \textbf{\#t}, \textbf{\#f}, and \textbf{'()} respectively. The character constants \textbf{\#\textbackslash{}backspace}, \textbf{\#\textbackslash{}page}, and \textbf{\#\textbackslash{}rubout} are not implemented. \subsection*{2.4.4 Literal Expressions} The value of \textbf{\#f} is false, represented as \textbf{\#f}, which is not the same as the empty list \textbf{()}. While both \textbf{\#f} and \textbf{()} are considered to be false when evaluating a boolean expression, they are not equivalent. Note that the empty list is not a self-evaluating constant. In order to avoid an error, one must quote it when entering it into Scheme: \begin{quote} \begin{verbatim} > () > ( ***** EVAL Argument contains an item that is not self-evaluating: () (EVAL ...) (SCREP_REP ...) (READ-EVAL-PRINT ...) >> ^D > '() () > \end{verbatim} \end{quote} \subsection*{3.2 The Global Environment} There is only one top level environment that contains both user and system definitions. \subsection*{5.2 Logical Operators} Since \textbf{\#f} and the empty list \textbf{()} are different, \textbf{\#f} is always returned when a predicate returns false: \begin{quote} \begin{verbatim} > (<= 4 3) #F \end{verbatim} \end{quote} \subsection*{5.7 begin} In the text, the programming convention is that one calls \textbf{newline} and then calls \textbf{display}. In printing to the terminal with \StoC, it is better to call \textbf{display} and then call \textbf{newline} as a newline is not automatically generated when Scheme prompts the user for additional input. \subsection*{8.2 Characters} The following \#\textbackslash{}\emph{char-name} forms are supported: \textbf{\#\textbackslash{}formfeed}, \textbf{\#\textbackslash{}linefeed}, \textbf{\#\textbackslash{}newline}, \textbf{\#\textbackslash{}return}, \textbf{\#\textbackslash{}space}, and \textbf{\#\textbackslash{}tab}. \subsection*{8.4.1 Character Predicates} The user need not define these as they are part of the system. \subsection*{8.4.3 String Conversion Functions} See the \StoC\ documentation for information about \textbf{number-\texttt{>}string} and \textbf{string-\texttt{>}number}. \subsection*{9.4 User-defined Port Operations} Ports in \StoC\ are represented as a pair of the symbol \textbf{port} and the procedure that implements it. For example: \begin{quote} \begin{verbatim} > (current-input-port) (PORT . #*PROCEDURE*) > \end{verbatim} \end{quote} Don't forget to put the call to \textbf{newline} after the second call to \textbf{display} when writing \textbf{addtwo}. \subsection*{9.6 Strings as Ports} Strings can be opened as input ports by \textbf{open-input-string} and as output ports by \textbf{open-output-string}. See the index for more details. \subsection*{9.7 A Utility for Reading Lines: read-ln} Users will not see either the backspace or rubout characters as they are handled by the workstation's terminal emulator. \subsection*{10.2 Debugging and Lexical Scope} A pretty-print procedure is provided, \textbf{pp}, but it does not pretty-print the text of a procedure. Breakpoints may be set on the entry and exit of any procedure defined in the top level environment. Rather than adding a call to \textbf{bkpt} as was done in the text, a user would set a breakpoint on each call to \textbf{\texttt{<}} and observe the value of \textbf{i}: \begin{quote} \begin{verbatim} > (one-to-y-sqrd 3) 0 -calls - (> 1 3) 0- i 1 0- ^D 0 -returns- #F 0- ^D \end{verbatim} \end{quote} \begin{quote} \begin{verbatim} 0 -calls - (> 0 3) 0- i 0 0- ^D 0 -returns- #F 0- ^D 0 -calls - (> -1 3) 0- i -1 0- ^D 0 -returns- #F 0- ^D 0 -calls - (> -2 3) 0- (top-level) > \end{verbatim} \end{quote} On each entry to \textbf{\texttt{>}}, the values of it's arguments are printed. The value of \textbf{i} can be examined by entering \textbf{i} followed by a return. When control-D or \textbf{(proceed)} is entered, the function is evaluated and the result is printed. To continue with the computation, enter control-D or \textbf{(proceed)}. Once it become clear that the program is in error, the user is able to return to the top level read-eval-print loop by entering \textbf{(top-level)}. Tracing is done using the \textbf{trace} and \textbf{untrace} commands: \begin{quote} \begin{verbatim} > (one-to-z-sqrd 3) 12 > (trace one-to-z-sqrd) (ONE-TO-Z-SQRD) > (one-to-z-sqrd 3) (ONE-TO-Z-SQRD 3) ==> 12 12 > (untrace one-to-z-sqrd) (ONE-TO-Z-SQRD) > \end{verbatim} \end{quote} The \textbf{bpt} command puts a breakpoint on both the entry and exit to a procedure. The \textbf{unbpt} command removes a breakpoint. Here's the example on page 141: \begin{quote} \begin{verbatim} > (bpt sqr) SQR > (one-to-z-sqrd 3) (ONE-TO-Z-SQRD 3) 1 -calls - (SQR 1) 1- ^D 1 -returns- 2 1- ^D \end{verbatim} \end{quote} \begin{quote} \begin{verbatim} 1 -calls - (SQR 2) 1- ^D 1 -returns- 4 1- ^D 1 -calls - (SQR 3) 1- ^D 1 -returns- 6 1- (top-level) > (unbpt sqr) (SQR) > \end{verbatim} \end{quote} When both \textbf{sqr} and \textbf{one-to-z-sqrd} are traced, one gets the following output. \begin{quote} \begin{verbatim} > (trace one-to-z-sqrd) (ONE-TO-Z-SQRD) > (trace sqr) (SQR) > (ONE-TO-Z-SQRD 3) (ONE-TO-Z-SQRD 3) (SQR 1) ==> 2 (SQR 2) ==> 4 (SQR 3) ==> 6 ==> 12 12 > \end{verbatim} \end{quote} Tracing the recursive function \textbf{ftl} produces the following output. \begin{quote} \begin{verbatim} > (trace ftl) (FTL) > (ftl 3) (FTL 3) (FTL 2) (FTL 1) (FTL 0) ==> 1 ==> 1 ==> 2 ==> 6 6 > \end{verbatim} \end{quote} \subsection*{10.3 Debugging in a Lexically Scoped Environment} Conditional breakpoints can be placed on procedures using the \textbf{bpt} special form. The second argument is a test procedure that is either the name of a top level procedure or a lambda expression defining a procedure. On each entry to the procedure, the test procedure is evaluated with the arguments to the breakpointed procedure. When the test procedure returns a true value, the breakpoint is taken. \begin{quote} \begin{verbatim} > (bpt one-to-n (lambda (x) (>= x 3))) ONE-TO-N > (mean-table 5) ======================================= N MEAN OF 1 TO N 1 1 2 1.5 3 0 -calls - (ONE-TO-N 3) 0- \end{verbatim} \end{quote} The first time the argument to \textbf{one-to-n} is \textbf{\texttt{>=}} 3, the breakpoint is taken. Once at a breakpoint, the \textbf{backtrace} procedure allows the call stack and environments to be inspected. \begin{quote} \begin{verbatim} 0- (backtrace) (ONE-TO-N N) in ENV-0 (/ (ONE-TO-N N) N) in ENV-1 (DISPLAY (ONE-TO-N-MEAN N)) in ENV-2 (BEGIN (NEWLINE) (DISPLAY N) (DISPLAY " ") (DIS ... in ENV-3 (EVAL ...) (SCREP_REP ...) (READ-EVAL-PRINT ...) #F 0- \end{verbatim} \end{quote} Environments are identified by the symbols \textbf{env-}\emph{i}. The value of an environment is an a-list of symbols and their values. It's often useful to use \textbf{pp} to print out an environment. An expression may be evaluated within a specific environment by calling \textbf{eval} with two arguments, the expression and the environment. \begin{quote} \begin{verbatim} 0- env-1 ((LOCATION . "inside one-to-n-mean") (N . 3)) 0- env-3 ((N . 3) (\d\o\l\o\o\p . #*PROCEDURE*) (PRINT-HEADER .#*PROCEDU RE*) (HEADER-LINE . "=======================================")( HIGH-BOUND . 5)) 0- (pp env-3) ((N . 3) (\d\o\l\o\o\p . #*PROCEDURE*) (PRINT-HEADER . #*PROCEDURE*) (HEADER-LINE . "=======================================") (HIGH-BOUND . 5))#T 0- (eval 'high-bound env-3) 5 0- ^D 0 -returns- 6 0- ^D 2 4 0 -calls - (ONE-TO-N 4) 0- ^D 0 -returns- 10 0- ^D 2.5 5 0 -calls - (ONE-TO-N 5) 0- ^D 0 -returns- 15 0- ^D 3 ======================================= #F > \end{verbatim} \end{quote} The same techniques that one uses to explore a program that has hit a breakpoint can be used to investigate a running program. Here a simple loop is run. When the user enters control-C the running program is interrupted. A breakpoint is put on \textbf{eq?}\ and then the program is continued by typing control-D. Once the breakpoint is hit, \textbf{(eq?\ 0 0)} is executed, and then \textbf{proceed} is used to change the result returned by \textbf{eq?}, which causes the loop to complete. \begin{quote} \begin{verbatim} > (let loop ((i 0)) (if (eq? i 0) (loop i) 'done)) ^C ***** INTERRUPT ***** (EQ? I 0) in ENV-0 (IF (EQ? I 0) (LOOP I) 'DONE) in ENV-1 (EVAL ...) (SCREP_REP ...) (READ-EVAL-PRINT ...) >> (bpt eq?) EQ? >> ^D 0 -calls - (EQ? 0 0) 0- ^D 0 -returns- #T 0- (proceed #f) DONE > \end{verbatim} \end{quote} Finally, these techniques can be used to investigate the environment when an error occurs. Note that when control-D is entered to continue, Scheme returns to the top level read-eval-print loop. \begin{quote} \begin{verbatim} > (let ((i 0)) (car (car (car i)))) ***** CAR Argument not a PAIR: 0 (SCRT1_$_CAR-ERROR ...) (CAR ...) (CAR I) in ENV-0 (CAR (CAR I)) in ENV-1 (CAR (CAR (CAR I))) in ENV-2 (EVAL ...) (SCREP_REP ...) (READ-EVAL-PRINT ...) >> i 0 >> env-0 ((I . 0)) >> ^D > \end{verbatim} \end{quote} Exercise for the student: implement \textbf{assert}. \subsection*{11.3 dir: A Utility for Listing Filenames (Implementation-specific)} In order to implement this in \StoC\ you'll need to implement your own version of \textbf{sort!}\ and use \textbf{(open-input-port \texttt{"}ls\texttt{"})} to generate a list of file names. \subsection*{11.4 format: A Utility for Formatted Output} \StoC\ contains a procedure \textbf{format}. See the documentation for details. \subsection*{13.2 Memory Organization} Exercise for the student: implement \textbf{append!}. \subsection*{15.4 Macros [OPTIONAL]} \StoC\ macros implements ``expansion passing'' macros based upon the ideas found in \emph{Expansion-Passing Style: Beyond Conventional Macros}, 1986 ACM Conference on Lisp and Functional Programming, 143--150. The simplest form of a macro is a constant. The arguments to the special form \textbf{define-constant} are the symbol identifying the constant and the expression to evaluate to calculate it's value. \begin{quote} \begin{verbatim} > (define-constant radius 23) RADIUS > (define-constant pi 3.14159) PI > (define-constant circumference (* pi radius 2)) CIRCUMFERENCE > (define-constant area (* 3.14159 (* radius radius))) AREA > area 1661.90111 > \end{verbatim} \end{quote} The second type of macro defines an in-line procedure. The form \textbf{define-in-line} associates a symbol with a procedure definition. All calls to the procedure are replaced by the lambda expression defining the procedure. \begin{quote} \begin{verbatim} > (define-in-line (plus3 x) (+ x 3)) PLUS3 > (plus3 5) 8 > \end{verbatim} \end{quote} The most general form of macro expansion allows the user to examine a procedure call and then selectively cause further macro expansion. The definition for \textbf{plus3} can also be written as: \begin{quote} \begin{verbatim} > (define-macro plus3 (lambda (form expander) (expander `(+ ,(cadr form) 3) expander))) PLUS3 > (plus3 8) 11 > \end{verbatim} \end{quote} The macro is defined by a procedure that takes two arguments: the form to be expanded, and a procedure to do further expansion. It's typical action is to build an expanded form and then call the further expansion procedure with the new form and the further expansion procedure as arguments. For examples of use of this type of macro expander, the reader is directed to the file \textbf{scrt/predef.sc} that defines the macros used by the compiler. N.B. Macro definitions may not be placed inside procedure definitions. \end{document} scheme2c-2012.10.14/makefile000066400000000000000000000117511203736146400153060ustar00rootroot00000000000000# # This file is used to make the Scheme->C system for multiple processor types. # # Architecture specific directories and links to the source files are # constructed by the following commands which follow: default: @echo "make: *** no default target" @exit 1 forANY: rm -Rf ${CPU} +mkdir -p ${CPU} +cp ports/makefile ${CPU}/ +mkdir -p ${CPU}/scsc +cat ports/${CPU}/makefile-head scsc/makefile >${CPU}/scsc/makefile $(MAKE) -C ${CPU}/scsc srclinks +mkdir -p ${CPU}/scrt +cat ports/${CPU}/makefile-head scrt/makefile >${CPU}/scrt/makefile $(MAKE) -C ${CPU}/scrt srclinks +mkdir -p ${CPU}/server +cat ports/${CPU}/makefile-head scrt/makefile >${CPU}/server/makefile $(MAKE) -C ${CPU}/server srclinks +mkdir -p ${CPU}/test +cat ports/${CPU}/makefile-head test/makefile >${CPU}/test/makefile $(MAKE) -C ${CPU}/test srclinks +mkdir -p ${CPU}/cdecl +cat ports/${CPU}/makefile-head cdecl/makefile >${CPU}/cdecl/makefile $(MAKE) -C ${CPU}/cdecl srclinks +mkdir -p ${CPU}/xlib +cat ports/${CPU}/makefile-head xlib/makefile >${CPU}/xlib/makefile $(MAKE) -C ${CPU}/xlib srclinks forAOSF: $(MAKE) "CPU=AOSF" forANY cp ports/AOSF/aosf.s AOSF/scrt/ cp ports/AOSF/options.h AOSF/scrt/ cp ports/AOSF/aosf.s AOSF/server/ cp ports/AOSF/options-server.h AOSF/server/options.h rm AOSF/xlib/X.cdecl cp ports/AOSF/X.cdecl AOSF/xlib/ forDECMIPS: $(MAKE) "CPU=DECMIPS" forANY cp ports/DECMIPS/mips.s DECMIPS/scrt/ cp ports/DECMIPS/options.h DECMIPS/scrt/ cp ports/DECMIPS/mips.s DECMIPS/server/ cp ports/DECMIPS/options-server.h DECMIPS/server/options.h forHP300: $(MAKE) "CPU=HP300" forANY cp ports/HP300/hp300.s HP300/scrt/ cp ports/HP300/options.h HP300/scrt/ cp ports/HP300/hp300.s HP300/server/ cp ports/HP300/options-server.h HP300/server/options.h forHP700: $(MAKE) "CPU=HP700" forANY cp ports/HP700/hp700.s HP700/scrt/ cp ports/HP700/options.h HP700/scrt/ cp ports/HP700/hp700.s HP700/server/ cp ports/HP700/options-server.h HP700/server/options.h forLINUX: $(MAKE) "CPU=LINUX" forANY cp ports/LINUX/linux.s LINUX/scrt/ cp ports/LINUX/options.h LINUX/scrt/ cp ports/LINUX/linux.s LINUX/server/ cp ports/LINUX/options-server.h LINUX/server/options.h forAMD64: $(MAKE) "CPU=AMD64" forANY cp ports/AMD64/linux.s AMD64/scrt/ cp ports/AMD64/options.h AMD64/scrt/ cp ports/AMD64/linux.s AMD64/server/ cp ports/AMD64/options-server.h AMD64/server/options.h forARM: $(MAKE) "CPU=ARM" forANY cp ports/ARM/arm.s ARM/scrt/ cp ports/ARM/options.h ARM/scrt/ forSUNOS5: $(MAKE) "CPU=SUNOS5" forANY cp ports/SUNOS5/sparc.s SUNOS5/scrt/ cp ports/SUNOS5/sparc-pragma.h SUNOS5/scrt/ cp ports/SUNOS5/options.h SUNOS5/scrt/ cp ports/SUNOS5/sparc.s SUNOS5/server/ cp ports/SUNOS5/options-server.h SUNOS5/server/options.h forSUNOS4: $(MAKE) "CPU=SUNOS4" forANY cp ports/SUNOS4/sparc.s SUNOS4/scrt/ cp ports/SUNOS4/sparc-pragma.h SUNOS5/scrt/ cp ports/SUNOS4/options.h SUNOS4/scrt/ cp ports/SUNOS4/sparc.s SUNOS4/server/ cp ports/SUNOS4/options-server.h SUNOS4/server/options.h forMAC: $(MAKE) "CPU=MAC" forANY rm -r MAC/scsc rm -r MAC/cdecl rm -r MAC/xlib rm -r MAC/server cp ports/MAC/README MAC/ cp ports/MAC/options.h MAC/scrt/ echo "#define MACSCI 1" > MAC/scrt/cio-MACSCI.c cat MAC/scrt/cio.c >> MAC/scrt/cio-MACSCI.c cp ports/MAC/pack MAC/scrt/ cp ports/MAC/unpack.c MAC/scrt/ forSGIMIPS: $(MAKE) "CPU=SGIMIPS" forANY cp ports/SGIMIPS/mips.s SGIMIPS/scrt/ cp ports/SGIMIPS/options.h SGIMIPS/scrt/ cp ports/SGIMIPS/mips.s SGIMIPS/server/ cp ports/SGIMIPS/options-server.h SGIMIPS/server/options.h cp ports/SGIMIPS/ranlib SGIMIPS/ forSONYMIPS: $(MAKE) "CPU=SONYMIPS" forANY cp ports/SONYMIPS/mips.s SONYMIPS/scrt/ cp ports/SONYMIPS/options.h SONYMIPS/scrt/ cp ports/SONYMIPS/mips.s SONYMIPS/server/ cp ports/SONYMIPS/options-server.h SONYMIPS/server/options.h forVAX: $(MAKE) "CPU=VAX" forANY cp ports/VAX/vax.s VAX/scrt/ cp ports/VAX/options.h VAX/scrt/ cp ports/VAX/vax.s VAX/server/ cp ports/VAX/options-server.h VAX/server/options.h forFREEBSD: $(MAKE) "CPU=FREEBSD" forANY cp ports/FREEBSD/x86.s FREEBSD/scrt/ cp ports/FREEBSD/options.h FREEBSD/scrt/ cp ports/FREEBSD/x86.s FREEBSD/server/ cp ports/FREEBSD/options-server.h FREEBSD/server/options.h forOPENBSD: $(MAKE) "CPU=OPENBSD" forANY cp ports/OPENBSD/openbsd.s OPENBSD/scrt/ cp ports/OPENBSD/options.h OPENBSD/scrt/ cp ports/OPENBSD/openbsd.s OPENBSD/server/ cp ports/OPENBSD/options-server.h OPENBSD/server/options.h # Clean out working files. clean: rm -f *.BAK *.CKP SC-TO-C* $(MAKE) -C doc clean $(MAKE) -C scrt clean $(MAKE) -C scsc clean $(MAKE) -C test clean $(MAKE) -C cdecl clean $(MAKE) -C xlib clean # Clean up C source files generated from Scheme source. clean-sc-to-c: $(MAKE) -C scrt clean-sc-to-c $(MAKE) -C scsc clean-sc-to-c $(MAKE) -C test clean-sc-to-c $(MAKE) -C cdecl clean-sc-to-c $(MAKE) -C xlib clean-sc-to-c # Delete programs and libraries. noprogs: $(MAKE) -C scrt noprogs $(MAKE) -C scsc noprogs $(MAKE) -C test noprogs $(MAKE) -C cdecl clean-sc-to-c $(MAKE) -C xlib clean-sc-to-c scheme2c-2012.10.14/ports/000077500000000000000000000000001203736146400147505ustar00rootroot00000000000000scheme2c-2012.10.14/ports/AMD64/000077500000000000000000000000001203736146400155235ustar00rootroot00000000000000scheme2c-2012.10.14/ports/AMD64/linux.s000066400000000000000000000007341203736146400170520ustar00rootroot00000000000000/* * SCHEME->C * * LINUX assembly code. * */ /*#ifdef __i486__ .align 4 #else .align 2 #endif*/ .globl sc_geti386regs sc_geti386regs: pushq %rbp movq %rsp,%rbp movq %rax,(%rdi) movq %rbx,8(%rdi) movq %rcx,16(%rdi) movq %rdx,24(%rdi) movq %rsi,32(%rdi) movq %r8,40(%rdi) movq %r9,48(%rdi) movq %r10,56(%rdi) movq %r11,64(%rdi) movq %r12,72(%rdi) movq %r13,80(%rdi) movq %r14,88(%rdi) movq %r15,96(%rdi) movq %rdi,%rax movq %rbp,%rsp popq %rbp ret scheme2c-2012.10.14/ports/AMD64/makefile-head000066400000000000000000000006521203736146400201250ustar00rootroot00000000000000# # This is the header file for constructing make files for LINUX. # # Default flags to use when invoking the C compiler. CFLAGS = -march=native -Wall -O2 -finline-functions -fno-math-errno -frename-registers LDFLAGS = -lsigsegv CC = gcc # Assembly language object files. Aruntime = linux.o # Profiled library Plib = # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of LINUX header. scheme2c-2012.10.14/ports/AMD64/options-server.h000066400000000000000000000101541203736146400206740ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ #define STACK_OVERFLOW 1 /* If you're going to disable this, remove it from makefile-head as well */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define AMD64 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* AMD64 */ /***************/ #ifdef AMD64 #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "AMD64" #define IMPLEMENTATION_OS "Linux" #undef IMPLEMENTATION_FS typedef long int S2CINT; /* Signed pointer size integer */ typedef unsigned long int S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffffffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x8000000000000000 /* S2CUINT with 1 in the MSB */ #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_processor_register( 0 ) #define POSIX 1 #include typedef jmp_buf sc_jmp_buf; #define DOUBLE_ALIGN 1 #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 8 #endif scheme2c-2012.10.14/ports/AMD64/options.h000066400000000000000000000102271203736146400173710ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ #define STACK_OVERFLOW 1 /* If you're going to disable this, remove it from makefile-head as well */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define AMD64 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* AMD64 */ /***************/ #ifdef AMD64 #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "AMD64" #define IMPLEMENTATION_OS "Linux" #undef IMPLEMENTATION_FS #include typedef intptr_t S2CINT; /* Signed pointer size integer */ typedef uintptr_t S2CUINT; /* Unsigned pointer size interger */ typedef long int PAGELINK; /* 64-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffffffffffL /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x8000000000000000L /* S2CUINT with 1 in the MSB */ #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_processor_register( 0 ) #define POSIX 1 #include typedef jmp_buf sc_jmp_buf; #define DOUBLE_ALIGN 1 #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 8 #define SCMAXHEAP 256000 #endif scheme2c-2012.10.14/ports/AOSF/000077500000000000000000000000001203736146400155005ustar00rootroot00000000000000scheme2c-2012.10.14/ports/AOSF/X.cdecl000066400000000000000000000456331203736146400167160ustar00rootroot00000000000000;;; X window system definitions for Scheme->C ;;; ;;; derived from: ;;; ;;; $XConsortium: X.h,v 1.66 88/09/06 15:55:56 jim Exp $ ;;; ;;; Definitions for the X window system likely to be used by applications ; Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ; and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ; ; All Rights Reserved ; ; Permission to use, copy, modify, and distribute this software and its ; documentation for any purpose and without fee is hereby granted, ; provided that the above copyright notice appear in all copies and that ; both that copyright notice and this permission notice appear in ; supporting documentation, and that the names of Digital or MIT not be ; used in advertising or publicity pertaining to distribution of the ; software without specific, written prior permission. ; ; DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ; DIGITAL BE LIABLE FOR ANY SPECIAL, 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. (const X_PROTOCOL 11) ; current protocol version (const X_PROTOCOL_REVISION 0) ; current minor version ;; New base types (typedef longunsigned unsignedlong) (typedef unsigned unsignedint) (typedef (unsigned 0) unsignedA) (typedef (unsignedlong 0) unsignedlongA) (typedef unsignedA unsignedintA) (typedef (unsignedA *) unsignedAP) (typedef (unsignedlongA *) unsignedlongAP) (typedef unsignedAP unsignedintAP) (typedef (unsigned *proc) unsignedPROC) (typedef (unsignedlong *proc) unsignedlongPROC) (typedef unsignedPROC unsignedintPROC) (typedef char unsignedchar) (typedef (char *) charP) (typedef (char 0) charA) (typedef (charA *) charAP) (typedef (charP 0) charPA) (typedef (charPA *) charPAP) (typedef shortint short) (typedef shortunsigned unsignedshort) (typedef longint long) (typedef (int *proc) intPROC) (typedef (int *) intP) (typedef (int 0) intA) (typedef (intA *) intAP) ;; Resources (typedef unsignedlong XID) (typedef XID Window) (typedef XID Drawable) (typedef XID Font) (typedef XID Pixmap) (typedef XID Cursor) (typedef XID Colormap) (typedef unsignedA ColormapA) (typedef unsignedAP ColormapAP) (typedef XID GContext) (typedef XID KeySym) (typedef unsignedA KeySymA) (typedef unsignedAP KeySymAP) (typedef unsignedA WindowA) (typedef unsignedAP WindowAP) (typedef unsignedlong Mask) (typedef unsignedlong Atom) (typedef unsignedA AtomA) (typedef unsignedAP AtomAP) (typedef unsignedlong VisualID) (typedef unsigned Time) ;;; OSF specific change !!! (typedef unsignedchar KeyCode) ;;*************************************************************** ;; RESERVED RESOURCE AND CONSTANT DEFINITIONS ;;**************************************************************** (const None 0) ;; universal null resource or null atom (const ParentRelative 1) ;; background pixmap in CreateWindow ;; and ChangeWindowAttributes (const CopyFromParent 0) ;; border pixmap in CreateWindow ;; and ChangeWindowAttributes ;; special VisualID and special window ;; class passed to CreateWindow (const PointerWindow 0) ;; destination window in SendEvent (const InputFocus 1) ;; destination window in SendEvent (const PointerRoot 1) ;; focus window in SetInputFocus (const AnyPropertyType 0) ;; special Atom, passed to GetProperty (const AnyKey 0) ;; special Key Code, passed to GrabKey (const AnyButton 0) ;; special Button Code, passed to GrabButton (const AllTemporary 0) ;; special Resource ID passed to KillClient (const CurrentTime 0) ;; special Time (const NoSymbol 0) ;; special KeySym ;;**************************************************************** ;;* EVENT DEFINITIONS ;;**************************************************************** ;; Input Event Masks. Used as event-mask window attribute and as arguments ;; to Grab requests. Not to be confused with event names. (const NoEventMask 0) (const KeyPressMask (expt 2 0)) (const KeyReleaseMask (expt 2 1)) (const ButtonPressMask (expt 2 2)) (const ButtonReleaseMask (expt 2 3)) (const EnterWindowMask (expt 2 4)) (const LeaveWindowMask (expt 2 5)) (const PointerMotionMask (expt 2 6)) (const PointerMotionHintMask (expt 2 7)) (const Button1MotionMask (expt 2 8)) (const Button2MotionMask (expt 2 9)) (const Button3MotionMask (expt 2 10)) (const Button4MotionMask (expt 2 11)) (const Button5MotionMask (expt 2 12)) (const ButtonMotionMask (expt 2 13)) (const KeymapStateMask (expt 2 14)) (const ExposureMask (expt 2 15)) (const VisibilityChangeMask (expt 2 16)) (const StructureNotifyMask (expt 2 17)) (const ResizeRedirectMask (expt 2 18)) (const SubstructureNotifyMask (expt 2 19)) (const SubstructureRedirectMask (expt 2 20)) (const FocusChangeMask (expt 2 21)) (const PropertyChangeMask (expt 2 22)) (const ColormapChangeMask (expt 2 23)) (const OwnerGrabButtonMask (expt 2 24)) ;; Event names. Used in "type" field in XEvent structures. Not to be ;; confused with event masks above. They start from 2 because 0 and 1 ;; are reserved in the protocol for errors and replies. (const KeyPress 2) (const KeyRelease 3) (const ButtonPress 4) (const ButtonRelease 5) (const MotionNotify 6) (const EnterNotify 7) (const LeaveNotify 8) (const FocusIn 9) (const FocusOut 10) (const KeymapNotify 11) (const Expose 12) (const GraphicsExpose 13) (const NoExpose 14) (const VisibilityNotify 15) (const CreateNotify 16) (const DestroyNotify 17) (const UnmapNotify 18) (const MapNotify 19) (const MapRequest 20) (const ReparentNotify 21) (const ConfigureNotify 22) (const ConfigureRequest 23) (const GravityNotify 24) (const ResizeRequest 25) (const CirculateNotify 26) (const CirculateRequest 27) (const PropertyNotify 28) (const SelectionClear 29) (const SelectionRequest 30) (const SelectionNotify 31) (const ColormapNotify 32) (const ClientMessage 33) (const MappingNotify 34) (const LASTEvent 35) ;; must be bigger than any event # ;; Key masks. Used as modifiers to GrabButton and GrabKey, results of ;; QueryPointer, state in various key-, mouse-, and button-related events. (const ShiftMask (expt 2 0)) (const LockMask (expt 2 1)) (const ControlMask (expt 2 2)) (const Mod1Mask (expt 2 3)) (const Mod2Mask (expt 2 4)) (const Mod3Mask (expt 2 5)) (const Mod4Mask (expt 2 6)) (const Mod5Mask (expt 2 7)) ;; modifier names. Used to build a SetModifierMapping request or ;; to read a GetModifierMapping request. These correspond to the ;; masks defined above. (const ShiftMapIndex 0) (const LockMapIndex 1) (const ControlMapIndex 2) (const Mod1MapIndex 3) (const Mod2MapIndex 4) (const Mod3MapIndex 5) (const Mod4MapIndex 6) (const Mod5MapIndex 7) ;; button masks. Used in same manner as Key masks above. Not to be confused ;; with button names below. (const Button1Mask (expt 2 8)) (const Button2Mask (expt 2 9)) (const Button3Mask (expt 2 10)) (const Button4Mask (expt 2 11)) (const Button5Mask (expt 2 12)) (const AnyModifier (expt 2 15)) ;; used in GrabButton, GrabKey ;; button names. Used as arguments to GrabButton and as detail in ButtonPress ;; and ButtonRelease events. Not to be confused with button masks above. ;; Note that 0 is already defined above as "AnyButton". (const Button1 1) (const Button2 2) (const Button3 3) (const Button4 4) (const Button5 5) ;; Notify modes (const NotifyNormal 0) (const NotifyGrab 1) (const NotifyUngrab 2) (const NotifyWhileGrabbed 3) (const NotifyHint 1) ;; for MotionNotify events ;; Notify detail (const NotifyAncestor 0) (const NotifyVirtual 1) (const NotifyInferior 2) (const NotifyNonlinear 3) (const NotifyNonlinearVirtual 4) (const NotifyPointer 5) (const NotifyPointerRoot 6) (const NotifyDetailNone 7) ;; Visibility notify (const VisibilityUnobscured 0) (const VisibilityPartiallyObscured 1) (const VisibilityFullyObscured 2) ;; Circulation request (const PlaceOnTop 0) (const PlaceOnBottom 1) ;; protocol families (const FamilyInternet 0) (const FamilyDECnet 1) (const FamilyChaos 2) ;; Property notification (const PropertyNewValue 0) (const PropertyDelete 1) ;; Color Map notification (const ColormapUninstalled 0) (const ColormapInstalled 1) ;; GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes (const GrabModeSync 0) (const GrabModeAsync 1) ;; GrabPointer, GrabKeyboard reply status (const GrabSuccess 0) (const AlreadyGrabbed 1) (const GrabInvalidTime 2) (const GrabNotViewable 3) (const GrabFrozen 4) ;; AllowEvents modes (const AsyncPointer 0) (const SyncPointer 1) (const ReplayPointer 2) (const AsyncKeyboard 3) (const SyncKeyboard 4) (const ReplayKeyboard 5) (const AsyncBoth 6) (const SyncBoth 7) ;; Used in SetInputFocus, GetInputFocus (const RevertToNone None) (const RevertToPointerRoot PointerRoot) (const RevertToParent 2) ;;**************************************************************** ;;* ERROR CODES ;;**************************************************************** (const Success 0) ;; everything's okay (const BadRequest 1) ;; bad request code (const BadValue 2) ;; int parameter out of range (const BadWindow 3) ;; parameter not a Window (const BadPixmap 4) ;; parameter not a Pixmap (const BadAtom 5) ;; parameter not an Atom (const BadCursor 6) ;; parameter not a Cursor (const BadFont 7) ;; parameter not a Font (const BadMatch 8) ;; parameter mismatch (const BadDrawable 9) ;; parameter not a Pixmap or Window (const BadAccess 10) ;; depending on context: ;; - key/button already grabbed ;; - attempt to free an illegal ;; cmap entry ;; - attempt to store into a read-only ;; color map entry. ;; - attempt to modify the access control ;; list from other than the local host. (const BadAlloc 11) ;; insufficient resources (const BadColor 12) ;; no such colormap (const BadGC 13) ;; parameter not a GC (const BadIDChoice 14) ;; choice not in range or already used (const BadName 15) ;; font or color name doesn't exist (const BadLength 16) ;; Request length incorrect (const BadImplementation 17) ;; server is defective (const FirstExtensionError 128) (const LastExtensionError 255) ;;**************************************************************** ;;* WINDOW DEFINITIONS ;;**************************************************************** ;; Window classes used by CreateWindow ;; Note that CopyFromParent is already defined as 0 above (const InputOutput 1) (const InputOnly 2) ;; Window attributes for CreateWindow and ChangeWindowAttributes (const CWBackPixmap (expt 2 0)) (const CWBackPixel (expt 2 1)) (const CWBorderPixmap (expt 2 2)) (const CWBorderPixel (expt 2 3)) (const CWBitGravity (expt 2 4)) (const CWWinGravity (expt 2 5)) (const CWBackingStore (expt 2 6)) (const CWBackingPlanes (expt 2 7)) (const CWBackingPixel (expt 2 8)) (const CWOverrideRedirect (expt 2 9)) (const CWSaveUnder (expt 2 10)) (const CWEventMask (expt 2 11)) (const CWDontPropagate (expt 2 12)) (const CWColormap (expt 2 13)) (const CWCursor (expt 2 14)) ;; ConfigureWindow structure (const CWX (expt 2 0)) (const CWY (expt 2 1)) (const CWWidth (expt 2 2)) (const CWHeight (expt 2 3)) (const CWBorderWidth (expt 2 4)) (const CWSibling (expt 2 5)) (const CWStackMode (expt 2 6)) ;; Bit Gravity (const ForgetGravity 0) (const NorthWestGravity 1) (const NorthGravity 2) (const NorthEastGravity 3) (const WestGravity 4) (const CenterGravity 5) (const EastGravity 6) (const SouthWestGravity 7) (const SouthGravity 8) (const SouthEastGravity 9) (const StaticGravity 10) ;; Window gravity + bit gravity above (const UnmapGravity 0) ;; Used in CreateWindow for backing-store hint (const NotUseful 0) (const WhenMapped 1) (const Always 2) ;; Used in GetWindowAttributes reply (const IsUnmapped 0) (const IsUnviewable 1) (const IsViewable 2) ;; Used in ChangeSaveSet (const SetModeInsert 0) (const SetModeDelete 1) ;; Used in ChangeCloseDownMode (const DestroyAll 0) (const RetainPermanent 1) (const RetainTemporary 2) ;; Window stacking method (in configureWindow) (const Above 0) (const Below 1) (const TopIf 2) (const BottomIf 3) (const Opposite 4) ;; Circulation direction (const RaiseLowest 0) (const LowerHighest 1) ;; Property modes (const PropModeReplace 0) (const PropModePrepend 1) (const PropModeAppend 2) ;;**************************************************************** ;;* GRAPHICS DEFINITIONS ;;**************************************************************** ;; graphics functions, as in GC.alu (const GXclear #x0) ;; 0 (const GXand #x1) ;; src AND dst (const GXandReverse #x2) ;; src AND NOT dst (const GXcopy #x3) ;; src (const GXandInverted #x4) ;; NOT src AND dst (const GXnoop #x5) ;; dst (const GXxor #x6) ;; src XOR dst (const GXor #x7) ;; src OR dst (const GXnor #x8) ;; NOT src AND NOT dst (const GXequiv #x9) ;; NOT src XOR dst (const GXinvert #xa) ;; NOT dst (const GXorReverse #xb) ;; src OR NOT dst (const GXcopyInverted #xc) ;; NOT src (const GXorInverted #xd) ;; NOT src OR dst (const GXnand #xe) ;; NOT src OR NOT dst (const GXset #xf) ;; 1 ;; LineStyle (const LineSolid 0) (const LineOnOffDash 1) (const LineDoubleDash 2) ;; capStyle (const CapNotLast 0) (const CapButt 1) (const CapRound 2) (const CapProjecting 3) ;; joinStyle (const JoinMiter 0) (const JoinRound 1) (const JoinBevel 2) ;; fillStyle (const FillSolid 0) (const FillTiled 1) (const FillStippled 2) (const FillOpaqueStippled 3) ;; fillRule (const EvenOddRule 0) (const WindingRule 1) ;; subwindow mode (const ClipByChildren 0) (const IncludeInferiors 1) ;; SetClipRectangles ordering (const Unsorted 0) (const YSorted 1) (const YXSorted 2) (const YXBanded 3) ;; CoordinateMode for drawing routines (const CoordModeOrigin 0) ;; relative to the origin (const CoordModePrevious 1) ;; relative to previous point ;; Polygon shapes (const Complex 0) ;; paths may intersect (const Nonconvex 1) ;; no paths intersect, but not convex (const Convex 2) ;; wholly convex ;; Arc modes for PolyFillArc (const ArcChord 0) ;; join endpoints of arc (const ArcPieSlice 1) ;; join endpoints to center of arc ;; GC components: masks used in CreateGC, CopyGC, ChangeGC, OR'ed into ;; GC.stateChanges (const GCFunction (expt 2 0)) (const GCPlaneMask (expt 2 1)) (const GCForeground (expt 2 2)) (const GCBackground (expt 2 3)) (const GCLineWidth (expt 2 4)) (const GCLineStyle (expt 2 5)) (const GCCapStyle (expt 2 6)) (const GCJoinStyle (expt 2 7)) (const GCFillStyle (expt 2 8)) (const GCFillRule (expt 2 9)) (const GCTile (expt 2 10)) (const GCStipple (expt 2 11)) (const GCTileStipXOrigin (expt 2 12)) (const GCTileStipYOrigin (expt 2 13)) (const GCFont (expt 2 14)) (const GCSubwindowMode (expt 2 15)) (const GCGraphicsExposures (expt 2 16)) (const GCClipXOrigin (expt 2 17)) (const GCClipYOrigin (expt 2 18)) (const GCClipMask (expt 2 19)) (const GCDashOffset (expt 2 20)) (const GCDashList (expt 2 21)) (const GCArcMode (expt 2 22)) (const GCLastBit 22) ;;**************************************************************** ;;* FONTS ;;**************************************************************** ;; used in QueryFont -- draw direction (const FontLeftToRight 0) (const FontRightToLeft 1) (const FontChange 255) ;;**************************************************************** ;;* IMAGING ;;**************************************************************** ;; ImageFormat -- PutImage, GetImage (const XYBitmap 0) ;; depth 1, XYFormat (const XYPixmap 1) ;; depth == drawable depth (const ZPixmap 2) ;; depth == drawable depth ;;**************************************************************** ;;* COLOR MAP STUFF ;;**************************************************************** ;; For CreateColormap (const AllocNone 0) ;; create map with no entries (const AllocAll 1) ;; allocate entire map writeable ;; Flags used in StoreNamedColor, StoreColors (const DoRed (expt 2 0)) (const DoGreen (expt 2 1)) (const DoBlue (expt 2 2)) ;;**************************************************************** ;;* CURSOR STUFF ;;**************************************************************** ;; QueryBestSize Class (const CursorShape 0) ;; largest size that can be displayed (const TileShape 1) ;; size tiled fastest (const StippleShape 2) ;; size stippled fastest ;;**************************************************************** ;;* KEYBOARD/POINTER STUFF ;;**************************************************************** (const AutoRepeatModeOff 0) (const AutoRepeatModeOn 1) (const AutoRepeatModeDefault 2) (const LedModeOff 0) (const LedModeOn 1) ;; masks for ChangeKeyboardControl (const KBKeyClickPercent (expt 2 0)) (const KBBellPercent (expt 2 1)) (const KBBellPitch (expt 2 2)) (const KBBellDuration (expt 2 3)) (const KBLed (expt 2 4)) (const KBLedMode (expt 2 5)) (const KBKey (expt 2 6)) (const KBAutoRepeatMode (expt 2 7)) (const MappingSuccess 0) (const MappingBusy 1) (const MappingFailed 2) (const MappingModifier 0) (const MappingKeyboard 1) (const MappingPointer 2) ;;**************************************************************** ;;* SCREEN SAVER STUFF ;;**************************************************************** (const DontPreferBlanking 0) (const PreferBlanking 1) (const DefaultBlanking 2) (const DisableScreenSaver 0) (const DisableScreenInterval 0) (const DontAllowExposures 0) (const AllowExposures 1) (const DefaultExposures 2) ;; for ForceScreenSaver (const ScreenSaverReset 0) (const ScreenSaverActive 1) ;;**************************************************************** ;;* HOSTS AND CONNECTIONS ;;**************************************************************** ;; for ChangeHosts (const HostInsert 0) (const HostDelete 1) ;; for ChangeAccessControl (const EnableAccess 1) (const DisableAccess 0) ;; Display classes used in opening the connection ;; * Note that the statically allocated ones are even numbered and the ;; * dynamically changeable ones are odd numbered (const StaticGray 0) (const GrayScale 1) (const StaticColor 2) (const PseudoColor 3) (const TrueColor 4) (const DirectColor 5) ;; Byte order used in imageByteOrder and bitmapBitOrder (const LSBFirst 0) (const MSBFirst 1) scheme2c-2012.10.14/ports/AOSF/aosf.s000066400000000000000000000057261203736146400166260ustar00rootroot00000000000000/* * SCHEME->C * * Alpha AXP for OSF/1 assembly code. * */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ #include /* sc_s0tos6 returns the values of s0-s6 in the caller supplied buffer. These are the "callee" save registers which need to be examined during garbage collection. */ .text .align 4 .globl sc_s0tos6 .ent sc_s0tos6 2 sc_s0tos6: ldgp gp, 0($27) .frame sp, 0, $26 .prologue 0 stq s0, 0(a0) stq s1, 8(a0) stq s2, 16(a0) stq s3, 24(a0) stq s4, 32(a0) stq s5, 40(a0) stq s6, 48(a0) ret $31, ($26), 1 .end sc_s0tos6 /* sc_setsp sets the stack pointer to the argument value */ .globl sc_setsp .ent sc_setsp 2 sc_setsp: ldgp gp, 0($27) .frame sp, 0, $26 .prologue 0 bis a0, a0, sp ret $31, ($26), 1 .end sc_setsp /* sc_getsp returns the current top-of-stack value */ .globl sc_getsp .ent sc_getsp 2 sc_getsp: ldgp gp, 0($27) .frame sp, 0, $26 .prologue 0 bis sp, sp, $0 ret $31, ($26), 1 .end sc_getsp /* sc_setjmp, sc_longjmp This code provides a version of C's setjmp/longjmp that can be used to implement Scheme's call-with-current-continuation. sc_longjmp(a,v) will generate a "return(v)" from the last call to: sc_setjmp(a) by restoring registers from the saved state, and then doing a return. */ .globl sc_setjmp .ent sc_setjmp 2 sc_setjmp: ldgp gp, 0($27) .frame sp, 0, $26 .prologue 0 stq s0, 0(a0) stq s1, 8(a0) stq s2, 16(a0) stq s3, 24(a0) stq s4, 32(a0) stq s5, 40(a0) stq s6, 48(a0) stq ra, 56(a0) stq sp, 64(a0) bis $31, $31, $0 ret $31, ($26), 1 .end sc_setjmp .globl sc_longjmp .ent sc_longjmp 2 sc_longjmp: ldgp gp, 0($27) .frame sp, 0, $26 .prologue 0 ldq s0, 0(a0) ldq s1, 8(a0) ldq s2, 16(a0) ldq s3, 24(a0) ldq s4, 32(a0) ldq s5, 40(a0) ldq s6, 48(a0) ldq ra, 56(a0) ldq sp, 64(a0) bis $17, $17, $0 ret $31, ($26), 1 .end sc_longjmp scheme2c-2012.10.14/ports/AOSF/makefile-head000066400000000000000000000005461203736146400201040ustar00rootroot00000000000000# # This is the header file for constructing make files for AOSF. # # Default flags to use when invoking the C compiler. CFLAGS = -O CC = cc # Assembly language object files. Aruntime = aosf.o # Profiled library Plib = # May be machine dependent RANLIB = ranlib # X library XLIB = -non_shared -lX11 -ldnet_stub XLIBCFLAGS = # End of AOSF header. scheme2c-2012.10.14/ports/AOSF/options-server.h000066400000000000000000000100351203736146400206470ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define AOSF 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /**************/ /* AOSF */ /**************/ #ifdef AOSF #define IMPLEMENTATION_MACHINE "Alpha AXP" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_OS "OSF/1" #undef IMPLEMENTATION_FS typedef long int S2CINT; /* Signed pointer size integer */ typedef long unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffffffffffL /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x8000000000000000L /* S2CUINT with 1 in the MSB */ typedef long int sc_jmp_buf[ 9 ]; /* The buffer contains the following items: s0-s6 saved registers ra return address sp stack pointer */ #define STACKPTR( x ) x = sc_getsp() extern S2CINT* sc_getsp(); #define NEED_MACRO_ARGS 1 #endif scheme2c-2012.10.14/ports/AOSF/options.h000066400000000000000000000100351203736146400173430ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 0 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define AOSF 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /**************/ /* AOSF */ /**************/ #ifdef AOSF #define IMPLEMENTATION_MACHINE "Alpha AXP" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_OS "OSF/1" #undef IMPLEMENTATION_FS typedef long int S2CINT; /* Signed pointer size integer */ typedef long unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffffffffffL /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x8000000000000000L /* S2CUINT with 1 in the MSB */ typedef long int sc_jmp_buf[ 9 ]; /* The buffer contains the following items: s0-s6 saved registers ra return address sp stack pointer */ #define STACKPTR( x ) x = sc_getsp() extern S2CINT* sc_getsp(); #define NEED_MACRO_ARGS 1 #endif scheme2c-2012.10.14/ports/ARM/000077500000000000000000000000001203736146400153675ustar00rootroot00000000000000scheme2c-2012.10.14/ports/ARM/arm.s000066400000000000000000000012331203736146400163310ustar00rootroot00000000000000/* * SCHEME->C * * ARM assembly code. * */ .align 2 .global sc_getARMregs .type sc_getARMregs, %function sc_getARMregs: mov ip, sp stmfd sp!, {fp, ip, lr, pc} sub fp, ip, #4 sub sp, sp, #4 str r0, [fp, #-16] str r1, [r0, #0] str r2, [r0, #4] str r3, [r0, #8] str r4, [r0, #12] str r5, [r0, #16] str r6, [r0, #20] str r7, [r0, #24] str r8, [r0, #28] str r9, [r0, #32] /* The following registers aren't saved as they're blessd as special by GCC, although they don't hold the same status in the ARM spec str r10, [r0, #36] str r11, [r0, #40] str r12, [r0, #44] */ ldmfd sp, {r0, fp, sp, pc} .size sc_getARMregs, .-sc_getARMregs scheme2c-2012.10.14/ports/ARM/makefile-head000066400000000000000000000006571203736146400177760ustar00rootroot00000000000000# # This is the header file for constructing make files for LINUX. # # Default flags to use when invoking the C compiler. CFLAGS = -O2 -Wall -finline-functions -fno-math-errno -frename-registers -fomit-frame-pointer LDFLAGS = -lsigsegv CC = gcc # Assembly language object files. Aruntime = arm.o # Profiled library Plib = # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of LINUX header. scheme2c-2012.10.14/ports/ARM/options.h000066400000000000000000000101571203736146400172370ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ #define STACK_OVERFLOW 1 /* If you're going to disable this, remove it from makefile-head as well */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define LINUX_ARM 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* LINUX_ARM */ /***************/ #ifdef LINUX_ARM #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "ARM" #define IMPLEMENTATION_OS "Linux" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_processor_register( 0 ) #define POSIX 1 #include typedef jmp_buf sc_jmp_buf; #define DOUBLE_ALIGN 1 #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 4 #define SCMAXHEAP 4000U #endif scheme2c-2012.10.14/ports/DECMIPS/000077500000000000000000000000001203736146400160345ustar00rootroot00000000000000scheme2c-2012.10.14/ports/DECMIPS/makefile-head000066400000000000000000000005221203736146400204320ustar00rootroot00000000000000# # This is the header file for constructing make files for DECMIPS. # # Default flags to use when invoking the C compiler. CFLAGS = -O CC = cc # Assembly language object files. Aruntime = mips.o # Profiled library Plib = # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = -G0 # End of DECMIPS header. scheme2c-2012.10.14/ports/DECMIPS/mips.s000066400000000000000000000066551203736146400172040ustar00rootroot00000000000000/* * SCHEME->C * * MIPS assembly code. * */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* sc_s0tos8 returns the values of s0-s8 in the caller supplied buffer. These are the "callee" save registers which need to be examined during garbage collection. */ #ifndef MIPSEL #include #else #include #endif .text .align 2 .globl sc_s0tos8 .ent sc_s0tos8 sc_s0tos8: .frame sp, 0, ra sw s0, 0(a0) sw s1, 4(a0) sw s2, 8(a0) sw s3, 12(a0) sw s4, 16(a0) sw s5, 20(a0) sw s6, 24(a0) sw s7, 28(a0) sw s8, 32(a0) j ra .end sc_s0tos8 /* sc_setsp sets the stack pointer to the argument value. It is necessary as longjmp checks to assure that the call is an "upexit". */ .text .align 2 .globl sc_setsp .ent sc_setsp sc_setsp: .frame sp, 0, ra or sp, a0, a0 j ra .end sc_setsp /************************************************************************** The following 4 arithmetic subroutines use MIPS instructions that generate overflow exceptions which can then be trappped. **************************************************************************/ /* sc_iplus uses the 'add' instruction to calculate the sum of the two integer arguments. */ .text .align 2 .globl sc_iplus .ent sc_iplus sc_iplus: .frame sp, 0, ra add v0, a0, a1 j ra .end sc_iplus /* sc_idifference uses the 'sub' instruction to calculate the difference of the two integer arguments. */ .text .align 2 .globl sc_idifference .ent sc_idifference sc_idifference: .frame sp, 0, ra sub v0, a0, a1 j ra .end sc_idifference /* sc_inegate also uses the 'sub' instruction to calculate the negation of the integer argument. */ .text .align 2 .globl sc_inegate .ent sc_inegate sc_inegate: .frame sp, 0, ra sub v0, $0, a0 j ra .end sc_inegate /* sc_itimes uses the 'mult' instruction to calculate the product of the two integer arguments. */ .text .align 2 .globl sc_itimes .ent sc_itimes sc_itimes: subu sp, 24 sw ra, 20(sp) sd a0, 24(sp) .mask 0x80000000, -4 .frame sp, 24, ra mult a0, a1 mfhi t0 mflo t1 sra t1, t1, 31 bne t0, t1, $overflow mflo v0 lw ra, 20(sp) addu sp, 24 j ra $overflow: mtc1 a0, $f4 cvt.d.w $f6, $f4 srl t1, a1, 2 mtc1 t1, $f8 cvt.d.w $f10, $f8 mul.d $f12, $f6, $f10 jal sc_makedoublefloat lw ra, 20(sp) addu sp, 24 j ra .end sc_itimes scheme2c-2012.10.14/ports/DECMIPS/options-server.h000066400000000000000000000120021203736146400211770ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 1 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define MIPS 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /**************/ /* MIPS */ /**************/ #ifdef MIPS #define IMPLEMENTATION_MACHINE "DECstation" #define IMPLEMENTATION_CPU "Rx000" #define IMPLEMENTATION_OS "ULTRIX" #undef IMPLEMENTATION_FS #define DOUBLE_ALIGN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #ifndef MIPSEL #define BIGMIPS 1 #define BIGENDIAN 1 #undef IMPLEMENTATION_MACHINE #define IMPLEMENTATION_MACHINE "Big Endian MIPS" #undef IMPLEMENTATION_OS /* Not sure what the correct conditionalization is here -- NEWS-OS 5.xx defines both "sony" and "sonyrisc", but apparently NEWS-OS 4.xx defines "sony_mips", because the previous version of Scheme->C was conditionalized on "sony_mips" which is *not* defined by NEWS-OS 5.xx. If there's an intersection between the symbols defined by 4.xx and 5.xx then a member of that intersection should be used for the conditionalization; otherwise test for both. */ #ifdef sonyrisc #undef IMPLEMENTATION_MACHINE #define IMPLEMENTATION_MACHINE "Sony MIPS" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_CPU "R3000" #undef IMPLEMENTATION_OS #define IMPLEMENTATION_OS "NEWS-OS" #ifdef SYSTYPE_SYSV #define SYSV4 1 #define SYSV 1 #define POSIX 1 /* This can be implemented but requires generalizing the signal handler to know about SYSV4 siginfo structure. */ #undef MATHTRAPS #define MATHTRAPS 0 #define NEED_MACRO_ARGS 1 #define COPY_STACK_BEFORE_LONGJMP 1 #endif #endif #endif #include typedef jmp_buf sc_jmp_buf; #define STACKPTR( x ) x = sc_processor_register( 29 ) #endif scheme2c-2012.10.14/ports/DECMIPS/options.h000066400000000000000000000120001203736146400176710ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 0 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 1 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 1 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define MIPS 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /**************/ /* MIPS */ /**************/ #ifdef MIPS #define IMPLEMENTATION_MACHINE "DECstation" #define IMPLEMENTATION_CPU "Rx000" #define IMPLEMENTATION_OS "ULTRIX" #undef IMPLEMENTATION_FS #define DOUBLE_ALIGN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #ifndef MIPSEL #define BIGMIPS 1 #define BIGENDIAN 1 #undef IMPLEMENTATION_MACHINE #define IMPLEMENTATION_MACHINE "Big Endian MIPS" #undef IMPLEMENTATION_OS /* Not sure what the correct conditionalization is here -- NEWS-OS 5.xx defines both "sony" and "sonyrisc", but apparently NEWS-OS 4.xx defines "sony_mips", because the previous version of Scheme->C was conditionalized on "sony_mips" which is *not* defined by NEWS-OS 5.xx. If there's an intersection between the symbols defined by 4.xx and 5.xx then a member of that intersection should be used for the conditionalization; otherwise test for both. */ #ifdef sonyrisc #undef IMPLEMENTATION_MACHINE #define IMPLEMENTATION_MACHINE "Sony MIPS" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_CPU "R3000" #undef IMPLEMENTATION_OS #define IMPLEMENTATION_OS "NEWS-OS" #ifdef SYSTYPE_SYSV #define SYSV4 1 #define SYSV 1 #define POSIX 1 /* This can be implemented but requires generalizing the signal handler to know about SYSV4 siginfo structure. */ #undef MATHTRAPS #define MATHTRAPS 0 #define NEED_MACRO_ARGS 1 #define COPY_STACK_BEFORE_LONGJMP 1 #endif #endif #endif #include typedef jmp_buf sc_jmp_buf; #define STACKPTR( x ) x = sc_processor_register( 29 ) #endif scheme2c-2012.10.14/ports/FREEBSD/000077500000000000000000000000001203736146400160225ustar00rootroot00000000000000scheme2c-2012.10.14/ports/FREEBSD/makefile-head000066400000000000000000000005311203736146400204200ustar00rootroot00000000000000# # This is the header file for constructing make files for FreeBSD. # # Default flags to use when invoking the C compiler. CFLAGS = -O2 CC = gcc # Assembly language object files. Aruntime = x86.o # Profiled library Plib = libsc_p.a # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of FREEBSD header. scheme2c-2012.10.14/ports/FREEBSD/options-server.h000066400000000000000000000077551203736146400212100ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX FREEBSD x86 FreeBSD WIN16 Microsoft Windows 3.1 */ #define FREEBSD 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* FREEBSD */ /***************/ #ifdef FREEBSD #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "Intelx86" #define IMPLEMENTATION_OS "FreeBSD" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR( x ) x = sc_processor_register( 0 ) #include typedef jmp_buf sc_jmp_buf; /* Horrid kludge. See callcc.c for the full story: */ #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 4 #endif scheme2c-2012.10.14/ports/FREEBSD/options.h000066400000000000000000000214471203736146400176760ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX FREEBSD x86 FreeBSD WIN16 Microsoft Windows 3.1 */ #define FREEBSD 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /**************/ /* AOSF */ /**************/ #ifdef AOSF #define IMPLEMENTATION_MACHINE "Alpha AXP" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_OS "OSF/1" #undef IMPLEMENTATION_FS typedef long int S2CINT; /* Signed pointer size integer */ typedef long unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffffffffffL /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x8000000000000000L /* S2CUINT with 1 in the MSB */ typedef long int sc_jmp_buf[ 9 ]; /* The buffer contains the following items: s0-s6 saved registers ra return address sp stack pointer */ #define STACKPTR( x ) x = sc_getsp() extern S2CINT* sc_getsp(); #define NEED_MACRO_ARGS 1 #endif /***************/ /* HP700 */ /***************/ #ifdef HP700 #ifdef __hp9000s700 #define IMPLEMENTATION_MACHINE "HP9000/700" #else #ifdef __hp9000s800 #define IMPLEMENTATION_MACHINE "HP9000/800" #endif #endif #define IMPLEMENTATION_CPU "HP-PA" #define BIGENDIAN 1 #define DOUBLE_ALIGN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register (30))) #define STACK_GROWS_POSITIVE 1 #endif #ifdef __hpux #define IMPLEMENTATION_OS "HP-UX" #undef IMPLEMENTATION_FS #include typedef jmp_buf sc_jmp_buf; #define SYSV 1 #define POSIX 1 #endif /*************/ /* MAC */ /*************/ #ifdef MAC #define IMPLEMENTATION_MACHINE "Apple Macintosh" #define IMPLEMENTATION_CPU "680x0" #define IMPLEMENTATION_OS "7.1" #undef IMPLEMENTATION_FS #define BIGENDIAN 1 typedef long int S2CINT; /* Signed pointer size integer */ typedef long unsigned S2CUINT; /* Unsigned pointer size interger */ typedef short int PAGELINK; /* 16-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffL /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000L /* S2CUINT with 1 in the MSB */ #include typedef jmp_buf sc_jmp_buf; #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_getsp() extern S2CINT* sc_getsp(); #define SCHEAP 1 #define SCMAXHEAP 15 #endif /****************/ /* MC680X0 */ /****************/ #ifdef MC680X0 #define IMPLEMENTATION_CPU "680x0" #define BIGENDIAN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register (15))) #ifdef __hp9000s400 #define IMPLEMENTATION_MACHINE "HP9000/400" #else #ifdef __hp9000s300 #define IMPLEMENTATION_MACHINE "HP9000/300" #endif #endif /* HP-UX dependent conditionalizations performed above. */ #endif /**************/ /* MIPS */ /**************/ #ifdef MIPS #define IMPLEMENTATION_MACHINE "DECstation" #define IMPLEMENTATION_CPU "Rx000" #define IMPLEMENTATION_OS "ULTRIX" #undef IMPLEMENTATION_FS #define DOUBLE_ALIGN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #ifndef MIPSEL #define BIGMIPS 1 #define BIGENDIAN 1 #undef IMPLEMENTATION_MACHINE #define IMPLEMENTATION_MACHINE "Big Endian MIPS" #undef IMPLEMENTATION_OS /* Not sure what the correct conditionalization is here -- NEWS-OS 5.xx defines both "sony" and "sonyrisc", but apparently NEWS-OS 4.xx defines "sony_mips", because the previous version of Scheme->C was conditionalized on "sony_mips" which is *not* defined by NEWS-OS 5.xx. If there's an intersection between the symbols defined by 4.xx and 5.xx then a member of that intersection should be used for the conditionalization; otherwise test for both. */ #ifdef sonyrisc #undef IMPLEMENTATION_MACHINE #define IMPLEMENTATION_MACHINE "Sony MIPS" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_CPU "R3000" #undef IMPLEMENTATION_OS #define IMPLEMENTATION_OS "NEWS-OS" #ifdef SYSTYPE_SYSV #define SYSV4 1 #define SYSV 1 #define POSIX 1 /* This can be implemented but requires generalizing the signal handler to know about SYSV4 siginfo structure. */ #undef MATHTRAPS #define MATHTRAPS 0 #define NEED_MACRO_ARGS 1 #define COPY_STACK_BEFORE_LONGJMP 1 #endif #endif #endif #include typedef jmp_buf sc_jmp_buf; #define STACKPTR( x ) x = sc_processor_register( 29 ) #endif /***************/ /* FREEBSD */ /***************/ #ifdef FREEBSD #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "Intelx86" #define IMPLEMENTATION_OS "FreeBSD" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR( x ) x = sc_processor_register( 0 ) #include typedef jmp_buf sc_jmp_buf; /* Horrid kludge. See callcc.c for the full story: */ #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 4 #endif scheme2c-2012.10.14/ports/FREEBSD/x86.s000066400000000000000000000007361203736146400166410ustar00rootroot00000000000000/* * SCHEME->C * * x86 assembly code. * * This code originally came from the Linux port, so someone else gets * the credit for writing it. * */ #ifdef __i486__ .align 4 #else .align 2 #endif .globl _sc_geti386regs _sc_geti386regs: pushl %ebp movl %esp,%ebp pushl %ecx movl %eax,%ecx movl 8(%ebp),%eax movl %ecx,(%eax) popl %ecx movl %ecx,4(%eax) movl %edx,8(%eax) movl %ebx,12(%eax) movl %esi,16(%eax) movl %edi,20(%eax) movl %ebp,%esp popl %ebp ret scheme2c-2012.10.14/ports/HP300/000077500000000000000000000000001203736146400155025ustar00rootroot00000000000000scheme2c-2012.10.14/ports/HP300/hp300.s000066400000000000000000000031151203736146400165200ustar00rootroot00000000000000# # SCHEME->C # # HP9000s300 assembly code. # # Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. # All Rights Reserved # Permission is hereby granted, free of charge, to any person obtaining a # copy of this software and associated documentation files (the "Software"), # to deal in the Software without restriction, including without limitation # the rights to use, copy, modify, merge, publish, distribute, sublicense, # and/or sell copies of the Software, and to permit persons to whom the # Software is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER # DEALINGS IN THE SOFTWARE. # # # sc_a2to5d2to7 # # sc_a2to5d2to7( a ) # will return the contents of A2, ..., A5, D2, ..., D7 starting at address 'a'. # # text global _sc_a2to5d2to7 even _sc_a2to5d2to7: link.l %a6,&-4 mov.l %a0,(%sp) mov.l (%a0),%a2 mov.l 4(%a0),%a3 mov.l 8(%a0),%a4 mov.l 12(%a0),%a5 mov.l 16(%a0),%d2 mov.l 20(%a0),%d3 mov.l 24(%a0),%d4 mov.l 28(%a0),%d5 mov.l 32(%a0),%d6 mov.l 36(%a0),%d7 unlk %a6 rts scheme2c-2012.10.14/ports/HP300/makefile-head000066400000000000000000000005531203736146400201040ustar00rootroot00000000000000# # This is the header file for constructing make files for HP 9000 series 300. # # Default flags to use when invoking the C compiler. CFLAGS = -Aa -D_HPUX_SOURCE +O1 CC = cc # Assembly language object files. Aruntime = hp300.o # Profiled library Plib = # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of HP300 header. scheme2c-2012.10.14/ports/HP300/options-server.h000066400000000000000000000076771203736146400206730ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define MC680X0 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /****************/ /* MC680X0 */ /****************/ #ifdef MC680X0 #define IMPLEMENTATION_CPU "680x0" #define BIGENDIAN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register (15))) #ifdef __hp9000s400 #define IMPLEMENTATION_MACHINE "HP9000/400" #else #ifdef __hp9000s300 #define IMPLEMENTATION_MACHINE "HP9000/300" #endif #endif /* HP-UX dependent conditionalizations performed above. */ #endif scheme2c-2012.10.14/ports/HP300/options.h000066400000000000000000000077001203736146400173520ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 0 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define MC680X0 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /****************/ /* MC680X0 */ /****************/ #ifdef MC680X0 #define IMPLEMENTATION_CPU "680x0" #define BIGENDIAN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register (15))) #ifdef __hp9000s400 #define IMPLEMENTATION_MACHINE "HP9000/400" #else #ifdef __hp9000s300 #define IMPLEMENTATION_MACHINE "HP9000/300" #endif #endif /* HP-UX dependent conditionalizations performed above. */ #endif scheme2c-2012.10.14/ports/HP700/000077500000000000000000000000001203736146400155065ustar00rootroot00000000000000scheme2c-2012.10.14/ports/HP700/hp700.s000066400000000000000000000035271203736146400165370ustar00rootroot00000000000000/* * SCHEME->C * * PA-RISC assembly code. * */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* sc_r1tor18 returns the values of r1-r18 in the caller supplied buffer. These are the "callee" save registers which need to be examined during garbage collection. */ #include .code .align 2 .export sc_r1tor18, entry sc_r1tor18 .proc .callinfo .enter stw r1,0(%arg0) stw r2,4(%arg0) stw r3,8(%arg0) stw r4,12(%arg0) stw r5,16(%arg0) stw r6,20(%arg0) stw r7,24(%arg0) stw r8,28(%arg0) stw r9,32(%arg0) stw r10,36(%arg0) stw r11,40(%arg0) stw r12,44(%arg0) stw r13,48(%arg0) stw r14,52(%arg0) stw r15,56(%arg0) stw r16,60(%arg0) stw r17,64(%arg0) stw r18,68(%arg0) .leave .procend .end sc_r1tor18 scheme2c-2012.10.14/ports/HP700/makefile-head000066400000000000000000000005521203736146400201070ustar00rootroot00000000000000# # This is the header file for constructing make files for HP 9000 series 700. # # Default flags to use when invoking the C compiler. CFLAGS = -Aa -D_HPUX_SOURCE -O CC = cc # Assembly language object files. Aruntime = hp700.o # Profiled library Plib = # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of HP700 header. scheme2c-2012.10.14/ports/HP700/options-server.h000066400000000000000000000101301203736146400206510ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define HP700 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* HP700 */ /***************/ #ifdef HP700 #ifdef __hp9000s700 #define IMPLEMENTATION_MACHINE "HP9000/700" #else #ifdef __hp9000s800 #define IMPLEMENTATION_MACHINE "HP9000/800" #endif #endif #define IMPLEMENTATION_CPU "HP-PA" #define BIGENDIAN 1 #define DOUBLE_ALIGN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register (30))) #define STACK_GROWS_POSITIVE 1 #endif #ifdef __hpux #define IMPLEMENTATION_OS "HP-UX" #undef IMPLEMENTATION_FS #include typedef jmp_buf sc_jmp_buf; #define SYSV 1 #define POSIX 1 #endif scheme2c-2012.10.14/ports/HP700/options.h000066400000000000000000000101271203736146400173530ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 0 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define HP700 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* HP700 */ /***************/ #ifdef HP700 #ifdef __hp9000s700 #define IMPLEMENTATION_MACHINE "HP9000/700" #else #ifdef __hp9000s800 #define IMPLEMENTATION_MACHINE "HP9000/800" #endif #endif #define IMPLEMENTATION_CPU "HP-PA" #define BIGENDIAN 1 #define DOUBLE_ALIGN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register (30))) #define STACK_GROWS_POSITIVE 1 #endif #ifdef __hpux #define IMPLEMENTATION_OS "HP-UX" #undef IMPLEMENTATION_FS #include typedef jmp_buf sc_jmp_buf; #define SYSV 1 #define POSIX 1 #endif scheme2c-2012.10.14/ports/LINUX/000077500000000000000000000000001203736146400156475ustar00rootroot00000000000000scheme2c-2012.10.14/ports/LINUX/linux.s000066400000000000000000000005661203736146400172010ustar00rootroot00000000000000/* * SCHEME->C * * LINUX assembly code. * */ #ifdef __i486__ .align 4 #else .align 2 #endif .globl sc_geti386regs sc_geti386regs: pushl %ebp movl %esp,%ebp pushl %ecx movl %eax,%ecx movl 8(%ebp),%eax movl %ecx,(%eax) popl %ecx movl %ecx,4(%eax) movl %edx,8(%eax) movl %ebx,12(%eax) movl %esi,16(%eax) movl %edi,20(%eax) movl %ebp,%esp popl %ebp ret scheme2c-2012.10.14/ports/LINUX/makefile-head000066400000000000000000000007111203736146400202450ustar00rootroot00000000000000# # This is the header file for constructing make files for LINUX. # # Default flags to use when invoking the C compiler. CFLAGS = -march=native -Wall -O2 -finline-functions -fno-math-errno -frename-registers -fomit-frame-pointer -m32 LDFLAGS = -m32 -lsigsegv CC = gcc # Assembly language object files. Aruntime = linux.o # Profiled library Plib = # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of LINUX header. scheme2c-2012.10.14/ports/LINUX/options-server.h000066400000000000000000000101221203736146400210130ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ #define STACK_OVERFLOW 1 /* If you're going to disable this, remove it from makefile-head as well */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define LINUX 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* LINUX */ /***************/ #ifdef LINUX #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "Intelx86" #define IMPLEMENTATION_OS "Linux" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_processor_register( 0 ) #define POSIX 1 #include typedef jmp_buf sc_jmp_buf; #define DOUBLE_ALIGN 1 #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 4 #endif scheme2c-2012.10.14/ports/LINUX/options.h000066400000000000000000000101501203736146400175100ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ #define STACK_OVERFLOW 1 /* If you're going to disable this, remove it from makefile-head as well */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define LINUX 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* LINUX */ /***************/ #ifdef LINUX #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "Intelx86" #define IMPLEMENTATION_OS "Linux" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_processor_register( 0 ) #define POSIX 1 #include typedef jmp_buf sc_jmp_buf; #define DOUBLE_ALIGN 1 #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 4 #define SCMAXHEAP 4000U #endif scheme2c-2012.10.14/ports/MAC/000077500000000000000000000000001203736146400153505ustar00rootroot00000000000000scheme2c-2012.10.14/ports/MAC/README000066400000000000000000000131671203736146400162400ustar00rootroot00000000000000Scheme->C for the Apple Macintosh on system 7.1 Scheme->C can be built for the Macintosh using Think C 5.0 as either a component to be embedded in an application, or as an interactive Scheme interpreter. The MAC directory contains two directories, scrt, containing the Scheme interpreter and runtime system and test, containing test programs. The first step is to get the sources to the Macintosh. If you're using xmodem, this can be done as follows. First, on the workstation, pack all relevant files into one file: csh 1 > cd MAC/scrt csh 2 > pack The result of this is the file sourcefiles. Next, transfer MAC/scrt/sourcefiles amd MAC/scrt/unpack.c to the Macintosh desktop using xmodem and your favorite terminal emulator or some other file transfer tool. On the Macintosh inside Think C's development folder, create a folder called Scheme->C. Move sourcefiles and unpack.c from the desktop to this folder, and start Think C. To unpack the source files, take the following steps. 1. Create a new project called unpack.pi in the Scheme->C folder. Add unpack.c and the ANSI library to it and then bring the project up to date. A compile error may occur if xmodem added extraneous characters to the end of the file. Edit and rebuild as required. 2. Run the program and select sourcefiles as the input file for the program. As it executes, it lists the name of each file as it unpacks it. The message "Junk on end-of-file, Quit!" may be ignored as long as the previous line is "test20-input.sc". 3. When the program completes, you may delete the file sourcefiles as it is no longer needed. The sci project, which builds an interactive Scheme interpreter, is now set up as follows: 1. Using the finder, create a new folder called Scheme->C inside the the Think C 5.0 folder. Place of a copy of objects.h into this folder. 2. Returning to Think C, close the existing project and create a new project called sci.pi in the Scheme->C folder. 3. Set the following options on the project via the Edit menu: Code Optimization disable Defer & combine stack adjusts enable Use Global Optimizer Debugging enable Use Source Debugger enable Always generate stack frames 4. Set the following options on the project via the Project menu: Partition (K) 1500 enable Far DATA 5. Add all .c files to it except: cio.c, embedded.c, sci.c and unpack.c. Put each file in a different code segment as there is significantly more than 32KB of code. 6. Add the ANSI and unix libraries. 7. Bring the project up to date and then run it. 8. Press GO on the debug menu and you should see a window titled "Scheme->C" with the following text at the buttom: Scheme->C -- 01feb93jfb -- Copyright .... > 9. To run the tests, perform the following operations: > (load "alltests.sc") . . . TEST23 TEST55 "alltests.sc" > (test) ***** Begin Scheme->C Tests ***** . . . ***** End Scheme->C Tests 0 Errors ***** #F > Enter control-D to terminate the program. 10. At this point, you may build the application sci. You may wish to resegment the code before doing this. The result is a "double-clickable" Scheme interpreter. Use it just like sci on workstations: control-c (or apple-.) to interrupt running programs, control-d to continue after breakpoints or terminate the program when at the top-level, (top-level) to return to the top level. While a Scheme program is running, the mouse may be used to bring up desk accessories or other applications. The user interface of sci is "quick-and-dirty". I'm sure you'll do better on the interfaces that you build in your applications that incorporate Scheme->C. An alternative way to build Scheme->C is as an element that can be embedded in a program. Create the project embedded.pi as follows: 1. Create a new project called embedded.pi in the Scheme->C folder. 2. Set the following options on the project via the Edit menu: Code Optimization disable Defer & combine stack adjusts enable Use Global Optimizer Debugging enable Use Source Debugger enable Always generate stack frames 3. Set the following options on the project via the Project menu: Partition (K) 1500 enable Far DATA 4. Add all .c files to it except: cio-MACSCI.c, sci.c and unpack.c. Put each file in a different code segment as there is significantly more than 32KB of code. 5. Add the ANSI and unix libraries. 6. Bring the project up to date and then run it. 7. After pressing the GO button on the debug window, you'll see a window titled Scheme->C with the following text at the bottom: Embedded Scheme->C Test Bed 0- This behaves exactly as shown in the embedded document. Entering a control-D at the prompt or apple-. during execution will terminate the program. 8. If desired, this application can be turned into a double-clickable application. If you're seriously interested in embedding Scheme->C inside an application on the Macintosh, then you probably know a lot more about the Macintosh environment than I do, so here's a few things to keep in mind: larger heap - If you give Scheme more memory and it needs it, it will expand the heap. better user interface to sci - what you see now is a quick-and-dirty hack on the console interface, you can do better. Scheme->C compiler on the Macintosh - it needs a user interface and a little resegmenting to fit in 32KB segments. It also needs more than 1.5MB! Another exercise for the student. time slice setting - experiment, find the best trade off for your application between interactive response and work accomplished. scheme2c-2012.10.14/ports/MAC/makefile-head000066400000000000000000000002021203736146400177410ustar00rootroot00000000000000# Header for the MAC port for Scheme->C unpack: unpack.c cc -o unpack unpack.c sourcefiles: pack sourcefiles # End of header scheme2c-2012.10.14/ports/MAC/options.h000066400000000000000000000077201203736146400172220ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 1 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 1 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define MAC 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /*************/ /* MAC */ /*************/ #ifdef MAC #define IMPLEMENTATION_MACHINE "Apple Macintosh" #define IMPLEMENTATION_CPU "680x0" #define IMPLEMENTATION_OS "7.1" #undef IMPLEMENTATION_FS #define BIGENDIAN 1 typedef long int S2CINT; /* Signed pointer size integer */ typedef long unsigned S2CUINT; /* Unsigned pointer size interger */ typedef short int PAGELINK; /* 16-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffL /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000L /* S2CUINT with 1 in the MSB */ #include typedef jmp_buf sc_jmp_buf; #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_getsp() extern S2CINT* sc_getsp(); #define SCHEAP 1 #define SCMAXHEAP 15 #endif scheme2c-2012.10.14/ports/MAC/pack000077500000000000000000000003461203736146400162170ustar00rootroot00000000000000#! /bin/csh -f rm -f sourcefiles touch sourcefiles foreach x ({*.c,*.h,../test/alltests.sc,../test/test20-input.sc}) echo "####START" >> sourcefiles echo $x:t >> sourcefiles cat $x >> sourcefiles echo "####END" >> sourcefiles end scheme2c-2012.10.14/ports/MAC/unpack000066400000000000000000000642341203736146400165650ustar00rootroot00000000000000bdb[+0`8    @@þÿÿ³€Š.text @ @   .data @.sdata   *0.sbss° ° 00.bssà à €¤<€Šœ'¥'H…¯¦$€L€¯!0Âèÿ½'@†¯ ¯d D„¯ü ! @ à½'à!ø ðþ½'4¿¯0·¯,¶¯(µ¯$´¯ ³¯²¯±¯°¯€ H¤'E@4¿<<< ÷&”&ts&€‘'€’'€•' €–'H¤'¼ !(€-@! à€ H¤'! @l !( @!€@ü $H¤'x !(`€ H¤'@H¤'¼ !( @H¤'x !(! @x !(€ H¤'@H¤'¼ !( óÿ@H¤'C ! ! Àx !(`! àx !(`ü $€ H¤'Éÿ@H¤'4¿°±² ³$´(µ,¶0·½'à!¸ÿ½'¿¯€(£'Ž€ ÀÐ (¤¯0£',¢¯0€'$o¬x¬c$L™œ€ˆ*( €H!0… ¡,!  $@+Eýÿ „$4„¯üÿ¢$+F !@0…¯$! üÿ$4„! 0…¯!ÀC+ @@!ÈC!!ÈC+&øÿ „$ <à )%€@!( £Œ `(¤¯¡ ¥¯¥(¤£Œ`!jŒï $ª¬k d b$¿0½'à!8€î$$Ðÿ½'0Ï+À¿¯0‚* ! ÂF! @À ÿÿ$Á€<A ( ¥¯! Â$ ¥¯¦¯t 0§¯ ¥¦0§ÿÿ$ A!@€À$ àà6$ àà####STARTJunk on end-of-file, Quit! Unknown error@(#)data.c 4.1 (ULTRIX) 7/3/90@(#)fopen.c 4.1 ULTRIX 7/3/90@(#)fclose.c 4.1 (ULTRIX) 7/3/90@(#)fputs.c 4.1 (ULTRIX) 7/3/90@(#)errlst.c 4.1 ULTRIX 7/3/90 dpŒœ´ÀÜð 4DXd|œ°ÀÐàô0@Phxœ¬¸Ìàø4Ttˆ¨ÀØô ,\t”¤¼à <Xp”¸Ðä,@ThxŒ¤Èäø  Not ownerNo such file or directoryNo such processInterrupted system callI/O errorNo such device or addressArg list too longExec format errorBad file numberNo childrenNo more processesNot enough corePermission deniedBad addressBlock device requiredMount device busyFile existsCross-device linkNo such deviceNot a directoryIs a directoryInvalid argumentFile table overflowToo many open filesNot a typewriterText file busyFile too largeNo space left on deviceIllegal seekRestricted operation on file systemToo many linksBroken pipeArgument too largeResult too largeOperation would blockOperation now in progressOperation already in progressSocket operation on non-socketDestination address requiredMessage too longProtocol wrong type for socketProtocol not availableProtocol not supportedSocket type not supportedOperation not supportedProtocol family not supportedAddress family not supported by protocol familyAddress already in useCan't assign requested addressNetwork is downNetwork is unreachableNetwork dropped connection on resetSoftware caused connection abortConnection reset by peerNo buffer space availableSocket is already connectedSocket is not connectedCan't send after socket shutdownToo many references: can't spliceConnection timed outConnection refusedToo many levels of symbolic linksFile name too longHost is downHost is unreachableDirectory not emptyToo many processesToo many usersDisc quota exceededStale NFS file handleToo many levels of remote in pathNo message of desired typeIdentifier removedAlignment errorNo locks availableFunction not implemented@(#)strlen.c 4.1 (ULTRIX) 7/3/90@(#)doopen.c 4.1 ULTRIX 7/3/90@(#)findiop.c 4.1 ULTRIX 7/3/90@(#)filbuf.c 4.3 ULTRIX 9/10/90@(#)malloc.c 4.1 (ULTRIX) 7/3/90@(#)flsbuf.c 4.3 (ULTRIX) 9/10/90@(#)calloc.c 4.1 (ULTRIX) 7/3/90@(#)getstdiobuf.c 4.1 (ULTRIX) 7/3/90w####END : à @ ÀðError 0M@ p  ° Ð  0 ` à à  p ÑD`0/¤3è0=|HÜNØÜS+´U¼Ìa>¼dPñ `°€€ÿä@Ð@€€ÿå€ð !  xð#@à# ð ð ð(@Ð0àÀ #ð#€ ‚ÿó€ ÿó€ €ÿó  ððà21ðsD"P°`ðQ'@±X€ €ÿõ€ B5dh!#à$ ðð…0ðb#0%0 ð€ €ÿö€ €ÿ÷€ ð ðð à scá05@Q!!0ÐQ@ˆ€ÿãð ð0ð ð€ ð ðpð ðA0Ð8P à"à!h@0†` ` r2ð10P±`ðPð!XAD21ЄBC3ƒ S€$ ðÀR$ à3P#ƒ(!!€ €ÿ÷„ !0à ð !ð t `ð0ð "ðg0ð„ €ÿò€ÿò€# ð&!à‚ð!!ð#Acq&A`à3!!C àˆ %!!!%Q((@ÀB ð ðT…AC`rððwQAà„@Á8 ð 0à‚ P á"1ðð7 ð00ð!!@Á@ð!ð#!g#ðSð@ ðð!ð3! ð  ðA!0ð  ð @Ð ÐA1ð ðP ð ð ` ð  °` à€ ð  à1` ð  ð €@  à€ ð  àA5Að ð ` ð  ð  ð 0 ð  ð 1 ð1!!€üÿÿÿÿÿÿÿS|Dÿÿÿÿ”–Lÿÿÿÿ¡¥`ÿÿÿÿµ·ÿ€$ÿÿÿÿÿÿÿ €ÌÿÿÿÿÿÿÿH €ôÿÿÿÿÿÿÿ05P€üÿÿÿÿÿÿÿ GYÐ4€üÿÿÿÿÿÿÿ]` €üÿÿÿÿÿÿÿ 3?€üÿÿÿÿÿÿÿ(€ìÿÿÿÿÿÿÿ0\ËÜx€ôÿÿÿÿÿÿÿ Ðí0€Üûÿÿÿÿÿÿ@1Vÿÿÿÿ3ÿÿÿÿ&ÿÿÿÿÿÿÿÿÿÿÿÿ€üÿÿÿÿÿÿÿF‘€ôÿÿÿÿÿÿÿ Ey€Üÿÿÿÿÿÿÿ@G³ÿÿÿÿÿÿÿÿ€äÿÿÿÿÿÿÿ02~„a€äÿÿÿÿÿÿÿ0†«3X –ÿÿÿÿ¯ÇW  ¨€Üÿÿÿÿÿÿÿ8Ú]D ÿÿÿÿ'3€€äÿÿÿÿÿÿÿ@:¦ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ€ôÿÿÿÿÿÿÿ )2\€üÿÿÿÿÿÿÿ8: ÿÿÿÿ€´ÿÿÿÿÿÿÿ`9Rÿÿÿÿÿÿÿÿ(ÿÿÿÿÿÿÿÿ]߀Ôÿÿÿÿÿÿÿ@ ÿÿÿÿ0`ÿÿÿÿ1ÿÿÿÿÿÿÿÿÿÿÿÿK° Bñÿÿ @F DH d@F`H@&l@F & H`.€@Fà.H€HK HK HK HK HK HK HK@ @FÐ tHHK@ @FÐ ÔHHKP ð@FÐÄ Bóÿÿ ÀHHKp Ð Bóÿÿ°@FÐÐH €@Fð$H@HKP à Bóÿÿ°@FÐDH HK@ @FÐ $HHKp ð Bóÿÿ0@FÐÜH  @FðÔH@HKP Bóÿÿà @FÐH HKp ð @F ô @Eðÿÿ!$ @Eðÿÿ., @Eðÿÿ DHHK0  BóÿÿHKP Bóÿÿ@ @FÐH HKP ` @F x @Eðÿÿ HHK@ € @F HHKP @F ¨ @Eðÿÿ HHKP 0 Bóÿÿ° @FÐpH HKP@ Bóÿÿ @FÐ`H HKP P Bóÿÿ€@FÐ<H HKP À@F Ø@Eðÿÿ HHKP à@F ø@Eðÿÿ HHK ` Bóÿÿà Âðÿÿ° ‚óÿÿ!´ ‚óÿÿ,@FÐ,„HP3„@Fð3ÔHp<X@F<HHA @F0A¤H°ID@NPIlHÐHKP p Bóÿÿ°@FÐHH HK@ @F HHK@ @F HHKP @F 8@Eðÿÿ HHKP @@F X@Eðÿÿ HHKp € Bóÿÿ`@FÐ\H ¼@Fð$H@HKPà@F "ø@Eðÿÿ HHKP Bóÿÿ@FаH HKP °@F È@Eðÿÿ HHKP Ð@F ô@Eðÿÿ ,HHKP@F @Eðÿÿ HHK @F D@Eðÿÿd@Eðÿÿ(˜@Eðÿÿ0¬@Eðÿÿ=ø@EðÿÿF @EðÿÿS(@Eðÿÿ_L@Eðÿÿm\@Eðÿÿzt@Eðÿÿƒ|@Eðÿÿ@Eðÿÿ xHHK@  @FÐ <HHKÐ à@F à@F`@Eðÿÿ!@Eðÿÿ.<@Eðÿÿ7L@EðÿÿD\@EðÿÿMh@EðÿÿZt@EðÿÿœH œHHKP €@F ˜@Eðÿÿ HHKP  @F ¸@Eðÿÿ HHÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ  (, $h (, $h (, $hh (, $hhh (, $h0ÿ (, $h (, $h (, $hÿÿÿÿ (, $h (, $hÿÿÿÿÿÿÿÿÿÿÿÿ (, $h0ÿ (, $h0ÿ (, $hÿÿÿÿÿÿÿÿ (, $h    (, $hÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ (, $hÿÿÿÿ (, $hhÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ (, $hÿÿÿÿ ÿÿÿÿ ÿÿÿÿÿÿÿÿ./crt0.sSTARTFRM__startmoncontrol_mcounteprol/usr/include/regdef.h/usr/include/asm.h/usr/include/ansi_compat.h/usr/include/syscall.h/usr/include/sys/sysinfo.h/usr/include/sys/exec.hunpack.cmain../perror.cperror../exit.cexitoldsig_set../data.csccsid_fwalk_cleanup../fopen.csccsidfopen../gets.cgets../fclose.csccsidfflushfclose../fputs.csccsidfputs../strcmp.sstrcmp1$00000000002$00000000003$0000000000../errlst.csccsid../strlen.csccsidstrlen../writev.swritev9$0000000000../_exit.s_exit../sigsetmask.ssigsetmask9$0000000000../doopen.csccsid_doopen../findiop.csccsid_findiop../filbuf.csccsid_filbuf../write.swrite9$0000000000../close.sclose9$0000000000../malloc.csccsidnextfpageszpagebucketmallocmorecorefreereallocfindbucket../flsbuf.csccsid_flsbuf../cerror.s_cerror../abort.sabort../open.sopen9$0000000000../lseek.slseek9$0000000000../calloc.csccsidcalloccfree../getdtablesize.sgetdtablesize9$0000000000../getstdiobuf.csccsid_getstdiobuf../read.sread9$0000000000../sbrk.ssbrkerr../getpagesize.sgetpagesize9$0000000000../bcopy.sbcopy1$0000000000forwardsblkcopy1$0000000001wordcopy1$0000000002unaligncopypartaligncopy1$0000000003bytecopy1$0000000004copydone../isatty.cisatty../bzero.sbzeroblkclrblkzero1$0000000000wordzero1$0000000001bytezero1$0000000002zerodone../fstat.sfstat9$0000000000../ioctl.sioctl9$0000000000__environ__Argc__Argverrno__start_gpmainexitmoncontrol_mcounteprol_iobfopengetsfclosefputsstrcmpsys_nerrsys_errlistperrorstrlenwritev_atexitlist_atexitp_cleanup_exitsigsetmask_iob_start_iob_end_fwalk_doopen_findiop_filbuffflushwriteclosefree_flsbuf_cerrorabortopenlseekcallocgetdtablesize_getstdiobufreadsbrkmallocgetpagesizemorecorerealloc_srchlenreallocbcopyisattybzerocfreefstatend_minbrk_curbrkioctlblkclr @4   @4  # @K  # @_ # @{( # @“2 # @¯< #@È]F@×t5G5ð@ë©0.HP&°@"$Ù==Iv°@(+ NJ…@A0'I _KŒ0@Q"4p­ nLšDà @s;D MÞ&ð @Œ;@aŽN@ @ÇG’ R@ @ÛJrŸS` @ö!Oy®T€ @T²Z @))X…¶`° @R]bºf 3 @nbïXËgS"€@ŒgGÜhu;À@¨l×ëi°à@Çqßïo²@æTvç.óu´°@:†’ vA;@V‹§w|@kª} @}“® !ƒ@@š˜¶!%‡…`@¹!¾ ")‡à@Ú/¤Þ$:Ž•@ &©æ,%>”—°@/®&M•ªÐ@L³ 'Q›¬ @`+¸%(U¡µ @‹™½-^)Y§·_ @$Í‹*]«à@8cÑ š'+l¬$€@›ÞÁ-t°> @ºãÉ.x¶@  !"#$%&'()*À óÿÿ Ä óÿÿÈ óÿÿÌ óÿÿ @F &€ŠEñÿÿ*@F /ð@F4d@F@?l@F`G€@F€ M`ðÿÿ R°@F X@F ] @F@dà @F jð @Fq Aóÿÿz0ðÿÿ†@F@ @F ”` @F ›` Áðÿÿ §À Aóÿÿ °€@F@¹€ @F¿ @F ÊÔ Aóÿÿ ÕÐ óÿÿ Þ°@F å° @F í @F ö€@F þ0@F À@F à@FX@F°@F @F&@F, @F1@@F 7`@F !>à@F"L@F #Y°@F$^Ð@Fc@FP%j@Fv„@Fpd Aóÿÿ @F°&— @F' @F(¤à@F ª¼@F@)°€@F$¶à Åðÿÿ$º  Aóÿÿ$¤ Aóÿÿ*Ê @F(Ðà@F scheme2c-2012.10.14/ports/MAC/unpack.c000066400000000000000000000012401203736146400167720ustar00rootroot00000000000000/* Unpacks the file containing all MAC files. */ #include #ifndef mips #include #endif main() { char line[200], **ap; FILE *out; #ifndef mips ccommand( &ap ); #endif while (gets( line ) != NULL) { if (strcmp( line, "####START" ) == 0) { out = fopen( gets( line ), "w" ); if (out == NULL) exit( 1 ); fputs( line, stdout ); while (gets( line ) != NULL && strcmp( line, "####END" )) { fputs( line, out ); fputs( "\n", out ); } fclose( out ); fputs( "\n", stdout ); } else { fputs( "Junk on end-of-file, Quit!\n", stdout ); exit( 1 ); } } } scheme2c-2012.10.14/ports/OPENBSD/000077500000000000000000000000001203736146400160425ustar00rootroot00000000000000scheme2c-2012.10.14/ports/OPENBSD/makefile-head000066400000000000000000000010061203736146400204360ustar00rootroot00000000000000# # This is the header file for constructing make files for OPENBSD. # # Default flags to use when invoking the C compiler. CFLAGS = -I/usr/local/include -march=native -Wall -O2 -finline-functions -fno-math-errno -frename-registers -fomit-frame-pointer -m32 LDFLAGS = -L/usr/X11R6/lib -L/usr/local/lib -m32 -lsigsegv CC = gcc # Assembly language object files. Aruntime = openbsd.o # Profiled library Plib = # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of OPENBSD header. scheme2c-2012.10.14/ports/OPENBSD/openbsd.s000066400000000000000000000005701203736146400176620ustar00rootroot00000000000000/* * SCHEME->C * * OPENBSD assembly code. * */ #ifdef __i486__ .align 4 #else .align 2 #endif .globl sc_geti386regs sc_geti386regs: pushl %ebp movl %esp,%ebp pushl %ecx movl %eax,%ecx movl 8(%ebp),%eax movl %ecx,(%eax) popl %ecx movl %ecx,4(%eax) movl %edx,8(%eax) movl %ebx,12(%eax) movl %esi,16(%eax) movl %edi,20(%eax) movl %ebp,%esp popl %ebp ret scheme2c-2012.10.14/ports/OPENBSD/options-server.h000066400000000000000000000101301203736146400212050ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ #define STACK_OVERFLOW 1 /* If you're going to disable this, remove it from makefile-head as well */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define OPENBSD 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* OPENBSD */ /***************/ #ifdef OPENBSD #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "Intelx86" #define IMPLEMENTATION_OS "OpenBSD" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_processor_register( 0 ) #define POSIX 1 #include typedef jmp_buf sc_jmp_buf; #define DOUBLE_ALIGN 1 #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 4 #endif scheme2c-2012.10.14/ports/OPENBSD/options.h000066400000000000000000000101561203736146400177110ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ #define STACK_OVERFLOW 1 /* If you're going to disable this, remove it from makefile-head as well */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX WIN16 Microsoft Windows 3.1 */ #define OPENBSD 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /***************/ /* OPENBSD */ /***************/ #ifdef OPENBSD #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "Intelx86" #define IMPLEMENTATION_OS "OpenBSD" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_processor_register( 0 ) #define POSIX 1 #include typedef jmp_buf sc_jmp_buf; #define DOUBLE_ALIGN 1 #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 4 #define SCMAXHEAP 4000U #endif scheme2c-2012.10.14/ports/SGIMIPS/000077500000000000000000000000001203736146400160635ustar00rootroot00000000000000scheme2c-2012.10.14/ports/SGIMIPS/makefile-head000066400000000000000000000006131203736146400204620ustar00rootroot00000000000000# # This is the header file for constructing make files for SGIMIPS. # # Default flags to use when invoking the C compiler. CFLAGS = -O CC = cc # Assembly language object files. Aruntime = mips.o # Profiled library Plib = # Installation tools RANLIB = ../ranlib # X library XLIB = -lX11 XLIBCFLAGS = -G0 # Force make to use the right shell SHELL = /bin/sh # End of SGIMIPS header. scheme2c-2012.10.14/ports/SGIMIPS/ranlib000077500000000000000000000001051203736146400172540ustar00rootroot00000000000000#!/bin/csh echo "ranlib(1) not implemented on Silicon Graphics Iris" scheme2c-2012.10.14/ports/SONYMIPS/000077500000000000000000000000001203736146400162315ustar00rootroot00000000000000scheme2c-2012.10.14/ports/SONYMIPS/makefile-head000066400000000000000000000005301203736146400206260ustar00rootroot00000000000000# # This is the header file for constructing make files for SONYMIPS. # # Default flags to use when invoking the C compiler. CFLAGS = -Xa -O CC = cc # Assembly language object files. Aruntime = mips.o # Profiled library Plib = # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = -G0 # End of SONYMIPS header. scheme2c-2012.10.14/ports/SUNOS4/000077500000000000000000000000001203736146400157435ustar00rootroot00000000000000scheme2c-2012.10.14/ports/SUNOS4/makefile-head000066400000000000000000000007441203736146400203470ustar00rootroot00000000000000# # This is the header file for constructing make files for SPARC-SunOS4.1.x. # # Default flags to use when invoking the C compiler. CFLAGS = -O CC = cc # Assembly language object files. Aruntime = sparc.o # need to override the default ".s.o" rule in the generic makefile sparc.o: sparc.s as -o sparc.o -P -DSUNOS4 sparc.s # Profiled library Plib = libsc_p.a # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of SPARC-SunOS4.1.x header. scheme2c-2012.10.14/ports/SUNOS4/options-server.h000066400000000000000000000026471203736146400211240ustar00rootroot00000000000000/* SCHEME->C */ /****************/ /* SPARC-SunOS4 */ /****************/ #define SPARC #define SUNOS4 /* callcc.c */ #undef COPY_STACK_BEFORE_LONGJMP /* cio.c */ #undef POSIX #undef SYSV #undef SYSV4 #undef HAVE_TIMES /* objects.h */ #define BIGENDIAN 1 #undef COMPACTPUSHTRACE #undef COMPACTPOPTRACE #undef NEED_MACROS_ARGS /* scinit.c */ #define IMPLEMENTATION_MACHINE "SPARC" #define IMPLEMENTATION_CPU "SPARC" #define IMPLEMENTATION_OS "SunOS 4.x" #undef IMPLEMENTATION_FS #undef STDERR_ISNT_UNBUFFERED /* * The sc_jmp_buf buffer contains the following items: * %o6-%o7, %g1-%g7, %l0-%l7, %i0-%i7, %y, * 0-4, 8-32, 36-64, 68-96, 100, 104 */ typedef int sc_jmp_buf[2+7+8+8+1+1]; /* heap.c, objects.h, sparc.s */ #undef DOUBLE_ALIGN /* heap.h, objects.h */ #undef STACK_GROWS_POSITIVE /* callcc.c, objects.h, scinit.c */ #define MATHTRAPS 1 /* mtraps.c, objects.h, sparc.s */ typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register(0))) /* be a server */ #define CHECKSTACK 1 /* objects.h */ #undef S2CSIGNALS /* cio.c */ #define TIMESLICE 1 /* cio.c, cio.h, objects.h */ scheme2c-2012.10.14/ports/SUNOS4/options.h000066400000000000000000000026461203736146400176170ustar00rootroot00000000000000/* SCHEME->C */ /****************/ /* SPARC-SunOS4 */ /****************/ #define SPARC #define SUNOS4 /* callcc.c */ #undef COPY_STACK_BEFORE_LONGJMP /* cio.c */ #undef POSIX #undef SYSV #undef SYSV4 #undef HAVE_TIMES /* objects.h */ #define BIGENDIAN 1 #undef COMPACTPUSHTRACE #undef COMPACTPOPTRACE #undef NEED_MACROS_ARGS /* scinit.c */ #define IMPLEMENTATION_MACHINE "SPARC" #define IMPLEMENTATION_CPU "SPARC" #define IMPLEMENTATION_OS "SunOS 4.x" #undef IMPLEMENTATION_FS #undef STDERR_ISNT_UNBUFFERED /* * The sc_jmp_buf buffer contains the following items: * %o6-%o7, %g1-%g7, %l0-%l7, %i0-%i7, %y, * 0-4, 8-32, 36-64, 68-96, 100, 104 */ typedef int sc_jmp_buf[2+7+8+8+1+1]; /* heap.c, objects.h, sparc.s */ #undef DOUBLE_ALIGN /* heap.h, objects.h */ #undef STACK_GROWS_POSITIVE /* callcc.c, objects.h, scinit.c */ #define MATHTRAPS 1 /* mtraps.c, objects.h, sparc.s */ typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register(0))) /* not a server */ #undef CHECKSTACK /* objects.h */ #define S2CSIGNALS 1 /* cio.c */ #undef TIMESLICE /* cio.c, cio.h, objects.h */ scheme2c-2012.10.14/ports/SUNOS4/sparc-pragma.h000066400000000000000000000002361203736146400204720ustar00rootroot00000000000000/* This is the pragma declaration that is necessary to tell the SPARC */ /* compiler about the new setjmp routine. */ #pragma unknown_control_flow(sc_setjmp) scheme2c-2012.10.14/ports/SUNOS4/sparc.s000066400000000000000000000206101203736146400172360ustar00rootroot00000000000000! ! SCHEME->C ! ! SPARC assembly code. ! Take care of different conventions for global identifiers, ! pseudo-ops, segment/section names, and other declarations. #ifdef __STDC__ #define CONCAT(prefix,suffix) prefix ## suffix #else /* non-portable.. */ #define CONCAT(prefix,suffix) prefix/**/suffix #endif #ifdef SUNOS5 #define XID(id) id #define FUNBEGIN(id) \ .section ".text" ; \ .align 4 ; \ .global XID(id) ; \ XID(id): #define FUNEND(id) \ .type XID(id),#function ; \ .size XID(id),(.-XID(id)) #else /*!SUNOS5, assume SUNOS4*/ #define XID(id) CONCAT(_,id) #define FUNBEGIN(id) \ .seg "text" ; \ .align 4 ; \ .global XID(id) ; \ XID(id): #define FUNEND(id) /*empty*/ #endif /*SUNOS5*/ #ifdef SUNOS5 .file "sparc.s" #define _ASM /* prevent typedef sysset_t */ #endif ! This misnamed function is responsible for providing the ! top of stack address, via macro STACKPTR, to the continuation ! builder and the heap manager. Because both of these functions ! immediately begin examining the memory on the stack, the register ! windows are flushed to memory so their values will be saved in ! heap allocated continuations and seen by the garbage collector. ! ! extern void *sc_processor_register() FUNBEGIN(sc_processor_register) ta 3 ! flush register windows retl ! return mov %sp, %o0 ! ..with stack pointer FUNEND(sc_processor_register) ! On the SPARC, doubles are normally aligned on eight-byte boundaries. ! Sun's bundled C compiler will, upon seeing a double-typed field in a struct, ! make sure the byte offset from the beginning of that struct to the field ! is a multiple of 8. The compiler will therefore insert a 4-byte padding ! between the header and the f.p. value in struct doublefloat (objects.h). ! This means that the object really extends 4 bytes past its allocated memory, ! causing garbage to be read when the object is accessed (the last half of ! the f.p. value will often be read from the next node's header!). Sun's C ! compiler can be tricked into doing this correctly by declaring the field ! as "int value[2]" and accessing it as "*(double*)&(.. ->doublefloat.value[0])". ! Unfortunately, GCC _insists_ on using the ldd/std instructions when accessing ! any "double*". My solution (can you say "kludge"?) is to use the fake ! declaration hack, and two assembly-coded routines for safe accesses. ! As a consequence, DOUBLE_ALIGN need not be defined for the SPARC. ! The two routines below expect the address of the "double" itself, rather ! than the base address of the node. ! extern double sc_get_double(int*) FUNBEGIN(sc_get_double) ld [%o0 + 0], %f0 retl ld [%o0 + 4], %f1 FUNEND(sc_get_double) ! extern void sc_set_double(int*, double) FUNBEGIN(sc_set_double) st %o1, [%o0 + 0] retl st %o2, [%o0 + 4] FUNEND(sc_set_double) ! Rules for building continuations on the SPARC: ! ! 1 - register windows must be flushed to memory before ! the stack is copied to the heap. ! ! 2 - setjmp must save the caller's local and input register ! frames when saving context, because longjmp will not ! have access to the saved stack to fetch the registers ! from their normal resting place. ! ! 3 - longjmp must flush register windows so the correct register ! values will be reloaded from memory when execution continues ! on the restored stack. ! ! 4 - longjmp must restore the caller's local and input register ! frames because the stack hasn't been restored when longjmp ! is called. ! ! ! Save the current environment in a heap allocated continuation. ! ! extern int sc_setjmp(int *jmpbuf) FUNBEGIN(sc_setjmp) st %o6, [%o0 + 0] ! save stack pointer st %o7, [%o0 + 4] ! save continuation pointer st %g1, [%o0 + 8] ! save global registers st %g2, [%o0 + 12] ! these may be allocated for st %g3, [%o0 + 16] ! caller saves registers or st %g4, [%o0 + 20] ! for global values. st %g5, [%o0 + 24] st %g6, [%o0 + 28] st %g7, [%o0 + 32] st %l0, [%o0 + 36] ! save local registers st %l1, [%o0 + 40] ! the sunos setjmp uses st %l2, [%o0 + 44] ! the register windows to st %l3, [%o0 + 48] ! save these, we can't. st %l4, [%o0 + 52] st %l5, [%o0 + 56] st %l6, [%o0 + 60] st %l7, [%o0 + 64] st %i0, [%o0 + 68] st %i1, [%o0 + 72] st %i2, [%o0 + 76] st %i3, [%o0 + 80] st %i4, [%o0 + 84] st %i5, [%o0 + 88] st %i6, [%o0 + 92] st %i7, [%o0 + 96] mov %y, %o2 ! fetch %y st %o2, [%o0 + 100] ! and save it #ifdef SUNOS4 mov %o0, %o5 ! save %o0 in %o5 clr %o0 mov SYS_sigblock, %g1 ! 0x6d ta 0 ! sigblock(0) --> returns old mask st %o0, [%o5 + 104] ! save signal mask #endif #ifdef SUNOS5 add %o0, 104, %o2 ! &jmpbuf[26] clr %o1 ! NULL clr %o0 ! mov SYS_sigprocmask, %g1 ! 0x5f ta 8 ! sigprocmask(0, NULL, &jmpbuf[26]) #endif retl ! return mov %g0, %o0 ! ..zero to caller of sc_setjmp() FUNEND(sc_setjmp) ! ! Restore an environment from a heap allocated continuation. ! ! extern void sc_longjmp(int *jmpbuf, int) FUNBEGIN(sc_longjmp) mov %o0, %i0 ! save %o0 in %i0 mov %o1, %i1 ! save %o1 in %i1 #ifdef SUNOS4 ld [%o0 + 104], %o0 mov SYS_sigsetmask, %g1 ta 0 ! sigsetmask(oldmask) #endif #ifdef SUNOS5 clr %o2 ! NULL add %o0, 104, %o1 ! &jmpbuf[26] mov 3, %o0 ! SIG_SETMASK mov SYS_sigprocmask, %g1 ! 0x5f ta 8 ! sigprocmask(SIG_SETMASK, &jmpbuf[26], NULL) #endif mov %i0, %o0 ! restore %o0 mov %i1, %o1 ! restore o1 ta 3 ! flush register windows ld [%o0 + 0], %o6 ! restore stack pointer ld [%o0 + 4], %o7 ! load continuation pointer ld [%o0 + 8], %g1 ! restore global registers ld [%o0 + 12], %g2 ld [%o0 + 16], %g3 ld [%o0 + 20], %g4 ld [%o0 + 24], %g5 ld [%o0 + 28], %g6 ld [%o0 + 32], %g7 ld [%o0 + 36], %l0 ! restore local frame from stack ld [%o0 + 40], %l1 ld [%o0 + 44], %l2 ld [%o0 + 48], %l3 ld [%o0 + 52], %l4 ld [%o0 + 56], %l5 ld [%o0 + 60], %l6 ld [%o0 + 64], %l7 ld [%o0 + 68], %i0 ld [%o0 + 72], %i1 ld [%o0 + 76], %i2 ld [%o0 + 80], %i3 ld [%o0 + 84], %i4 ld [%o0 + 88], %i5 ld [%o0 + 92], %i6 ld [%o0 + 96], %i7 ld [%o0 + 100], %o2 ! restore %y mov %o2, %y retl ! return mov %o1, %o0 ! ..value is second arg FUNEND(sc_longjmp) ! ! Overflow-checking arithmetic functions ! ! "addcc" and "subcc" always indicate arithmetic overflow by setting the V ! (overflow) flag. ".mul" sets Z if it succeeded, clears it otherwise ! given two upshifted fixnums in <%o0,%o1>, place in %o0 their sum ! either as an upshifted fixnum or as a tagged pointer to a boxed flonum ! ! extern int sc_iplus(int, int) FUNBEGIN(sc_iplus) addcc %o0, %o1, %o2 bvc 0f nop save %sp, -72, %sp sra %i0, 2, %i0 ! downshift to remove tags sra %i1, 2, %i1 std %i0, [%sp + 64] ! transfer to f.p. regs ldd [%sp + 64], %f0 fitod %f0, %f2 ! convert int -> double fitod %f1, %f4 faddd %f2, %f4, %f6 ! add'em std %f6, [%sp + 64] ! move f.p. num back to arg regs ldd [%sp + 64], %i0 call XID(sc_makedoublefloat), 2 ! box & tag result restore 0: retl ! return fixnum mov %o2, %o0 FUNEND(sc_iplus) ! given two upshifted fixnums in <%o0,%o1>, place in %o0 their difference ! either as an upshifted fixnum or as a tagged pointer to a boxed flonum ! ! extern int sc_idifference(int, int) FUNBEGIN(sc_idifference) subcc %o0, %o1, %o2 bvc 0f nop save %sp, -72, %sp sra %i0, 2, %i0 sra %i1, 2, %i1 std %i0, [%sp + 64] ldd [%sp + 64], %f0 fitod %f0, %f2 fitod %f1, %f4 fsubd %f2, %f4, %f6 std %f6, [%sp + 64] ldd [%sp + 64], %i0 call XID(sc_makedoublefloat), 2 restore 0: retl mov %o2, %o0 FUNEND(sc_idifference) ! given an upshifted fixnum in %o0, place in %o0 its negation ! either as an upshifted fixnum or as a tagged pointer to a boxed flonum ! ! extern int sc_inegate(int) FUNBEGIN(sc_inegate) subcc %g0, %o0, %o2 bvc 0f nop save %sp, -72, %sp sra %i0, 2, %i0 st %i0, [%sp + 64] ld [%sp + 64], %f0 fitod %f0, %f6 fnegs %f6, %f6 std %f6, [%sp + 64] ldd [%sp + 64], %i0 call XID(sc_makedoublefloat), 2 restore 0: retl mov %o2, %o0 FUNEND(sc_inegate) ! given a downshifted fixnum in %o0 and an upshifted fixnum in %o1, place in ! %o0 their product either as an upshifted fixnum or as a tagged pointer to ! a boxed flonum ! ! extern int sc_itimes(int, int) FUNBEGIN(sc_itimes) save %sp, -104, %sp mov %i0, %o0 call .mul, 2 mov %i1, %o1 bz,a 0f ! Z == no overflow mov %o0, %i0 sra %i1, 2, %i1 ! %i0 is already down-shifted std %i0, [%sp + 96] ldd [%sp + 96], %f0 fitod %f0, %f2 fitod %f1, %f4 fmuld %f2, %f4, %f6 std %f6, [%sp + 96] ldd [%sp + 96], %i0 call XID(sc_makedoublefloat), 2 restore 0: ret restore FUNEND(sc_itimes) scheme2c-2012.10.14/ports/SUNOS5/000077500000000000000000000000001203736146400157445ustar00rootroot00000000000000scheme2c-2012.10.14/ports/SUNOS5/makefile-head000066400000000000000000000007611203736146400203470ustar00rootroot00000000000000# # This is the header file for constructing make files for SPARC-SunOS5.x # # Default flags to use when invoking the C compiler. CFLAGS = -O CC = cc # Assembly language object files. Aruntime = sparc.o # need to override the default ".s.o" rule in the generic makefile sparc.o: sparc.s cpp sparc.s sparc-cpp.s as -o sparc.o -P sparc-cpp.s # Profiled library Plib = libsc_p.a # Installation tools RANLIB = echo # X library XLIB = -lX11 XLIBCFLAGS = # End of SPARC-SunOS5.x header. scheme2c-2012.10.14/ports/SUNOS5/options-server.h000066400000000000000000000026601203736146400211200ustar00rootroot00000000000000/* SCHEME->C */ /****************/ /* SPARC-SunOS5 */ /****************/ #define SPARC #define SUNOS5 /* callcc.c */ #undef COPY_STACK_BEFORE_LONGJMP /* cio.c */ #define POSIX 1 #define SYSV 1 #define SYSV4 1 #undef HAVE_RUSAGE /* objects.h */ #define BIGENDIAN 1 #undef COMPACTPUSHTRACE #undef COMPACTPOPTRACE #undef NEED_MACROS_ARGS /* scinit.c */ #define IMPLEMENTATION_MACHINE "SPARC" #define IMPLEMENTATION_CPU "SPARC" #define IMPLEMENTATION_OS "SunOS 5.x" #undef IMPLEMENTATION_FS #undef STDERR_ISNT_UNBUFFERED /* * The sc_jmp_buf buffer contains the following items: * %o6-%o7, %g1-%g7, %l0-%l7, %i0-%i7, %y, * 0-4, 8-32, 36-64, 68-96, 100, 104-116 */ typedef int sc_jmp_buf[2+7+8+8+1+4]; /* heap.c, objects.h, sparc.s */ #undef DOUBLE_ALIGN /* heap.h, objects.h */ #undef STACK_GROWS_POSITIVE /* callcc.c, objects.h, scinit.c */ #define MATHTRAPS 1 /* mtraps.c, objects.h, sparc.s */ typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register(0))) /* be a server */ #define CHECKSTACK 1 /* objects.h */ #undef S2CSIGNALS /* cio.c */ #define TIMESLICE 1 /* cio.c, cio.h, objects.h */ scheme2c-2012.10.14/ports/SUNOS5/options.h000066400000000000000000000026571203736146400176220ustar00rootroot00000000000000/* SCHEME->C */ /****************/ /* SPARC-SunOS5 */ /****************/ #define SPARC #define SUNOS5 /* callcc.c */ #undef COPY_STACK_BEFORE_LONGJMP /* cio.c */ #define POSIX 1 #define SYSV 1 #define SYSV4 1 #undef HAVE_RUSAGE /* objects.h */ #define BIGENDIAN 1 #undef COMPACTPUSHTRACE #undef COMPACTPOPTRACE #undef NEED_MACROS_ARGS /* scinit.c */ #define IMPLEMENTATION_MACHINE "SPARC" #define IMPLEMENTATION_CPU "SPARC" #define IMPLEMENTATION_OS "SunOS 5.x" #undef IMPLEMENTATION_FS #undef STDERR_ISNT_UNBUFFERED /* * The sc_jmp_buf buffer contains the following items: * %o6-%o7, %g1-%g7, %l0-%l7, %i0-%i7, %y, * 0-4, 8-32, 36-64, 68-96, 100, 104-116 */ typedef int sc_jmp_buf[2+7+8+8+1+4]; /* heap.c, objects.h, sparc.s */ #undef DOUBLE_ALIGN /* heap.h, objects.h */ #undef STACK_GROWS_POSITIVE /* callcc.c, objects.h, scinit.c */ #define MATHTRAPS 1 /* mtraps.c, objects.h, sparc.s */ typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register(0))) /* not a server */ #undef CHECKSTACK /* objects.h */ #define S2CSIGNALS 1 /* cio.c */ #undef TIMESLICE /* cio.c, cio.h, objects.h */ scheme2c-2012.10.14/ports/SUNOS5/sparc-pragma.h000066400000000000000000000002361203736146400204730ustar00rootroot00000000000000/* This is the pragma declaration that is necessary to tell the SPARC */ /* compiler about the new setjmp routine. */ #pragma unknown_control_flow(sc_setjmp) scheme2c-2012.10.14/ports/SUNOS5/sparc.s000066400000000000000000000205761203736146400172520ustar00rootroot00000000000000! ! SCHEME->C ! ! SPARC assembly code. ! Take care of different conventions for global identifiers, ! pseudo-ops, segment/section names, and other declarations. #ifdef __STDC__ #define CONCAT(prefix,suffix) prefix ## suffix #else /* non-portable.. */ #define CONCAT(prefix,suffix) prefix/**/suffix #endif #ifdef SUNOS5 #define XID(id) id #define FUNBEGIN(id) \ .section ".text" ; \ .align 4 ; \ .global XID(id) ; \ XID(id): #define FUNEND(id) \ .type XID(id),#function ; \ .size XID(id),(.-XID(id)) #else /*!SUNOS5, assume SUNOS4*/ #define XID(id) id #define FUNBEGIN(id) \ .seg "text" ; \ .align 4 ; \ .global XID(id) ; \ XID(id): #define FUNEND(id) /*empty*/ #endif /*SUNOS5*/ #ifdef SUNOS5 .file "sparc.s" #define _ASM /* prevent typedef sysset_t */ #endif ! This misnamed function is responsible for providing the ! top of stack address, via macro STACKPTR, to the continuation ! builder and the heap manager. Because both of these functions ! immediately begin examining the memory on the stack, the register ! windows are flushed to memory so their values will be saved in ! heap allocated continuations and seen by the garbage collector. ! ! extern void *sc_processor_register() FUNBEGIN(sc_processor_register) ta 3 ! flush register windows retl ! return mov %sp, %o0 ! ..with stack pointer FUNEND(sc_processor_register) ! On the SPARC, doubles are normally aligned on eight-byte boundaries. ! Sun's bundled C compiler will, upon seeing a double-typed field in a struct, ! make sure the byte offset from the beginning of that struct to the field ! is a multiple of 8. The compiler will therefore insert a 4-byte padding ! between the header and the f.p. value in struct doublefloat (objects.h). ! This means that the object really extends 4 bytes past its allocated memory, ! causing garbage to be read when the object is accessed (the last half of ! the f.p. value will often be read from the next node's header!). Sun's C ! compiler can be tricked into doing this correctly by declaring the field ! as "int value[2]" and accessing it as "*(double*)&(.. ->doublefloat.value[0])". ! Unfortunately, GCC _insists_ on using the ldd/std instructions when accessing ! any "double*". My solution (can you say "kludge"?) is to use the fake ! declaration hack, and two assembly-coded routines for safe accesses. ! As a consequence, DOUBLE_ALIGN need not be defined for the SPARC. ! The two routines below expect the address of the "double" itself, rather ! than the base address of the node. ! extern double sc_get_double(int*) FUNBEGIN(sc_get_double) ld [%o0 + 0], %f0 retl ld [%o0 + 4], %f1 FUNEND(sc_get_double) ! extern void sc_set_double(int*, double) FUNBEGIN(sc_set_double) st %o1, [%o0 + 0] retl st %o2, [%o0 + 4] FUNEND(sc_set_double) ! Rules for building continuations on the SPARC: ! ! 1 - register windows must be flushed to memory before ! the stack is copied to the heap. ! ! 2 - setjmp must save the caller's local and input register ! frames when saving context, because longjmp will not ! have access to the saved stack to fetch the registers ! from their normal resting place. ! ! 3 - longjmp must flush register windows so the correct register ! values will be reloaded from memory when execution continues ! on the restored stack. ! ! 4 - longjmp must restore the caller's local and input register ! frames because the stack hasn't been restored when longjmp ! is called. ! ! ! Save the current environment in a heap allocated continuation. ! ! extern int sc_setjmp(int *jmpbuf) FUNBEGIN(sc_setjmp) st %o6, [%o0 + 0] ! save stack pointer st %o7, [%o0 + 4] ! save continuation pointer st %g1, [%o0 + 8] ! save global registers st %g2, [%o0 + 12] ! these may be allocated for st %g3, [%o0 + 16] ! caller saves registers or st %g4, [%o0 + 20] ! for global values. st %g5, [%o0 + 24] st %g6, [%o0 + 28] st %g7, [%o0 + 32] st %l0, [%o0 + 36] ! save local registers st %l1, [%o0 + 40] ! the sunos setjmp uses st %l2, [%o0 + 44] ! the register windows to st %l3, [%o0 + 48] ! save these, we can't. st %l4, [%o0 + 52] st %l5, [%o0 + 56] st %l6, [%o0 + 60] st %l7, [%o0 + 64] st %i0, [%o0 + 68] st %i1, [%o0 + 72] st %i2, [%o0 + 76] st %i3, [%o0 + 80] st %i4, [%o0 + 84] st %i5, [%o0 + 88] st %i6, [%o0 + 92] st %i7, [%o0 + 96] mov %y, %o2 ! fetch %y st %o2, [%o0 + 100] ! and save it #ifdef SUNOS4 mov %o0, %o5 ! save %o0 in %o5 clr %o0 mov SYS_sigblock, %g1 ! 0x6d ta 0 ! sigblock(0) --> returns old mask st %o0, [%o5 + 104] ! save signal mask #endif #ifdef SUNOS5 add %o0, 104, %o2 ! &jmpbuf[26] clr %o1 ! NULL clr %o0 ! mov SYS_sigprocmask, %g1 ! 0x5f ta 8 ! sigprocmask(0, NULL, &jmpbuf[26]) #endif retl ! return mov %g0, %o0 ! ..zero to caller of sc_setjmp() FUNEND(sc_setjmp) ! ! Restore an environment from a heap allocated continuation. ! ! extern void sc_longjmp(int *jmpbuf, int) FUNBEGIN(sc_longjmp) mov %o0, %i0 ! save %o0 in %i0 mov %o1, %i1 ! save %o1 in %i1 #ifdef SUNOS4 ld [%o0 + 104], %o0 mov SYS_sigsetmask, %g1 ta 0 ! sigsetmask(oldmask) #endif #ifdef SUNOS5 clr %o2 ! NULL add %o0, 104, %o1 ! &jmpbuf[26] mov 3, %o0 ! SIG_SETMASK mov SYS_sigprocmask, %g1 ! 0x5f ta 8 ! sigprocmask(SIG_SETMASK, &jmpbuf[26], NULL) #endif mov %i0, %o0 ! restore %o0 mov %i1, %o1 ! restore o1 ta 3 ! flush register windows ld [%o0 + 0], %o6 ! restore stack pointer ld [%o0 + 4], %o7 ! load continuation pointer ld [%o0 + 8], %g1 ! restore global registers ld [%o0 + 12], %g2 ld [%o0 + 16], %g3 ld [%o0 + 20], %g4 ld [%o0 + 24], %g5 ld [%o0 + 28], %g6 ld [%o0 + 32], %g7 ld [%o0 + 36], %l0 ! restore local frame from stack ld [%o0 + 40], %l1 ld [%o0 + 44], %l2 ld [%o0 + 48], %l3 ld [%o0 + 52], %l4 ld [%o0 + 56], %l5 ld [%o0 + 60], %l6 ld [%o0 + 64], %l7 ld [%o0 + 68], %i0 ld [%o0 + 72], %i1 ld [%o0 + 76], %i2 ld [%o0 + 80], %i3 ld [%o0 + 84], %i4 ld [%o0 + 88], %i5 ld [%o0 + 92], %i6 ld [%o0 + 96], %i7 ld [%o0 + 100], %o2 ! restore %y mov %o2, %y retl ! return mov %o1, %o0 ! ..value is second arg FUNEND(sc_longjmp) ! ! Overflow-checking arithmetic functions ! ! "addcc" and "subcc" always indicate arithmetic overflow by setting the V ! (overflow) flag. ".mul" sets Z if it succeeded, clears it otherwise ! given two upshifted fixnums in <%o0,%o1>, place in %o0 their sum ! either as an upshifted fixnum or as a tagged pointer to a boxed flonum ! ! extern int sc_iplus(int, int) FUNBEGIN(sc_iplus) addcc %o0, %o1, %o2 bvc 0f nop save %sp, -72, %sp sra %i0, 2, %i0 ! downshift to remove tags sra %i1, 2, %i1 std %i0, [%sp + 64] ! transfer to f.p. regs ldd [%sp + 64], %f0 fitod %f0, %f2 ! convert int -> double fitod %f1, %f4 faddd %f2, %f4, %f6 ! add'em std %f6, [%sp + 64] ! move f.p. num back to arg regs ldd [%sp + 64], %i0 call XID(sc_makedoublefloat), 2 ! box & tag result restore 0: retl ! return fixnum mov %o2, %o0 FUNEND(sc_iplus) ! given two upshifted fixnums in <%o0,%o1>, place in %o0 their difference ! either as an upshifted fixnum or as a tagged pointer to a boxed flonum ! ! extern int sc_idifference(int, int) FUNBEGIN(sc_idifference) subcc %o0, %o1, %o2 bvc 0f nop save %sp, -72, %sp sra %i0, 2, %i0 sra %i1, 2, %i1 std %i0, [%sp + 64] ldd [%sp + 64], %f0 fitod %f0, %f2 fitod %f1, %f4 fsubd %f2, %f4, %f6 std %f6, [%sp + 64] ldd [%sp + 64], %i0 call XID(sc_makedoublefloat), 2 restore 0: retl mov %o2, %o0 FUNEND(sc_idifference) ! given an upshifted fixnum in %o0, place in %o0 its negation ! either as an upshifted fixnum or as a tagged pointer to a boxed flonum ! ! extern int sc_inegate(int) FUNBEGIN(sc_inegate) subcc %g0, %o0, %o2 bvc 0f nop save %sp, -72, %sp sra %i0, 2, %i0 st %i0, [%sp + 64] ld [%sp + 64], %f0 fitod %f0, %f6 fnegs %f6, %f6 std %f6, [%sp + 64] ldd [%sp + 64], %i0 call XID(sc_makedoublefloat), 2 restore 0: retl mov %o2, %o0 FUNEND(sc_inegate) ! given a downshifted fixnum in %o0 and an upshifted fixnum in %o1, place in ! %o0 their product either as an upshifted fixnum or as a tagged pointer to ! a boxed flonum ! ! extern int sc_itimes(int, int) FUNBEGIN(sc_itimes) save %sp, -104, %sp mov %i0, %o0 call .mul, 2 mov %i1, %o1 bz,a 0f ! Z == no overflow mov %o0, %i0 sra %i1, 2, %i1 ! %i0 is already down-shifted std %i0, [%sp + 96] ldd [%sp + 96], %f0 fitod %f0, %f2 fitod %f1, %f4 fmuld %f2, %f4, %f6 std %f6, [%sp + 96] ldd [%sp + 96], %i0 call XID(sc_makedoublefloat), 2 restore 0: ret restore FUNEND(sc_itimes) scheme2c-2012.10.14/ports/VAX/000077500000000000000000000000001203736146400154065ustar00rootroot00000000000000scheme2c-2012.10.14/ports/VAX/makefile-head000066400000000000000000000005171203736146400200100ustar00rootroot00000000000000# # This is the header file for constructing make files for VAX. # # Default flags to use when invoking the C compiler. CFLAGS = -O CC = cc # Assembly language object files. Aruntime = vax.o # Profiled library Plib = libsc_p.a # Installation tools RANLIB = ranlib # X library XLIB = -lX11 XLIBCFLAGS = # End of VAX header. scheme2c-2012.10.14/ports/VAX/options-server.h000066400000000000000000000101411203736146400205530ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 1 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 1 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX */ #define VAX 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /*************/ /* VAX */ /*************/ #ifdef VAX #define IMPLEMENTATION_MACHINE "VAX" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_OS "ULTRIX" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ typedef int sc_jmp_buf[ 16 ]; /* The buffer contains the following items: R2-R11 saved registers SIGM saved signal mask SP stack pointer on entry to setjmp PSW PSW word from stack frame AP saved argument ptr from frame FP saved frame ptr from frame PC saved program cntr from frame */ #define STACKPTR( x ) x = sc_processor_register( 14 ) #endif scheme2c-2012.10.14/ports/VAX/options.h000066400000000000000000000101411203736146400172470ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 0 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 1 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX */ #define VAX 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /*************/ /* VAX */ /*************/ #ifdef VAX #define IMPLEMENTATION_MACHINE "VAX" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_OS "ULTRIX" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ typedef int sc_jmp_buf[ 16 ]; /* The buffer contains the following items: R2-R11 saved registers SIGM saved signal mask SP stack pointer on entry to setjmp PSW PSW word from stack frame AP saved argument ptr from frame FP saved frame ptr from frame PC saved program cntr from frame */ #define STACKPTR( x ) x = sc_processor_register( 14 ) #endif scheme2c-2012.10.14/ports/VAX/vax.s000066400000000000000000000124321203736146400163720ustar00rootroot00000000000000/* * SCHEME->C * * VAX assembly code. * */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* * sc_r2tor11 * * sc_r2tor11( a ) * will return the contents of R2 through R11 starting at address 'a'. * */ .globl _sc_r2tor11 .align 2 _sc_r2tor11: .word 0 movl 4(ap),r1 # r1 = address of buffer movl r2,(r1) # Save R2-R11 movl r3,4(r1) movl r4,8(r1) movl r5,12(r1) movl r6,16(r1) movl r7,20(r1) movl r8,24(r1) movl r9,28(r1) movl r10,32(r1) movl r11,36(r1) ret /* * sc_setjmp, sc_longjmp * * This code is based upon the C library functions. They cannot be used as * they assume that longjmp is always an "upexit", which is not sufficiently * general for Scheme's call-with-current-continuation. * * sc_longjmp(a,v) * will generate a "return(v)" from * the last call to * sc_setjmp(a) * by restoring registers from the saved state, the * previous signal mask, and then doing a return. * * BUG: always restores onsigstack state to 0 * */ .globl _sc_setjmp .align 2 _sc_setjmp: .word 0 pushl $0 calls $1,_sigblock # r0 = signal mask movl 4(ap),r1 # r1 = address of jmp_buf movl r2,(r1) # Save R2-R11 movl r3,4(r1) movl r4,8(r1) movl r5,12(r1) movl r6,16(r1) movl r7,20(r1) movl r8,24(r1) movl r9,28(r1) movl r10,32(r1) movl r11,36(r1) movl r0,40(r1) # Save signal mask movl sp,44(r1) # Save current stack pointer movl 4(fp),48(r1) # Save PSW word from frame movl 8(fp),52(r1) # Save argument ptr from frame movl 12(fp),56(r1) # Save frame ptr from frame movl 16(fp),60(r1) # Save program cntr from frame clrl r0 ret .globl _sc_longjmp .align 2 _sc_longjmp: .word 0 movl 8(ap),r0 # r0 = return value movl 4(ap),r1 # r1 = address of jmp_buf movl (r1),r2 # Restore R2-R11 movl 4(r1),r3 movl 8(r1),r4 movl 12(r1),r5 movl 16(r1),r6 movl 20(r1),r7 movl 24(r1),r8 movl 28(r1),r9 movl 32(r1),r10 movl 36(r1),r11 movl 44(r1),sp # Restore the stack pointer movl sp,fp # Restore the frame pointer movl $0,(fp) # Restore frame: condition handler movl 48(r1),4(fp) # PSW movl 52(r1),8(fp) # AP movl 56(r1),12(fp) # FP movl 60(r1),16(fp) # PC movl $1,20(fp) # arg cnt for sc_setjmp pushl sp # old stack pointer pushl 40(r1) # old signal mask pushl $0 # old onsigstack pushl sp # pointer to sigcontext chmk $139 # restore previous signal context ret # done, return.... /* * sc_iplus * returns the integer sum, a + b, where a and b are the two * integer arguments, unless integer overflow occurs, then returns * (unsigned int) sc_makedoublefloat( (double)a + (double)b ) instead. */ .text .align 2 .globl _sc_iplus _sc_iplus: .word 0 addl3 8(ap),4(ap),r0 bvs sc_iplus_overflow ret sc_iplus_overflow: ashl $-2,4(ap),r0 cvtld r0,r0 ashl $-2,8(ap),r2 cvtld r2,r2 addd2 r2,r0 movd r0,-(sp) calls $2,_sc_makedoublefloat ret /* * sc_idifference * returns integer difference, a - b, where a and b are the two * integer arguments, unless integer overflow occurs, then returns * (unsigned int) sc_makedoublefloat( (double)a - (double)b ) instead. */ .text .align 2 .globl _sc_idifference _sc_idifference: .word 0 subl3 8(ap),4(ap),r0 bvs sc_idifference_overflow ret sc_idifference_overflow: ashl $-2,4(ap),r0 cvtld r0,r0 ashl $-2,8(ap),r2 cvtld r2,r2 subd2 r2,r0 movd r0,-(sp) calls $2,_sc_makedoublefloat ret /* * sc_inegate * returns integer negation, -a, where a is the integer * argument, unless integer overflow occurs, then returns * (unsigned int) sc_makedoublefloat( (double)a - (double)b ) instead. */ .text .align 2 .globl _sc_inegate _sc_inegate: .word 0 mnegl 4(ap),r0 bvs sc_inegate_overflow ret sc_inegate_overflow: ashl $-2,4(ap),r0 cvtld r0,r0 mnegd r0,r2 movd r2,-(sp) calls $2,_sc_makedoublefloat ret /* * sc_itimes * returns integer procuct, a * b, where a and b are the two * integer arguments, unless integer overflow occurs, then returns * (unsigned int) sc_makedoublefloat( (double)a * (double)b ) instead. */ .text .align 2 .globl _sc_itimes _sc_itimes: .word 0 mull3 8(ap),4(ap),r0 bvs sc_itimes_overflow ret sc_itimes_overflow: cvtld 4(ap),r0 ashl $-2,8(ap),r2 cvtld r2,r2 muld2 r2,r0 movd r0,-(sp) calls $2,_sc_makedoublefloat ret scheme2c-2012.10.14/ports/makefile000066400000000000000000000017071203736146400164550ustar00rootroot00000000000000# # This file is used to make the Scheme->C system for a specific processor # type. # # The Scheme->C system is initially compiled from the C sources by the # following: port: $(MAKE) -C scrt port $(MAKE) -C scsc port $(MAKE) -C test autotest # Install in system directories; use prefix=~ for private copy install: $(MAKE) -C scrt install $(MAKE) -C scsc install # $(MAKE) -C cdecl install # $(MAKE) -C xlib install # Clean out working files. clean: rm -f *.BAK *.CKP SC-TO-C* $(MAKE) -C scrt clean $(MAKE) -C scsc clean $(MAKE) -C test clean # Clean up C source files generated from Scheme source. clean-sc-to-c: $(MAKE) -C scrt clean-sc-to-c $(MAKE) -C scsc clean-sc-to-c $(MAKE) -C test clean-sc-to-c # Delete programs and libraries. noprogs: $(MAKE) -C scrt noprogs $(MAKE) -C scsc noprogs $(MAKE) -C test noprogs # All files which must be constructed are made by the following command: all: $(MAKE) -C scrt all $(MAKE) -C scsc all scheme2c-2012.10.14/scrt/000077500000000000000000000000001203736146400145545ustar00rootroot00000000000000scheme2c-2012.10.14/scrt/README000066400000000000000000000001131203736146400154270ustar00rootroot00000000000000This directory contains the shared files for the SCHEME->C runtime system. scheme2c-2012.10.14/scrt/apply.c000066400000000000000000002014341203736146400160510ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module defines the APPLY and UNKNOWNCALL functions. APPLY is as defined in Revised**3 and UNKNOWNCALL is a variant of APPLY which is used by the compiler to call unknown functions. */ /* External declarations */ #include "objects.h" #include "scinit.h" #include "heap.h" #include "apply.h" #include /* Data structures used by UNKNOWNCALL. These values must be pushed on the stack and then restored by interrupt handlers or when calling finalization procedures. */ TSCP sc_unknownproc[ 4 ]; /* Procedure pointers */ S2CINT sc_unknownargc; /* Procedure argument count */ TSCP sc_arg[MAXARGS]; /* Array for the required arguments */ /* Used by sc_apply_2dtwo to copy the optional argument list. */ static TSCP copy_list( l ) TSCP l; { TSCP tail; if (TSCPTAG( l ) == PAIRTAG) { tail = copy_list( PAIR_CDR( l ) ); if (tail == FALSEVALUE) return( tail ); return( sc_cons( PAIR_CAR( l ), tail ) ); } if (l == EMPTYLIST) return( l ); return( FALSEVALUE ); } /* APPLY as defined in Revised**3. It expects a procedure and an argument list. It returns the result of applying that procedure to the arguments. */ TSCP sc_apply_2dtwo( proc, argl ) TSCP proc, argl; { int i; int req; /* # of required arguments */ int opt; /* true iff required arguments */ TSCP arg[MAXARGS]; /* argument array */ TSCP optl; /* optional argument list */ TSCP closure; /* closure pointer */ SCP utproc; /* untagged version of tproc */ SCP utargl; utproc = T_U( proc ); if ((TSCPTAG( proc ) != EXTENDEDTAG) || (utproc->procedure.tag != PROCEDURETAG)) sc_error( "APPLY", "Argument is not a PROCEDURE: ~s", LIST1( proc ) ); req = utproc->procedure.required; opt = utproc->procedure.optional; i = 0; while ((i < req) && (TSCPTAG( argl ) == PAIRTAG)) { utargl = T_U( argl ); arg[ i++ ] = utargl->pair.car; argl = utargl->pair.cdr; } if (i < req) sc_error( "APPLY", "PROCEDURE requires ~s arguments, ~s supplied", LIST2( C_FIXED( req ), C_FIXED( i ) ) ); if (opt) { optl = copy_list( argl ); if (optl == FALSEVALUE) sc_error( "APPLY", "Argument list is not a LIST: ~s", LIST1( argl ) ); argl = optl; closure = utproc->procedure.closure; } else { if (argl != EMPTYLIST) sc_error( "APPLY", "PROCEDURE accepts only ~s arguments", LIST1( C_FIXED( req ) ) ); argl = utproc->procedure.closure; } switch (req) { case 0: return( (*utproc->procedure.code) ( argl, closure ) ); case 1: return( (*utproc->procedure.code) ( arg[0], argl, closure ) ); case 2: return( (*utproc->procedure.code) ( arg[0], arg[1], argl, closure ) ); case 3: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], argl, closure ) ); case 4: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], argl, closure )); case 5: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], argl, closure ) ); case 6: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], argl, closure ) ); case 7: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], argl, closure ) ); case 8: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], argl, closure ) ); case 9: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], argl, closure ) ); case 10: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], argl, closure ) ); case 11: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], argl, closure ) ); case 12: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], argl, closure ) ); case 13: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], argl, closure ) ); case 14: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], argl, closure ) ); case 15: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], argl, closure ) ); case 16: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], argl, closure ) ); #if (MAXARGS >= 17) case 17: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], argl, closure ) ); #endif #if (MAXARGS >= 18) case 18: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], argl, closure ) ); #endif #if (MAXARGS >= 19) case 19: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], argl, closure ) ); #endif #if (MAXARGS >= 20) case 20: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], argl, closure ) ); #endif #if (MAXARGS >= 21) case 21: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], argl, closure ) ); #endif #if (MAXARGS >= 22) case 22: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], argl, closure ) ); #endif #if (MAXARGS >= 23) case 23: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], argl, closure ) ); #endif #if (MAXARGS >= 24) case 24: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], argl, closure ) ); #endif #if (MAXARGS >= 25) case 25: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], argl, closure ) ); #endif #if (MAXARGS >= 26) case 26: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], argl, closure ) ); #endif #if (MAXARGS >= 27) case 27: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], argl, closure ) ); #endif #if (MAXARGS >= 28) case 28: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], argl, closure ) ); #endif #if (MAXARGS >= 29) case 29: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], argl, closure ) ); #endif #if (MAXARGS >= 30) case 30: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], argl, closure ) ); #endif #if (MAXARGS >= 31) case 31: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], argl, closure ) ); #endif #if (MAXARGS >= 32) case 32: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], argl, closure ) ); #endif #if (MAXARGS >= 33) case 33: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], argl, closure ) ); #endif #if (MAXARGS >= 34) case 34: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], argl, closure ) ); #endif #if (MAXARGS >= 35) case 35: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], argl, closure ) ); #endif #if (MAXARGS >= 36) case 36: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], argl, closure ) ); #endif #if (MAXARGS >= 37) case 37: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], argl, closure ) ); #endif #if (MAXARGS >= 38) case 38: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], argl, closure ) ); #endif #if (MAXARGS >= 39) case 39: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], argl, closure ) ); #endif #if (MAXARGS >= 40) case 40: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], argl, closure ) ); #endif #if (MAXARGS >= 41) case 41: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], argl, closure ) ); #endif #if (MAXARGS >= 42) case 42: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], argl, closure ) ); #endif #if (MAXARGS >= 43) case 43: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], arg[42], argl, closure ) ); #endif #if (MAXARGS >= 44) case 44: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], arg[42], arg[43], argl, closure ) ); #endif #if (MAXARGS >= 45) case 45: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], arg[42], arg[43], arg[44], argl, closure ) ); #endif #if (MAXARGS >= 46) case 46: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], arg[42], arg[43], arg[44], arg[45], argl, closure ) ); #endif #if (MAXARGS >= 47) case 47: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], arg[42], arg[43], arg[44], arg[45], arg[46], argl, closure ) ); #endif #if (MAXARGS >= 48) case 48: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], arg[42], arg[43], arg[44], arg[45], arg[46], arg[47], argl, closure ) ); #endif #if (MAXARGS >= 49) case 49: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], arg[42], arg[43], arg[44], arg[45], arg[46], arg[47], arg[48], argl, closure ) ); #endif #if (MAXARGS >= 50) case 50: return( (*utproc->procedure.code) ( arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13], arg[14], arg[15], arg[16], arg[17], arg[18], arg[19], arg[20], arg[21], arg[22], arg[23], arg[24], arg[25], arg[26], arg[27], arg[28], arg[29], arg[30], arg[31], arg[32], arg[33], arg[34], arg[35], arg[36], arg[37], arg[38], arg[39], arg[40], arg[41], arg[42], arg[43], arg[44], arg[45], arg[46], arg[47], arg[48], arg[49], argl, closure ) ); #endif } } /* UNKNOWNCALL is a variant of apply where the function's arguments are are passed as arguments to the function. Before the call, the procedure pointer is placed in SC_UNKNOWNPROC[ 1 ], and the argument count is placed in SC_UNKNOWNARGC. This procedure is only entered, when there is an error in the call, or the procedure takes a variable number of arguments. */ /* Qobi h15jan2005, f22aug2008 */ TSCP sc_unknowncall( TSCP firstarg, ... ) { va_list argl; /* List of arguments on stack */ int req; /* # of required arguments */ int i; /* Loop index */ TSCP optl; /* Optional argument list */ TSCP tail; /* Tail of optional argument list */ SCP utproc; /* Untagged version of proc */ int argp = 0; va_start( argl, firstarg ); utproc = T_U( sc_unknownproc[ 1 ] ); if ((TSCPTAG( sc_unknownproc[ 1 ] ) != EXTENDEDTAG) || (utproc->procedure.tag != PROCEDURETAG)) sc_error( "APPLY", "Argument is not a PROCEDURE: ~s", LIST1( sc_unknownproc[ 1 ] ) ); req = utproc->procedure.required; if ((sc_unknownargc < req) || ((utproc->procedure.optional == 0) && (sc_unknownargc != req))) sc_error( "APPLY", "PROCEDURE requires ~s arguments, ~s supplied", LIST2( C_FIXED( req ), C_FIXED( sc_unknownargc ) ) ); for (i = 0; i < req; i++) sc_arg[ i ] = ((argp==1)?va_arg( argl, TSCP ):(argp = 1, firstarg)); optl = EMPTYLIST; if (i++ < sc_unknownargc) { tail = (optl = sc_cons( ((argp==1)?va_arg( argl, TSCP ):(argp = 1, firstarg)), EMPTYLIST )); while (i++ < sc_unknownargc) tail = (TP_U( tail )->pair.cdr = sc_cons( ((argp==1)?va_arg( argl, TSCP ):(argp = 1, firstarg)), EMPTYLIST )); } switch (req) { case 0: return( (*utproc->procedure.code) ( optl, utproc->procedure.closure ) ); case 1: return( (*utproc->procedure.code) ( sc_arg[0], optl, utproc->procedure.closure ) ); case 2: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], optl, utproc->procedure.closure ) ); case 3: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], optl, utproc->procedure.closure ) ); case 4: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], optl, utproc->procedure.closure )); case 5: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], optl, utproc->procedure.closure ) ); case 6: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], optl, utproc->procedure.closure ) ); case 7: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], optl, utproc->procedure.closure ) ); case 8: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], optl, utproc->procedure.closure ) ); case 9: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], optl, utproc->procedure.closure ) ); case 10: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], optl, utproc->procedure.closure ) ); case 11: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], optl, utproc->procedure.closure ) ); case 12: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], optl, utproc->procedure.closure ) ); case 13: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], optl, utproc->procedure.closure ) ); case 14: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], optl, utproc->procedure.closure ) ); case 15: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], optl, utproc->procedure.closure ) ); case 16: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], optl, utproc->procedure.closure ) ); #if (MAXARGS >= 17) case 17: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 18) case 18: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 19) case 19: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 20) case 20: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 21) case 21: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 22) case 22: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 23) case 23: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 24) case 24: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 25) case 25: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 26) case 26: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 27) case 27: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 28) case 28: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 29) case 29: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 30) case 30: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 31) case 31: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 32) case 32: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 33) case 33: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 34) case 34: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 35) case 35: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 36) case 36: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 37) case 37: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 38) case 38: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 39) case 39: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 40) case 40: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 41) case 41: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 42) case 42: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 43) case 43: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 44) case 44: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 45) case 45: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 46) case 46: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 47) case 47: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 48) case 48: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 49) case 49: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 50) case 50: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 51) case 51: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 52) case 52: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 53) case 53: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 54) case 54: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 55) case 55: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 56) case 56: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 57) case 57: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 58) case 58: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 59) case 59: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 60) case 60: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 61) case 61: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 62) case 62: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 63) case 63: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], sc_arg[62], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 64) case 64: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], sc_arg[62], sc_arg[63], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 65) case 65: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], sc_arg[62], sc_arg[63], sc_arg[64], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 66) case 66: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], sc_arg[62], sc_arg[63], sc_arg[64], sc_arg[65], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 67) case 67: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], sc_arg[62], sc_arg[63], sc_arg[64], sc_arg[65], sc_arg[66], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 68) case 68: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], sc_arg[62], sc_arg[63], sc_arg[64], sc_arg[65], sc_arg[66], sc_arg[67], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 69) case 69: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], sc_arg[62], sc_arg[63], sc_arg[64], sc_arg[65], sc_arg[66], sc_arg[67], sc_arg[68], optl, utproc->procedure.closure ) ); #endif #if (MAXARGS >= 70) case 70: return( (*utproc->procedure.code) ( sc_arg[0], sc_arg[1], sc_arg[2], sc_arg[3], sc_arg[4], sc_arg[5], sc_arg[6], sc_arg[7], sc_arg[8], sc_arg[9], sc_arg[10], sc_arg[11], sc_arg[12], sc_arg[13], sc_arg[14], sc_arg[15], sc_arg[16], sc_arg[17], sc_arg[18], sc_arg[19], sc_arg[20], sc_arg[21], sc_arg[22], sc_arg[23], sc_arg[24], sc_arg[25], sc_arg[26], sc_arg[27], sc_arg[28], sc_arg[29], sc_arg[30], sc_arg[31], sc_arg[32], sc_arg[33], sc_arg[34], sc_arg[35], sc_arg[36], sc_arg[37], sc_arg[38], sc_arg[39], sc_arg[40], sc_arg[41], sc_arg[42], sc_arg[43], sc_arg[44], sc_arg[45], sc_arg[46], sc_arg[47], sc_arg[48], sc_arg[49], sc_arg[50], sc_arg[51], sc_arg[52], sc_arg[53], sc_arg[54], sc_arg[55], sc_arg[56], sc_arg[57], sc_arg[58], sc_arg[59], sc_arg[60], sc_arg[61], sc_arg[62], sc_arg[63], sc_arg[64], sc_arg[65], sc_arg[66], sc_arg[67], sc_arg[68], sc_arg[69], optl, utproc->procedure.closure ) ); #endif } } scheme2c-2012.10.14/scrt/apply.h000066400000000000000000000041671203736146400160620ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module defines the APPLY and UNKNOWNCALL functions. APPLY is as defined in Revised**3 and UNKNOWNCALL is a variant of APPLY which is used by the compiler to call unknown functions. */ #define MAXARGS 70 /* 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. */ /* I changed this from 25 to 30 -- Qobi M19Aug96 */ /* I changed this from 30 to 40 -- Qobi T25Aug98 */ /* I changed this from 40 to 50 -- Qobi H7Nov98 */ /* I changed this from 50 to 70 -- Qobi F22Aug08 */ extern S2CINT sc_unknownargc; /* Data structures for sc_unknowncall */ extern TSCP sc_unknownproc[ 4 ]; extern TSCP sc_arg[MAXARGS]; /* The procedural interfaces in this module are: */ extern TSCP sc_apply_2dtwo(); extern TSCP sc_unknowncall(TSCP va_alist, ...); /* Qobi h15jan2005 */ scheme2c-2012.10.14/scrt/c.sc000066400000000000000000000022211203736146400153220ustar00rootroot00000000000000;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. scheme2c-2012.10.14/scrt/callcc.c000066400000000000000000000170511203736146400161450ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* The following procedures implement CALL-WITH-CURRENT-CONTINUATION. CALLCCCONTINUING is the function that is executed when a continuation is applied. It is called with the result to be returned and the procedure's closure which is the continuation created by the initial call to TSC_CALLWITHCURRENTCONTINUATION. It will unwind the stack until the right return point is found. If it is not found, then it will restore the stack from the continuation(s). Once the stack is known to have the right contents, it will restore the correct state with longjmp. */ /* External declarations */ #include "objects.h" #include "scinit.h" #include "heap.h" #include "callcc.h" #include "apply.h" #include "cio.h" #ifdef AOSF #define LONGJMP( x, y ) sc_longjmp( x, y ) #define SETJMP( x ) sc_setjmp( x ) extern long int sc_longjmp( long int* context, long int result ); extern long int sc_setjmp( long int* context ); #endif #if defined(__hpux) || defined(LINUX) || defined(MAC) || defined(MIPS) \ || defined(FREEBSD) || defined(AMD64) || defined(LINUX_ARM) || defined(OPENBSD) #define LONGJMP( x, y ) longjmp( x, y ) #define SETJMP( x ) setjmp( x ) #endif #ifdef MIPS extern sc_setsp(); #endif #ifdef SPARC extern int sc_setjmp( XAL1(int *) ); extern void sc_longjmp( XAL2(int *, int) ); /* The SPARC compilers need a special #pragma for setjmp-like functions, but * some compilers generate error messages upon seeing such a directive. * Hence this kludge. */ #include "sparc-pragma.h" #endif #if defined(VAX) || defined(SPARC) #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 variables may be static as they are only used under MUTEX. However, they may not hold there values across sections that aren't mutexed! */ static TSCP callccresult, /* Passes result across longjmp. */ callcccp; /* Preserves cp during stack rebuilding. */ static S2CINT *fp, /* Temps for constructing continuation */ *tp, *tos, rcount, bcount, count; static char *bfp, *btp, *btos; #ifdef STACK_GROWS_POSITIVE #define STACK_BYTES(base, sp) (((S2CUINT) (sp)) - ((S2CUINT) (base))) #define POSTINC_SP(sp) (sp)-- #else #define STACK_BYTES(base, sp) (((S2CUINT) (base)) - ((S2CUINT) (sp))) #define POSTINC_SP(sp) (sp)++ #endif #define COPY_STACK() \ { \ if (sc_clink == EMPTYLIST) { \ sc_clink = callcccp; \ while (sc_clink != EMPTYLIST) { \ btp = (T_U(sc_clink))->continuation.address; \ bfp = (char*)(&(T_U(sc_clink))->continuation.word0+ \ sc_maxdisplay); \ bcount = (T_U(sc_clink))->continuation.stackbytes; \ while (bcount--) *POSTINC_SP(btp) = *bfp++; \ sc_clink = (T_U(sc_clink))->continuation.continuation; \ } \ } \ } static TSCP callcccontinuing( result, cp ) TSCP result, cp; { MUTEXON; callccresult = result; callcccp = cp; /* Unwind CLINK to see if this continuation is currently on the stack. */ while (sc_clink != EMPTYLIST) { if (sc_clink == cp) LONGJMP( (T_U(cp))->continuation.savedstate, 1 ); sc_clink = (T_U(sc_clink))->continuation.continuation; } /* Continuation is not currently on the stack, so transfer to it and it will restore the stack. Some implementations require the stack pointer to be reset before this can be done. */ #ifdef MIPS sc_setsp( (T_U(callcccp))->continuation.address ); #ifdef COPY_STACK_BEFORE_LONGJMP COPY_STACK (); #endif #endif LONGJMP( (T_U(callcccp))->continuation.savedstate, 1 ); } TSCP sc_ntinuation_1af38b9f_v; TSCP sc_callcc( function ) TSCP function; { SCP cp; /* Pointer to the continuation */ S2CINT *save_fp; /* Save static values across heap allocate */ CHECK_TS; MUTEXON; if (sc_clink == EMPTYLIST) bfp = (char*)sc_stackbase; else bfp = (T_U(sc_clink))->continuation.address; STACKPTR( tos ); count = (((STACK_BYTES (bfp, tos)) + ((sizeof (S2CINT)) - 1)) / (sizeof (S2CINT))); #ifdef LAZY_STACK_POP /* NOTE WELL! * For machines that must pop arguments after a function call, * the compiler may let arguments accumulate on the stack for several * function calls and pop them all at once. * If your compiler uses this optimization, 'count' must be incremented * by the number of S2CINTs pushed as arguments between this point and * the point where 'bcount' is computed. */ count += LAZY_STACK_INCREMENT; #endif save_fp = (S2CINT*)bfp; cp = sc_allocateheap( NULLCONTINUATIONSIZE+count+2+sc_maxdisplay, CONTINUATIONTAG, NULLCONTINUATIONSIZE+count+sc_maxdisplay ); STACKPTR( tos ); fp = save_fp; bcount = (STACK_BYTES (fp, tos)); if (bcount > count*sizeof(S2CINT)) /* If you get this error, look above at LAZY_STACK_POP */ sc_error( "CALL-WITH-CURRENT-CONTINUATION", "internal error: want to write ~s bytes of stack, " "but only ~s bytes allocated.", LIST2( C_FIXED( bcount ), C_FIXED( count*sizeof(S2CINT) ) ) ); cp->continuation.continuation = sc_clink; cp->continuation.stackbytes = bcount; cp->continuation.stacktrace = sc_stacktrace; sc_clink = U_TX( cp ); btos = (char*)tos; cp->continuation.address = btos; tp = &cp->continuation.word0; rcount = sc_maxdisplay; while (rcount--) *tp++ = (S2CINT)sc_display[ rcount ]; btp = (char*)tp; while (bcount--) *btp++ = *POSTINC_SP(btos); MUTEXOFF; if (SETJMP( cp->continuation.savedstate ) == 0) { callccresult = sc_apply_2dtwo( function, sc_cons( sc_makeprocedure( 1, 0, callcccontinuing, U_TX( cp ) ), EMPTYLIST ) ); sc_clink = T_U( sc_clink )->continuation.continuation; return( callccresult ); } /* Return here when the continuation is invoked. */ #ifndef COPY_STACK_BEFORE_LONGJMP COPY_STACK (); #endif if (sc_savetopofstack != 0) { sc_topofstack = sc_savetopofstack; sc_savetopofstack = 0; } tp = &T_U( callcccp )->continuation.word0; rcount = sc_maxdisplay; while (rcount--) sc_display[ rcount ] = (TSCP)(*tp++); sc_clink = T_U( callcccp )->continuation.continuation; sc_stacktrace = T_U( callcccp )->continuation.stacktrace; /* Move result onto the stack under mutex */ function = callccresult; MUTEXOFF; return( function ); } scheme2c-2012.10.14/scrt/callcc.h000066400000000000000000000027021203736146400161470ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module implements CALL-WITH-CURRENT-CONTINUATION. SC_CLINK is a pointer to the current "inner most" continuation on the stack. */ extern TSCP sc_clink; /* Procedural interfaces in this module: */ extern TSCP sc_ntinuation_1af38b9f_v; extern TSCP sc_callcc(); scheme2c-2012.10.14/scrt/cio.c000066400000000000000000000660631203736146400155050ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module supplies functions to access the system dependent facilities. */ #include "objects.h" #include "heap.h" #include "cio.h" #include "scinit.h" #undef TRUE #undef FALSE #ifdef SUNOS4 extern long _sysconf(int); /* System Private interface to sysconf() */ #define CLK_TCK ((clock_t) _sysconf(3)) /* clock ticks per second */ /* 3 is _SC_CLK_TCK */ #endif #ifdef MAC #include #else #include #if defined(LINUX) || defined(AMD64) || defined(LINUX_ARM) || defined(OPENBSD) #include #include #include #endif #endif #if STACK_OVERFLOW #include #if HAVE_STACK_OVERFLOW_RECOVERY && HAVE_SIGSEGV_RECOVERY #include #include char overflow_stack[16384]; void stackoverflow_handler(int emergency, stackoverflow_context_t scp) { printf("***** Stack overflow!\n"); printf("***** Now we're going to see if we can print a backtrace, good luck!\n"); sc_stackoverflow(); abort(); } int sigsegv_handler(void* address, int emergency) { // this tells libsigsegv that this is a stack overflow if(!emergency) return 0; printf("***** Segfault -- Please tell the scheme->c maintainers!\n"); printf("***** Now we're going to try to print out a bracktrace, good luck!\n"); char *procname = "SIGSEGV"; if (sc_stacktrace != NULL) procname = sc_stacktrace->procname; sc_error( procname, "Segfault:", EMPTYLIST ); abort(); } #else #error "Stack overflow is enabled for this architecture but you are either missing libsigsegv or do not have stack overflow and sigsegv recovery built in" #endif #endif #include #ifdef VAX extern double strtod(); extern void abort(); extern void exit(); extern char* malloc(); extern void free(); extern char* getenv(); extern int system(); extern int unlink(); static int remove( c ) char *c; { return( unlink( c ) ); } #else #include #ifdef SUNOS4 extern double strtod( XAL2(char*, char**) ); #endif #endif #ifdef MAC #include #else #include #include #ifdef __hpux #include #else #if !defined(LINUX) && !defined(AMD64) && !defined(LINUX_ARM) && !defined(OPENBSD) extern char *sbrk(); #endif extern int select ( XAL5( int, fd_set *, fd_set *, fd_set *, struct timeval * ) ); #endif #include #if S2CSIGNALS #include #ifdef __hp9000s800 /* HP-UX defines macro with conflicting name: */ #undef sc_error #endif #endif /* Jump through some hoops to decide which time function to use for unix. Most portable is times(), which is available on virtually every flavor of unix, including BSD, SYSV, and POSIX. getrusage() is preferable when available, due to its (likely) higher resolution, but is a BSD feature that is not as portable. Unfortunately there's no automatic way to conditionalize for rusage; I had thought to use RUSAGE_SELF, but that is defined by HP-UX header file even though getrusage() isn't implemented. */ #if defined(AOSF) || defined(FREEBSD) || defined(VAX) || defined(SUNOS4) #define HAVE_RUSAGE #endif #ifdef MIPS #ifndef SYSV #define HAVE_RUSAGE #endif #endif #ifdef SYSV #define HAVE_TIMES #else #ifdef POSIX #define HAVE_TIMES #endif #endif #ifdef HAVE_RUSAGE #include #else #ifdef HAVE_TIMES #include #ifndef CLK_TCK #define CLK_TCK CLOCKS_PER_SEC #endif #endif #endif #if defined(VAX) || defined(SUNOS4) extern int sys_nerr; extern char *sys_errlist[]; static char* strerror( e ) int e; { if (e < sys_nerr) return( sys_errlist[ e ] ); else return( "" ); } #else extern char* strerror( XAL1( int ) ); #endif #endif extern TSCP scrt4_callsignalhandler( XAL1( TSCP ) ); /* The MACSCI flag is used in conjunction with the MAC flag to produce a usable (but crude) interactive interface to Scheme->C. The flag may be defined in either this module or options.h. */ #ifdef MACSCI #include static struct { int keyinx; /* Index to enter characters into buffer */ int keyoutx; /* Index to read characters from buffer */ int rawcnt; /* # raw characters in buffer */ int processedcnt; /* # of processed characters in buffer */ char buffer[ 512 ]; } keys; static TSCP SIGINT_handler = C_FIXED( (S2CINT)SIG_DFL ); #define INCKEYX( keyx, i ) keyx = (keyx+i) & 511 #define CONTROL_D ('d' & 037) #define BACKSPACE ('h' & 037) #define CONTROL_C ('c' & 037) #define APPLE_PERIOD ('.' & 037) #define CONTROL_U ('u' & 037) #define RETURN (015) #define S2CSTACK 57000 #define S2CTIMESLICE 10000 /* Main program to set the Application stack limit, the Scheme stack size and time slice, and then invoke the read-eval-print loop. */ main() { S2CINT *sp; STACKPTR( sp ); SetApplLimit( (char*)sp-S2CSTACK ); console_options.nrows = 30; console_options.title = "\pScheme->C"; csetmode( C_RAW, stdin ); INITHEAP( 0, 0, NULL, NULL ); sc_set_2dstack_2dsize_21( C_FIXED( ((S2CUINT)S2CSTACK)-3000 ) ); sc_set_2dtime_2dslice_21( C_FIXED( (S2CUINT)S2CTIMESLICE ) ); screp__init(); screp_read_2deval_2dprint( EMPTYLIST ); SCHEMEEXIT(); } #endif /* Standard I/O FILE pointers for stand-alone or interactive applications. */ TSCP sc_stdin_v, sc_stdout_v, sc_stderr_v; void sc_setstdio() { #ifdef stdin sc_stdin_v = POINTER_TSCP( stdin ); CONSTANTEXP( &sc_stdin_v ); sc_stdout_v = POINTER_TSCP( stdout ); CONSTANTEXP( &sc_stdout_v ); sc_stderr_v = POINTER_TSCP( stderr ); CONSTANTEXP( &sc_stderr_v ); #endif } /* Called to open a file with a file name and access option ("r" or "w"). It returns either a "file-number", or #F indicating it was unable to open the file. */ TSCP sc_fopen( TSCP filename, TSCP option ) { FILE* f; f = fopen( (char*)&STRING_CHAR( filename, 0 ), (char*)&STRING_CHAR( option, 0 ) ); if (f == NULL) return( CSTRING_TSCP( strerror( errno ) ) ); else return( POINTER_TSCP( f ) ); } /* Closes a file with the "file-number". */ TSCP sc_fclose( TSCP file ) { fclose( (FILE*)TSCP_POINTER( file ) ); return( FALSEVALUE ); } /* Flushes any OS supplied buffers associated with the "file-number". */ TSCP sc_fflush( TSCP file ) { fflush( (FILE*)TSCP_POINTER( file ) ); return( FALSEVALUE ); } /* Returns the next character from a file, the end-of-file object, or a string on an error. */ TSCP sc_fgetc( TSCP file ) { FILE* stream; int character; stream = (FILE*)TSCP_POINTER( file ); #ifdef MACSCI if (stream == stdin) { if (keys.processedcnt == 0) { sc_stoptimer( &sc_usertime ); while (keys.processedcnt == 0) sc_timesliced(); sc_stoptimer( &sc_idletime ); } keys.processedcnt--; character = keys.buffer[ keys.keyoutx ]; INCKEYX( keys.keyoutx, 1 ); if (character == CONTROL_D) return( EOFOBJECT ); else return( C_CHAR( character ) ); } #endif character = getc( stream ); if (character == EOF) { if (feof( stream )) { clearerr( stream ); return( EOFOBJECT ); } else return( CSTRING_TSCP( strerror( ferror( stream ) ) ) ); } return( C_CHAR( character ) ); } /* Places the next character into a file. Returns #F on success, or an error string on failure. */ TSCP sc_fputc( TSCP character, TSCP file ) { FILE* stream; int error; stream = (FILE*)TSCP_POINTER( file ); error = fputc( CHAR_C( character ), stream ); if (error == EOF) { return( CSTRING_TSCP( strerror( ferror( stream ) ) ) ); } return( FALSEVALUE ); } /* Returns the operating system's file number for a stream. */ TSCP sc_fileno( TSCP file ) { return( C_FIXED( fileno( (FILE*)TSCP_POINTER( file ) ) ) ); } /* Returns a bit mask indicating which files have input available. If this function is not available, or a signal occurs, a 0 is returned. System specific I/O errors are handled here. */ TSCP sc_inputready( TSCP mask ) { #ifdef MAC return( S2CUINT_TSCP( 0 ) ); #else S2CUINT filemask; fd_set readfds; int i = 0, ioerror; FD_ZERO( &readfds ); filemask = TSCP_S2CUINT( mask ); while (filemask != 0) { if (filemask & 1) { FD_SET( i, &readfds ); } i = i+1; filemask = filemask>>1; } ioerror = select( i, &readfds, NULL, NULL, NULL ); if (ioerror == -1) { if (errno == EINTR) return( C_FIXED( 0 ) ); sc_error( "INPUTREADY", "select error: ~s", LIST1( CSTRING_TSCP( strerror( errno ) ) ) ); } filemask = 0; while (--i >= 0) { if (FD_ISSET( i, &readfds )) { filemask = filemask | 1<cnt) return( TRUEVALUE ); else return( FALSEVALUE ); #else FILE* stream; fd_set readfds; int nfound; struct timeval timeout; stream = (FILE*)TSCP_POINTER( file ); #if defined(LINUX) || defined(AMD64) || defined(LINUX_ARM) if (((stream)->_IO_read_end) <= ((stream)->_IO_read_ptr) ) { #elif defined(FREEBSD) || defined(OPENBSD) if (((stream)->_r) <= 0) { #else if (((stream)->_cnt) <= 0) { #endif FD_ZERO( &readfds ); FD_SET( fileno( stream ), &readfds ); timeout.tv_sec = 0; timeout.tv_usec = 0; nfound = select( fileno( stream )+1, &readfds, 0, 0, &timeout ); if (nfound == 0) return( FALSEVALUE ); } return( TRUEVALUE ); #endif } /* Remove a file. Return #F on success, the operating system dependent error on an error. */ TSCP sc_removefile( TSCP filename ) { if (remove( (char*)&STRING_CHAR( filename, 0 ) ) == 0) return( FALSEVALUE ); else return( CSTRING_TSCP( strerror( errno ) ) ); } /* Rename a file. Return #F on success, or an error message on failure. */ extern TSCP sc_rename( TSCP old, TSCP new ) { if (rename( (char*)&STRING_CHAR( old, 0 ), (char*)&STRING_CHAR( new, 0 ) ) == 0) return( FALSEVALUE ); else return( CSTRING_TSCP( strerror( errno ) ) ); } /* Number to string conversion is done in a system dependent way by the following routine. */ TSCP sc_formatnumber( TSCP number, TSCP type, TSCP length ) { char buffer[100], format[10]; switch FIXED_C( type ) { case 0: /* [-]dddddddd */ snprintf( buffer, sizeof(buffer), "%.0lf", TSCP_DOUBLE( number ) ); break; case 1: /* [-]dddddddd.dddd */ snprintf( format, sizeof(format), "%%.%lilf", (long)TSCP_S2CINT( length ) ); snprintf( buffer, sizeof(buffer), format, TSCP_DOUBLE( number ) ); break; case 2: /* [-]d.ddde+dd */ snprintf( format, sizeof(format), "%%.%lile", (long)TSCP_S2CINT( length )-1 ); snprintf( buffer, sizeof(buffer), format, TSCP_DOUBLE( number ) ); break; case 3: #if defined(MAC) || defined(LINUX) || defined(FREEBSD) || defined(LINUX_ARM) || defined(OPENBSD) snprintf( format, sizeof(format), "%%.%lilg", (long)TSCP_S2CINT( length ) ); snprintf( buffer, sizeof(buffer), format, TSCP_DOUBLE( number ) ); #else gcvt( TSCP_DOUBLE( number ), TSCP_S2CINT( length ), buffer ); #endif break; } return( CSTRING_TSCP( buffer ) ); } /* String to number conversion is done is a system dependent way by the following routine. It returns either the number or #f indicating an error. */ TSCP sc_readnumber( TSCP string, TSCP type ) { char *nptr, *eptr; double value; switch FIXED_C( type ) { case 0: /* Read a floating point number */ nptr = (char*)&STRING_CHAR( string, 0 ); value = strtod( nptr, &eptr ); if (nptr == eptr || *eptr != 0) return( FALSEVALUE ); else return( FLTV_FLT( value ) ); break; } return( FALSEVALUE ); } /* Look up the value of an environment variable. */ char* sc_getenv( char* name ) { return( getenv( name ) ); } /* Fatal error exit */ void sc_abort() { abort(); } /* Normal exit */ TSCP sc_osexit( TSCP code ) { exit( FIXED_C( code ) ); return NULL; } /* Return the time used by Scheme->C (in seconds). This is either the cpu time used by the process (when available), or a time based on the wall time. */ #ifdef MAC static clock_t clockbase; #endif double sc_cputime() { #ifdef MAC return( ((double)(clock()-clockbase))/CLOCKS_PER_SEC ); #else #ifdef HAVE_RUSAGE struct rusage ru; getrusage( RUSAGE_SELF, &ru ); return( ru.ru_utime.tv_sec+(ru.ru_utime.tv_usec/1000000.0)+ ru.ru_stime.tv_sec+(ru.ru_stime.tv_usec/1000000.0) ); #else #ifdef HAVE_TIMES struct tms buffer; (void) times (&buffer); #if defined(AMD64) || defined(LINUX) || defined(LINUX_ARM) return ((buffer.tms_utime) / CLOCKS_PER_SEC); #else return ((buffer.tms_utime) / CLK_TCK); #endif #endif #endif #endif } /* Log a string in a system dependent manner. */ void sc_log_string( char *s ) { fprintf( stderr, "%s", s ); } /* Log a decimal integer in a system dependent manner. */ void sc_log_dec( S2CINT d ) { char buffer[30]; snprintf( buffer, sizeof(buffer), "%ld", (long)d ); sc_log_string( buffer ); } /* Log a hex integer in a system dependent manner. */ void sc_log_hex( S2CUINT d ) { char buffer[30]; snprintf( buffer, sizeof(buffer), "%lx", (long unsigned)d ); sc_log_string( buffer ); } /* Last ditch error logger. This is used when a error occurs while trying to build the error message. */ TSCP sc_error_2ddisplay( TSCP item ) { char s[2]; switch TSCPTAG( item ) { case FIXNUMTAG: sc_log_dec( FIXED_C( item ) ); break; case EXTENDEDTAG: switch (TSCP_EXTENDEDTAG( item )) { case SYMBOLTAG: sc_log_string( (char*)&STRING_CHAR( SYMBOL_NAME( item ), 0 ) ); break; case STRINGTAG: sc_log_string( (char*)&STRING_CHAR( item, 0 ) ); break; default: sc_log_hex( (S2CUINT)item ); break; } break; case IMMEDIATETAG: if (TSCPIMMEDIATETAG( item ) == CHARACTERTAG) { s[ 0 ] = CHAR_C( item ); s[ 1 ] = 0; sc_log_string( s ); } else sc_log_hex( (S2CUINT)item ); break; case PAIRTAG: sc_log_hex( (S2CUINT)item ); break; } return( FALSEVALUE ); } /* Memory allocation */ #if defined(LINUX) || defined(AMD64) || defined(LINUX_ARM) /* added by Qobi F2Nov2001 */ int linux_mmap_hack = (0==1); int linux_getenv_hack = (0==1); /* (define-external (enable-linux-mmap-hack!) sc) */ TSCP sc__2dhack_21_6518f460( void ) { linux_mmap_hack = (0==0); return( FALSEVALUE ); } #endif /* The following procedure is called to allocate memory for the Scheme->C heap. Memory requests are filled by allocating one or more 64KB blocks of memory until the request is satisfied. When quit is true, the program will fail when space cannot be allcoated. On return from this procedure, the structure sc_heapblocks contains information about the blocks of memory allocated. */ struct HEAPBLOCKS sc_heapblocks; #define SIXTY4KB 0x10000L void sc_getheap( S2CINT bytes, S2CINT quit ) { VOIDP memp; #ifdef MAC memp = malloc( (size_t)(bytes+PAGEBYTES-1) ); if ((S2CINT)memp & (PAGEBYTES-1)) memp = (VOIDP)((char*)memp+(PAGEBYTES-((S2CINT)memp & (PAGEBYTES-1)))); #else #if defined(LINUX) || defined(AMD64) || defined(LINUX_ARM) /* changed by Qobi S10Jan99 and again R18Feb99 and again F19Feb99 and again R1Jun2000 and again F2Nov2001 */ if (!linux_getenv_hack) { linux_getenv_hack = (0==0); if (getenv("SCMMAP")!=NULL) linux_mmap_hack = (0==0);} if (linux_mmap_hack) { for (; bytes>0; bytes -= PAGEBYTES) /* This used to be 0x00000001. With that, under RH7.2 the maximum amount that can be allocated is about 2G. Because allocation starts around 0x40000000 and goes up to about 0xc0000000. If you set this to 0x00001000 then allocation starts at 0x00001000 and goes up to about 0xc0000000 giving about 3G maximum allocation. I have not been able to get any pages allocated above 0xc0000000 and thus have not been able to get more than 3G. For some reason, when this is 0x00001000 allocation starts below 0x40000000. But when it is 0x00000000, 0x00000001, or above 0x40000000, allocation starts at 0x40000000 and pages below that never get allocated. */ { memp = mmap((void *)0x00001000, (size_t)(bytes+PAGEBYTES-1), PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0); if ((S2CINT)memp!=-1) { if ((S2CINT)memp&(PAGEBYTES-1)) { memp = (VOIDP)((char*)memp+(PAGEBYTES-((S2CINT)memp&(PAGEBYTES-1))));} goto l;}} memp = NULL; l:;} else { #endif memp = sbrk( 0 ); if ((S2CINT)memp & (PAGEBYTES-1)) sbrk( (PAGEBYTES-(S2CINT)memp) & (PAGEBYTES-1) ); memp = sbrk( bytes ); if ((S2CINT)memp == -1) memp = NULL; #if defined(LINUX) || defined(AMD64) || defined(LINUX_ARM) } #endif #endif if (memp == NULL) { sc_heapblocks.count = 0; if (quit) { sc_log_string( "***** Memory allocation failed: " ); sc_log_dec( bytes ); sc_log_string( "\n" ); sc_abort(); } } else { if (sc_gcinfo > 1) { sc_log_string( "***** Memory " ); sc_log_hex( (S2CINT)memp ); sc_log_string( " " ); sc_log_hex( (S2CINT)memp+bytes-1 ); sc_log_string( "\n" ); } sc_heapblocks.count = 1; sc_heapblocks.block[ 0 ].address = memp; sc_heapblocks.block[ 0 ].size = bytes; sc_heapblocks.minphypage = ADDRESS_PHYPAGE( memp ); sc_heapblocks.maxphypage = ADDRESS_PHYPAGE( ((char*)memp)+bytes-1 ); } } /* Memory is allocated for the side tables by calling the following procedure with the number of bytes needed. A pointer to the space is returned. Errors occurring during initialization will cause the program to abort. Later errors will return NULL as the procedure's value. */ VOIDP sc_gettable( S2CINT bytes, S2CINT quit ) { VOIDP memp; memp = malloc( bytes ); if (memp == NULL) { if (quit) { sc_log_string( "***** Table allocation failed: malloc( " ); sc_log_dec( bytes ); sc_log_string( " )\n" ); sc_abort(); } } if (sc_gcinfo > 1) { sc_log_string( "***** Tables " ); sc_log_hex( (S2CINT)memp ); sc_log_string( " " ); sc_log_hex( (S2CINT)memp+bytes-1 ); sc_log_string( "\n" ); } return( memp ); } /* Memory in the side tables is returned by calling the following procedure. Note that one may attempt to free NULL. */ void sc_freetable( VOIDP any ) { if (any != NULL) free( any ); } /* Execute the operating system dependent system command and return the result. */ TSCP sc_ossystem( TSCP command ) { #ifdef MAC return( FALSEVALUE ); #else return( S2CINT_TSCP( system( (char*)&STRING_CHAR( command, 0 ) ) ) ); #endif } /* Unix-like signal handling is done here. */ #if S2CSIGNALS #ifdef POSIX /* For POSIX.1 systems, use `sigaction' instead of `signal', because `signal' has losing SYSV semantics with unavoidable interrupt window. */ typedef sigset_t SIGSET_T; void sc_segv__handlers() { #if STACK_OVERFLOW stackoverflow_install_handler(&stackoverflow_handler, overflow_stack, sizeof (overflow_stack)); sigsegv_install_handler(&sigsegv_handler); #endif } static VOIDP ossignal( int sig, VOIDP handler ) { struct sigaction new_action, old_action; (new_action.sa_handler) = handler; sigemptyset (& (new_action.sa_mask)); (new_action.sa_flags) = 0; sigaction (sig, (&new_action), (&old_action)); sc_segv__handlers(); return (old_action.sa_handler); } static void block_all_signals( SIGSET_T * old_mask ) { SIGSET_T new_mask; sigfillset( &new_mask ); sigprocmask( SIG_BLOCK, (&new_mask), old_mask ); } static void restore_signal_mask( SIGSET_T * old_mask ) { sigprocmask( SIG_SETMASK, old_mask, ((SIGSET_T *) 0) ); } #else /* Not a POSIX system so fake it. */ typedef S2CINT SIGSET_T; #define ossignal signal static void block_all_signals( SIGSET_T * old_mask ) { #ifndef MAC (*old_mask) = (sigsetmask( 0xffffffff )); #endif } static void restore_signal_mask( SIGSET_T * old_mask ) { #ifndef MAC sigsetmask( *old_mask ); #endif } #endif #endif #ifndef SUNOS4 #define SIGFIRST 0 #else #define SIGFIRST 1 #endif #ifdef SPARC /* These definitions don't quite cover the range of signals in * SunOS5.x -- SIGWAITING and SIGLWP cannot be handled. * Some other time, perhaps. */ #define SIGLAST 31 #define SIGAFTERGC 0 /* Used by Scheme->C */ #else #define SIGAFTERGC 31 /* Used by Scheme->C */ #endif S2CINT sc_mutex = 0; /* Mutual exclusion flag */ S2CINT sc_pendingsignals = 0; /* pending signal mask */ #if S2CSIGNALS static void signal_handler( int sig ) { SIGSET_T oldmask; block_all_signals (&oldmask); sc_pendingsignals = sc_pendingsignals | 1<procname; sc_error( procname, "OVERFLOWED a ~s byte stack", LIST1( C_FIXED( sc_stackbytes ) ) ); } /* The following procedure is called on the expiration of the time slice. */ void sc_timesliced() { #ifdef MACSCI int c; #endif if (sc_freed != EMPTYLIST) { sc_timeslice = collectdonetimeslice; sc_apply_when_unreferenced(); } #ifdef MACSCI sc_timeslice = sc_timesliceinit; c = getchar(); if (c != EOF) { if (c == CONTROL_C || c == APPLE_PERIOD) { /* Keyboard interrupt so flush input and trap */ keys.rawcnt = keys.processedcnt = keys.keyinx = keys.keyoutx = 0; scrt4_callsignalhandler( C_FIXED( 2 ) ); return; } else if (c == BACKSPACE) { /* Backspace deletes the last character */ if (keys.rawcnt) { keys.rawcnt--; INCKEYX( keys.keyinx, -1 ); fputc( c, stdout ); ccleol( stdout ); } } else if (c == CONTROL_U) { /* Control-u deletes the line */ while (keys.rawcnt) { keys.rawcnt--; INCKEYX( keys.keyinx, -1 ); fputc( BACKSPACE, stdout ); } ccleol( stdout ); } else { /* Otherwise add character to the buffer */ keys.rawcnt++; keys.buffer[ keys.keyinx ] = c; INCKEYX( keys.keyinx, 1 ); fputc( c, stdout ); if (c == RETURN || c == CONTROL_D) { /* Make line available to Scheme */ if (c == RETURN) fputs( "\n", stdout ); if (c == CONTROL_D) fputs( "^D", stdout ); keys.processedcnt = keys.processedcnt+keys.rawcnt; keys.rawcnt = 0; } } } return; #endif sc_timeslice = MAXS2CINT; scdebug_timeout(); } /* The following procedure is called on procedure entry to set the stack link, check the stack height, and check the time slice when COMPACTPUSHTRACE is 1. */ void sc_pushstacktrace( struct STACKTRACE *st, char *procname ) { st->prevstacktrace = sc_stacktrace; st->procname = procname; sc_stacktrace = st; CHECK_SP; CHECK_TS; } /* The following procedure is called on procedure exit to reset the stack link when COMPACTPOPTRACE is 1. */ TSCP sc_popstacktrace( struct STACKTRACE *st, TSCP result ) { sc_stacktrace = st->prevstacktrace; return( result ); } /* Operating system dependent time of day string. */ TSCP sc_time_2dof_2dday_v; TSCP sc_time_2dof_2dday() { time_t timevalue; char buffer[ 50 ], *bp = buffer, *cp; time( &timevalue ); cp = ctime( &timevalue ); while (*cp && *cp != '\n') *bp++ = *cp++; *bp = 0; return( sc_cstringtostring( buffer ) ); } /* Operating system specific initializations are inserted here. This is called from sc_newheap, after the heap has been created. */ void sc_cioinit() { #ifdef MAC clockbase = clock(); #endif } scheme2c-2012.10.14/scrt/cio.h000066400000000000000000000072031203736146400155010ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module supplies functions to access system dependent facilities. */ extern TSCP sc_stdin_v; extern TSCP sc_stdout_v; extern TSCP sc_stderr_v; extern void sc_setstdio(); extern TSCP sc_fopen( XAL2( TSCP, TSCP ) ); extern TSCP sc_fclose( XAL1( TSCP ) ); extern TSCP sc_fflush( XAL1( TSCP ) ); extern TSCP sc_fgetc( XAL1( TSCP ) ); extern TSCP sc_fputc( XAL2( TSCP, TSCP ) ); extern TSCP sc_charready( XAL1( TSCP ) ); extern TSCP sc_fileno( XAL1( TSCP ) ); extern TSCP sc_inputready( XAL1( TSCP ) ); extern TSCP sc_removefile( XAL1( TSCP ) ); extern TSCP sc_rename( XAL2( TSCP, TSCP ) ); extern TSCP sc_formatnumber( XAL3( TSCP, TSCP, TSCP ) ); extern TSCP sc_readnumber( XAL2( TSCP, TSCP ) ); extern char* sc_getenv( XAL1( char* ) ); #ifdef __GNUC__ extern void sc_abort() __attribute__((noreturn)); #else extern void sc_abort(); #endif extern double sc_cputime(); extern void sc_log_string( XAL1( char * ) ); extern void sc_log_dec( XAL1( S2CINT ) ); extern void sc_log_hex( XAL1( S2CUINT ) ); extern TSCP sc_error_2ddisplay( XAL1( TSCP ) ); extern void sc_getheap( XAL2( S2CINT, S2CINT ) ); extern void sc_freeheap( XAL1( void* ) ); extern VOIDP sc_gettable( XAL2( S2CINT, S2CINT ) ); extern void sc_freetable( XAL1( void* ) ); /* Signal handling - N.B. signals and time slicing are mutually exclusive. */ extern void sc_dispatchpendingsignals(); extern S2CINT sc_mutex; extern S2CINT sc_pendingsignals; #if TIMESLICE #define MUTEXON #define MUTEXOFF #else #define MUTEXON sc_mutex = 1 #define MUTEXOFF if ((sc_mutex = sc_pendingsignals) && sc_collecting == 0) \ sc_dispatchpendingsignals() #endif /* Information about allocated heap space is returned in the following structure. */ struct HEAPBLOCKS { S2CINT count; /* # of blocks of memory allocated */ S2CINT minphypage; /* Pages spanned by this allocation */ S2CINT maxphypage; struct { VOIDP address; /* Address of the block */ S2CINT size; /* Size in bytes of the block */ } block[ 256 ]; }; extern struct HEAPBLOCKS sc_heapblocks; extern TSCP sc_ossystem( XAL1( TSCP ) ); extern TSCP sc_ossignal( XAL2( TSCP, TSCP ) ); extern void sc_collect_done(); extern void sc_stackoverflow(); extern void sc_timesliced(); extern void sc_pushstacktrace( XAL2( struct STACKTRACE *, char* ) ); extern TSCP sc_popstacktrace( XAL2( struct STACKTRACE *, TSCP ) ); extern void sc_cioinit(); extern TSCP sc_time_2dof_2dday_v; extern TSCP sc_time_2dof_2dday(); scheme2c-2012.10.14/scrt/em2.c000066400000000000000000000053121203736146400154040ustar00rootroot00000000000000/* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ #include "options.h" #include #if MAC #include #endif char line[ 200 ], *result, *error; int status, s; void ev0() { scheme2c( line, &status, &result, &error ); } void ev1() { int buffer[ 500 ], i; for (i = 0; i < 500; i++) buffer[ i ] = i; scheme2c( line, &status, &result, &error ); for (i = 0; i < 500; i++) if (buffer[ i ] != i) abort(); } void ev2() { int buffer[ 1000 ], i; for (i = 0; i < 1000; i++) buffer[ i ] = i; scheme2c( line, &status, &result, &error ); for (i = 0; i < 1000; i++) if (buffer[ i ] != i) abort(); } void ev3() { int buffer[ 700 ], i; for (i = 0; i < 700; i++) buffer[ i ] = i; scheme2c( line, &status, &result, &error ); for (i = 0; i < 700; i++) if (buffer[ i ] != i) abort(); } main() { S2CINT *sp; #if MAC STACKPTR( sp ); SetApplLimit( (char*)sp-57000 ); console_options.nrows = 30; console_options.title = "\pScheme->C"; #endif printf( "Embedded Scheme->C Test Bed\n0- " ); scheme2c( "(begin (set-stack-size! 57000) (set-time-slice! 100000))", &status, &result, &error ); if (status != 0) { printf( "Initialization failed!\n" ); exit( 1 ); } while (gets( line ) != NULL) { switch (s) { case 0: ev0(); break; case 1: ev1(); break; case 2: ev2(); break; case 3: ev3(); break; } s = (s + 1) & 3; if (*result != 0) printf( "%s\n", result ); if (*error != 0) printf( "%s", error ); printf( "%d- ", status ); fflush( stdout ); } printf( "\n" ); exit( 0 ); } scheme2c-2012.10.14/scrt/embedded.c000066400000000000000000000060071203736146400164540ustar00rootroot00000000000000/* This file is the "main" program for an embedded SCHEME->C interpreter. */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ #include "options.h" #ifdef DYNAMIC #include #include main() { char line[ 200 ], FAR *result, FAR *error; int status; HINSTANCE s2clib; void (FAR *scheme2c)( char FAR *line, int FAR *status, char FAR **result, char FAR **error ); s2clib = LoadLibrary( "scheme2c.dll" ); if (s2clib <= 21) { printf( "LoadLibrary error = %d\n", s2clib ); exit( 1 ); } (FARPROC)scheme2c = GetProcAddress( s2clib, "_scheme2c" ); printf( "Embedded Scheme->C Test Bed\n0- " ); (*scheme2c)( "(begin (set-stack-size! 50000) (set-time-slice! 100000))", &status, &result, &error ); if (status != 0) { printf( "Initialization failed!\n" ); FreeLibrary( s2clib ); exit( 1 ); } while (gets( line ) != NULL && line[0] != 0) { (*scheme2c)( &line[0], &status, &result, &error ); if (*result != 0) printf( "%s\n", result ); if (*error != 0) printf( "%s", error ); printf( "%d- ", status ); } printf( "\n" ); FreeLibrary( s2clib ); exit( 0 ); } #else #include #if MAC #include #endif main() { char line[ 200 ], *result, *error; int status; S2CINT *sp; #if MAC STACKPTR( sp ); SetApplLimit( (char*)sp-57000 ); console_options.nrows = 30; console_options.title = "\pScheme->C"; #endif printf( "Embedded Scheme->C Test Bed\n0- " ); scheme2c( "(begin (set-stack-size! 57000) (set-time-slice! 100000))", &status, &result, &error ); if (status != 0) { printf( "Initialization failed!\n" ); exit( 1 ); } while (gets( line ) != NULL) { scheme2c( line, &status, &result, &error ); if (*result != 0) printf( "%s\n", result ); if (*error != 0) printf( "%s", error ); printf( "%d- ", status ); fflush( stdout ); } printf( "\n" ); exit( 0 ); } #endif scheme2c-2012.10.14/scrt/heap.c000066400000000000000000001620521203736146400156430ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module implements the object storage storage system. */ /* Import definitions */ #include /* for abort(3) */ #include "objects.h" #include "scinit.h" #include "heap.h" #include "callcc.h" #include "apply.h" #include "cio.h" #ifndef NULL #define NULL 0 #endif #ifdef HP700 extern sc_r1tor18( ); #endif #if defined(LINUX) || defined(FREEBSD) || defined(AMD64) || defined(OPENBSD) extern sc_geti386regs( S2CINT* a ); #endif #ifdef MC680X0 extern sc_a2to5d2to7( ); #endif #ifdef MIPS extern sc_s0tos8( S2CINT* a ); #endif #ifdef VAX extern sc_r2tor11( ); #endif /* Forward declarations */ static void move_ptr( XAL1( TSCP ) ); static SCP move_object( XAL1( SCP ) ); static void move_continuation_ptr( XAL1( SCP ) ); /* Set the following define to a non-zero value to enable all heap checks that are normally enabled by sc_gcinfo == 2. */ #define CHECK_S2C_HEAP 0 /* Allocate storage which is defined in "heap.h" */ unsigned char *sc_pagegeneration, /* page generation table */ *sc_pagetype, /* page type table */ *sc_pagelock; /* page lock table */ PAGELINK *sc_pagelink; /* page lock list link table */ S2CINT sc_initiallink, /* Value to put in sc_pagelink field for a newly allocated page */ sc_locklist, /* list header for locked pages */ sc_genlist, /* list of modified pages */ sc_lockcnt, /* # of locked pages */ sc_current_generation, /* current generation */ sc_next_generation; /* next generation */ S2CINT sc_firstphypagem1, /* first phy page - 1 in the Scheme heap */ sc_firstphypage, /* first phy page in the Scheme heap */ sc_lastphypage, /* last phy page in the Scheme heap */ sc_firstpage, /* first logical page in the Scheme heap */ sc_lastpage, /* last logical page in the Scheme heap */ sc_heappages, /* # of pages in the Scheme heap */ sc_limit, /* % of heap allocated after collecton that forces total collection */ sc_freepage, /* free page index */ sc_maxheappages, /* Maximum # of pages in Scheme heap */ sc_allocatedheappages, /* # of pages currently allocated */ sc_generationpages, /* # of pages in saved generations */ *sc_firstheapp, /* ptr to first word in the Scheme heap */ *sc_lastheapp; /* ptr to last word in the Scheme heap */ int sc_conscnt; /* # cons cells in sc_consp */ SCP sc_consp; /* pointer to next cons cell */ S2CINT sc_extobjwords, /* # of words for ext objs in sc_extobjp */ sc_extwaste; /* # of words wasted on page crossings */ SCP sc_extobjp; /* pointer to next free extended obj word */ S2CINT sc_gcinfo, /* controls logging */ sc_collecting; static S2CINT sc_newlist; /* list of newly allocated pages */ S2CINT *sc_stackbase; /* pointer to base of the stack */ TSCP sc_whenfreed, /* list of items needing cleanup when free */ sc_freed; /* list of free items to be cleanup */ TSCP sc_after_2dcollect_v, /* Collection status callback */ sc__2afrozen_2dobjects_2a_v; /* User managed frozen object list */ static double starttime = 0.0; /* Processor time at start of interval */ double sc_usertime = 0.0, /* Scheme time */ sc_idletime = 0.0, /* Outside Scheme time */ sc_gctime = 0.0; /* Collection time */ /* Application and collection time is kept by the following routine. When a timer is stopped, it updates it and returns the delta added to it. */ double sc_stoptimer( double *timer ) { double currenttime, delta; currenttime = sc_cputime(); delta = currenttime-starttime; *timer = *timer+delta; starttime = currenttime; return( delta ); } /* Each time a weak-cons is created, an entry is made on the following list. Each entry of the list is a 3-element vector with the following fields: pointer to the next entry (or EMPTYLIST) pointer to the cons cell cell to hold the original value from the CAR of the cons cell */ static TSCP weakconsl = EMPTYLIST; #define WEAK_LINK( x ) VECTOR_ELEMENT( x, C_FIXED( 0 ) ) #define WEAK_CONS( x ) VECTOR_ELEMENT( x, C_FIXED( 1 ) ) #define WEAK_CAR( x ) VECTOR_ELEMENT( x, C_FIXED( 2 ) ) #define MAKE_WEAK sc_make_2dvector( C_FIXED( 3 ), EMPTYLIST ) /* When pages are allocated during garbage collection, they are queued on the following two lists for later scanning. One list holds pages allocated for cons cells and the other holds pages allocated for extended objects. The lists are threaded through sc_pagelink, the pointer points to the tail of the list, and the tail link points to the head. */ static S2CINT cons_pages = -1, extended_pages = -1; #define QUEUE_PAGE( tail, page ) \ if (tail == -1) { \ tail = sc_pagelink[ page ] = page; \ } else { \ sc_pagelink[ page ] = sc_pagelink[ tail ]; \ sc_pagelink[ tail ] = page; \ tail = page; \ } #define DELETE_PAGE( tail, page ) \ if (tail == -1) \ page = -1; \ else { \ page = sc_pagelink[ tail ]; \ sc_pagelink[ tail ] = sc_pagelink[ page ]; \ if (tail == page) tail = -1; \ } /* 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 once. */ static SCP moving_object; static S2CINT pointer_errors = 0; static void pointererror( char* msg, S2CUINT pp ) { sc_log_string( "***** COLLECT pointer error in " ); sc_log_hex( (S2CUINT)moving_object ); sc_log_string ( ", " ); sc_log_hex( (S2CUINT)pp ); sc_log_string( msg ); if (++pointer_errors == 30) sc_abort(); } #ifdef AOSF /* All processor registers which might contain pointers are traced by the following procedure. */ static trace_stack_and_registers() { S2CINT s0tos6[7], *pp; sc_s0tos6( s0tos6 ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif #if defined(AMD64) || defined(LINUX) || defined(HP700) \ || defined(MIPS) || defined(FREEBSD) || defined(LINUX_ARM) || defined(OPENBSD) /* 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. */ S2CINT *sc_processor_register( S2CINT reg ) { S2CINT* x = ® return( x ); } #endif #ifdef AMD64 /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT i386regs[13], *pp; sc_geti386regs( i386regs ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif #ifdef HP700 /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT r1tor18[18], *pp; sc_r1tor18( r1tor18 ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp--) ); } #endif #if defined(LINUX) || defined(OPENBSD) /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT i386regs[6], *pp; sc_geti386regs( i386regs ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif #ifdef MAC /* The following code is used to read the stack pointer. */ S2CINT *sc_getsp() { register S2CINT* x; asm{ move.l sp,x } return( x+1 ); } /* Traces the stack, 2 bytes at a time. No pointers are assumed to be in the registers. */ static void trace_stack_and_registers() { S2CINT *pp; STACKPTR( pp ); while ((S2CUINT)pp < (S2CUINT)sc_stackbase) { move_continuation_ptr( (SCP)*pp ); pp = (S2CINT*)(((char*)pp)+2); } } #endif #ifdef MC680X0 /* 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( ®+1 ); } /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT a2to5d2to7[10], *pp; sc_a2to5d2to7( a2to5d2to7 ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif #ifdef MIPS /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT s0tos8[9], *pp; sc_s0tos8( s0tos8 ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif #ifdef VAX /* 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. */ S2CINT *sc_processor_register( reg ) S2CINT reg; { return( ®+1 ); } /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT r2tor11[10], *pp; sc_r2tor11( r2tor11 ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif #ifdef FREEBSD /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT i386regs[6], *pp; sc_geti386regs( i386regs ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif #ifdef SPARC /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT *pp; sc_jmp_buf tmp; STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif #ifdef LINUX_ARM /* All processor registers which might contain pointers are traced by the following procedure. */ static void trace_stack_and_registers() { S2CINT armregs[9], *pp; sc_getARMregs( armregs ); STACKPTR( pp ); while (pp != sc_stackbase) move_continuation_ptr( ((SCP)*pp++) ); } #endif /* The size of an extended object in words is returned by the following function. */ static S2CINT extendedsize( SCP obj ) { switch (obj->extendedobj.tag) { case SYMBOLTAG: return( SYMBOLSIZE ); case STRINGTAG: return( STRINGSIZE( obj->string.length ) ); case VECTORTAG: return( VECTORSIZE( obj->vector.length ) ); case PROCEDURETAG: return( PROCEDURESIZE ); case CLOSURETAG: return( CLOSURESIZE( obj->closure.length ) ); case CONTINUATIONTAG: return( CONTINUATIONSIZE( obj->continuation.length ) ); case RECORDTAG: return( RECORDSIZE( obj->record.length ) ); case DOUBLEFLOATTAG: return( DOUBLEFLOATSIZE ); case FORWARDTAG: return( FORWARDSIZE( obj->forward.length ) ); case WORDALIGNTAG: return( WORDALIGNSIZE ); default: sc_log_string( "***** COLLECT Unknown extended object: " ); sc_log_hex( (S2CUINT)obj ); sc_log_string( " " ); sc_log_hex( (S2CUINT)obj->extendedobj.tag ); sc_log_string( "\n" ); sc_abort(); } } /* Words inside continuations are checked by the following function. If the word looks like a pointer, then the page containing the object will be locked and the object will be moved. */ static void move_continuation_ptr( SCP pp ) { S2CINT page, tag; SCP sweep, next; if ((S2CUINT)pp >= (S2CUINT)sc_firstheapp && (S2CUINT)pp < (S2CUINT)sc_lastheapp) { page = ADDRESS_PAGE( pp ); if (S2CPAGE( page ) && sc_current_generation == sc_pagegeneration[ page ]) { tag = sc_pagetype[ page ]; if (tag == PAIRTAG) { /* Trace just that PAIR */ pp = (SCP)(((S2CINT)pp) & ~(((S2CINT)CONSBYTES)-1)); if (sc_pagelock[ page ] == 0) { sc_pagelock[ page ] = 1; sc_pagelink[ page ] = sc_locklist; sc_locklist = page; sc_lockcnt = sc_lockcnt+1; } if (sc_gcinfo == 2 && pp->forward.tag != FORWARDTAG) { sc_log_string( " move_continuation_ptr " ); sc_log_hex( (S2CUINT)U_T( pp, PAIRTAG ) ); sc_log_string( "\n" ); } move_ptr( U_T( pp, PAIRTAG ) ); return; } /* Trace the referenced object */ if (tag == BIGEXTENDEDTAG) { while (sc_pagetype[ page ] != EXTENDEDTAG) page--; } sweep = (SCP)PAGE_ADDRESS( page ); if (sc_pagelock[ page ] == 0) { sc_pagelock[ page ] = 1; sc_pagelink[ page ] = sc_locklist; sc_locklist = page; if (sweep->wordalign.tag == WORDALIGNTAG) { sweep = (SCP)( ((S2CINT*)sweep)+WORDALIGNSIZE ); } sc_lockcnt = (extendedsize( sweep )+PAGEWORDS-1)/PAGEWORDS+ sc_lockcnt; } while (ADDRESS_PAGE( sweep ) == page && sweep->unsi.gned != ENDOFPAGE) { next = (SCP)( ((S2CINT*)sweep)+extendedsize( sweep ) ); if ((S2CUINT)pp < (S2CUINT)next) { /* sweep points to object to move */ if (sc_gcinfo == 2 && sweep->forward.tag != FORWARDTAG) { sc_log_string( " move_continuation_ptr " ); sc_log_hex( (S2CUINT)U_TX( sweep ) ); sc_log_string( "\n" ); } move_ptr( U_TX( sweep ) ); return; } sweep = next; } } } } /* Objects are moved from old space to new space by calling this procedure with a Scheme pointer to the object. Note that this function does not return the new value of the pointer, as it cannot be discerned at this time as all locked pages may not have been found yet. N.B. in the generational scheme, only objects in sc_current_generation are moved. */ static void move_ptr( TSCP tpp ) { S2CINT length, words, *oldp, *newp, page; TSCP new; SCP pp; pp = T_U( tpp ); switch TSCPTAG( tpp ) { case FIXNUMTAG: return; case EXTENDEDTAG: page = ADDRESS_PAGE( pp ); if (NOT_S2CPAGE( page ) || pp->forward.tag == FORWARDTAG || pp->wordalign.tag == WORDALIGNTAG || sc_pagegeneration[ page ] != sc_current_generation) return; if (sc_pagetype[ page ] != EXTENDEDTAG) { pointererror( " not in an EXTENDEDTAG page\n", (S2CUINT)pp ); return; } words = extendedsize( pp ); length = words; newp = (S2CINT*)sc_allocateheap( extendedsize( pp ), pp->extendedobj.tag, 0 ); new = U_T( newp, EXTENDEDTAG ); oldp = (S2CINT*)pp; while (words--) *newp++ = *oldp++; pp->forward.tag = FORWARDTAG; pp->forward.length = length; pp->forward.forward = new; return; case IMMEDIATETAG: return; case PAIRTAG: page = ADDRESS_PAGE( pp ); if (pp->forward.tag == FORWARDTAG || sc_pagegeneration[ page ] != sc_current_generation) return; if (sc_pagetype[ page ] != PAIRTAG) { pointererror( " not in a PAIRTAG page\n", (S2CUINT)pp ); return; } pp->forward.forward = sc_cons( pp->pair.car, pp->pair.cdr ); pp->forward.tag = FORWARDTAG; pp->forward.length = CONSSIZE; return; } } /* MOVE_OBJECT is called to move all extended objects in a page starting at a starting point. It will return a pointer to the first object that it could not move, or NULL if the page was finished. */ static SCP move_object( SCP pp ) { S2CINT size, cnt, vpage, left; PATSCP obj; left = (PAGEBYTES-ADDRESS_OFFSET( pp ))/sizeof(S2CINT); while (left > 0 && (pp != sc_extobjp || sc_extobjwords == 0) && pp->unsi.gned != ENDOFPAGE) { moving_object = pp; switch ( pp->extendedobj.tag ) { case SYMBOLTAG: move_ptr( pp->symbol.name ); vpage = ADDRESS_PAGE( pp->symbol.ptrtovalue ); if (S2CPAGE( vpage )) pp->symbol.ptrtovalue = &pp->symbol.value; move_ptr( *pp->symbol.ptrtovalue ); move_ptr( pp->symbol.propertylist ); size = SYMBOLSIZE; break; case STRINGTAG: size = STRINGSIZE( pp->string.length ); break; case VECTORTAG: cnt = pp->vector.length; obj = &pp->vector.element0; while (cnt--) move_ptr( *obj++ ); size = VECTORSIZE( pp->vector.length ); break; case PROCEDURETAG: move_ptr( pp->procedure.closure ); size = PROCEDURESIZE; break; case CLOSURETAG: move_ptr( pp->closure.closure ); cnt = pp->closure.length; obj = &pp->closure.var0; while (cnt--) move_ptr( *obj++ ); size = CLOSURESIZE( pp->closure.length ); break; case CONTINUATIONTAG: move_ptr( pp->continuation.continuation ); obj = &pp->continuation.continuation; cnt = pp->continuation.length; #ifdef MAC cnt = cnt*2-1; ++obj; while (cnt--) { move_continuation_ptr( (SCP)*obj ); obj = (PATSCP)(((char*)obj)+2); } #else while (cnt--) move_continuation_ptr( ((SCP)*(++obj)) ); #endif size = CONTINUATIONSIZE( pp->continuation.length ); break; case RECORDTAG: move_ptr( pp->record.methods ); cnt = pp->record.length; obj = &pp->record.element0; while (cnt--) move_ptr( *obj++ ); size = RECORDSIZE( pp->record.length ); break; case DOUBLEFLOATTAG: size = DOUBLEFLOATSIZE; break; case FORWARDTAG: size = FORWARDSIZE( pp->forward.length ); break; case WORDALIGNTAG: size = WORDALIGNSIZE; break; default: pointererror( " is not a valid extended object tag\n", pp->extendedobj.tag ); } pp = (SCP)( ((S2CINT*)pp)+size ); left = left-size; } if (left > 0 && pp == sc_extobjp && sc_extobjwords != 0) return( pp ); return( NULL ); } /* The following function is called to resolve a pointer that might be forwarded. It returns the resolved pointer. */ static TSCP resolveptr( TSCP obj ) { if ((TSCPTAG( obj ) & 1) && (T_U( obj )->forward.tag == FORWARDTAG)) return( T_U( obj )->forward.forward ); return( obj ); } /* Save the car of each weak cons cell that contains a pointer into the heap and replace it with #F. */ static void save_weakconsl() { TSCP wl, weakcons; SCP pp; wl = weakconsl; while (wl != EMPTYLIST) { weakcons = WEAK_CONS( wl ); pp = T_U( PAIR_CAR( weakcons ) ); if (TSCPTAG( PAIR_CAR( weakcons ) ) & 1 && pp >= (SCP)sc_firstheapp && pp < (SCP)sc_lastheapp) { WEAK_CAR( wl ) = PAIR_CAR( weakcons ); PAIR_CAR( weakcons ) = FALSEVALUE; } else { WEAK_CAR( wl ) = FALSEVALUE; } wl = WEAK_LINK( wl ); } } /* Rebuild the weak cons list. */ static void rebuild_weakconsl() { TSCP wl, oldcons, newcons, oldcar, newcar, weak; wl = weakconsl; weakconsl = EMPTYLIST; while (wl != EMPTYLIST) { newcons = resolveptr( (oldcons = WEAK_CONS( wl )) ); newcar = resolveptr( (oldcar = WEAK_CAR( wl )) ); if (oldcons == newcons && sc_pagegeneration[ ADDRESS_PAGE( oldcons ) ] == sc_current_generation) { /* Cons cell was not retained so drop from list */ wl = resolveptr( WEAK_LINK( wl ) ); } else { if (oldcar != FALSEVALUE && (oldcar != newcar || sc_pagegeneration[ ADDRESS_PAGE( oldcar ) ] != sc_current_generation)) { /* Object is still in use so restore it's car ptr */ PAIR_CAR( newcons ) = oldcar; } weak = MAKE_WEAK; WEAK_LINK( weak ) = weakconsl; weakconsl = weak; WEAK_CONS( weak ) = oldcons; wl = resolveptr( WEAK_LINK( wl ) ); } } } /* Once all objects are moved, objects needing special action on deletion are discovered by examining SC_WHENFREED. All objects that have not been moved are placed on SC_FREED, and those that have been moved are retained on SC_WHENFREED. */ static void check_unreferenced() { TSCP objects, object_procedure, object; objects = resolveptr( sc_whenfreed ); sc_whenfreed = EMPTYLIST; while (objects != EMPTYLIST) { object_procedure = resolveptr( PAIR_CAR( objects ) ); object = PAIR_CAR( object_procedure ); if (object == resolveptr( object ) && sc_pagegeneration[ ADDRESS_PAGE( object ) ] == sc_current_generation) { /* Object was not forwarded, so it needs to be cleaned up. */ sc_freed = sc_cons( object_procedure, sc_freed ); } else { /* Object was forwarded, so leave it on sc_whenfreed. */ sc_whenfreed = sc_cons( object_procedure, sc_whenfreed ); } objects = resolveptr( PAIR_CDR( objects ) ); } } /* The moves are coordinated by the following function which moves objects on newly allocated pages until there is nothing left to move. */ static void move_the_heap() { S2CINT progress, count, weaktodo, unreferenced, page; SCP myconsp, myextobjp, newp; myconsp = NULL; myextobjp = NULL; weaktodo = 1; unreferenced = 1; progress = 1; while (progress--) { /* Move all the currently allocated, but unmoved pairs. */ if (myconsp == NULL) { DELETE_PAGE( cons_pages, page ); if (page != -1) { sc_pagelink[ page ] = sc_newlist; sc_newlist = page; myconsp = (SCP)PAGE_ADDRESS( page ); } } if (myconsp != NULL && (myconsp != sc_consp || sc_conscnt == 0)) { count = (PAGEBYTES-ADDRESS_OFFSET( myconsp ))/CONSBYTES; progress = 1; while (count-- && (myconsp != sc_consp || sc_conscnt == 0)) { moving_object = myconsp; move_ptr( myconsp->pair.car ); move_ptr( myconsp->pair.cdr ); myconsp = (SCP)(((char*)myconsp)+CONSBYTES); } if (count == -1) myconsp = NULL; } /* Move all currently allocated, but unmoved extended items */ if (myextobjp == NULL) { DELETE_PAGE( extended_pages, page ); if (page != -1) { sc_pagelink[ page ] = sc_newlist; sc_newlist = page; myextobjp = (SCP)PAGE_ADDRESS( page ); } } if (myextobjp != NULL) { newp = move_object( myextobjp ); if (newp != myextobjp) progress = 1; myextobjp = newp; } /* Find weak references needing cleanup */ if (progress == 0 && weaktodo) { weaktodo = 0; rebuild_weakconsl(); progress = 1; } /* Find unreferenced objects needing cleanup */ if (progress == 0 && unreferenced) { unreferenced = 0; check_unreferenced(); progress = 1; } } if (pointer_errors) sc_abort(); } /* Objects in the current generation that have references in previous generations are moved in the following routine. */ static void move_the_generations() { S2CINT page = sc_genlist, count, pageaddr; SCP myconsp; /* Correct the newly allocated pages */ while (page != -1) { pageaddr = PAGE_ADDRESS( page ); switch (sc_pagetype[ page ]) { case PAIRTAG: myconsp = (SCP)PAGE_ADDRESS( page ); count = PAGEBYTES/CONSBYTES; while (count--) { move_ptr( myconsp->pair.car ); move_ptr( myconsp->pair.cdr ); myconsp = (SCP)(((char*)myconsp)+CONSBYTES); } break; case EXTENDEDTAG: move_object( (SCP)PAGE_ADDRESS( page ) ); break; } page = sc_pagelink[ ADDRESS_PAGE( pageaddr ) ]; } } /* Once all objects are moved, pointers can be corrected to either point to the new object (when it can be copied), or point to the old object (when the page is locked). This is done by the following function which takes a tagged pointer as its argument and returns the new value of the pointer. */ static TSCP correct( TSCP tobj ) { SCP obj; if (((S2CINT)tobj) & 1) { obj = T_U( tobj ); if ( (obj->forward.tag != FORWARDTAG) || sc_pagelock[ ADDRESS_PAGE( obj ) ] ) return tobj; return( obj->forward.forward ); } return( tobj ); } /* The pointers within extended objects are corrected by the following function. It is called with a pointer to an object. All objects which follow it on that page will be corrected. */ static void correct_object( SCP pp ) { S2CINT page, size, cnt; PATSCP obj; page = ADDRESS_PAGE( pp ); while (ADDRESS_PAGE( pp ) == page && pp->unsi.gned != ENDOFPAGE && (pp != sc_extobjp || sc_extobjwords == 0)) { switch ( pp->extendedobj.tag ) { case SYMBOLTAG: pp->symbol.name = correct( pp->symbol.name ); *pp->symbol.ptrtovalue = correct( *pp->symbol.ptrtovalue ); pp->symbol.propertylist = correct( pp->symbol.propertylist ); size = SYMBOLSIZE; break; case STRINGTAG: size = STRINGSIZE( pp->string.length ); break; case VECTORTAG: cnt = pp->vector.length; obj = &pp->vector.element0; while (cnt--) { *obj = correct( *obj ); obj++; } size = VECTORSIZE( pp->vector.length ); break; case PROCEDURETAG: pp->procedure.closure = correct( pp->procedure.closure ); size = PROCEDURESIZE; break; case CLOSURETAG: pp->closure.closure = correct( pp->closure.closure ); cnt = pp->closure.length; obj = &pp->closure.var0; while (cnt--) { *obj = correct( *obj ); obj++; } size = CLOSURESIZE( pp->closure.length ); break; case CONTINUATIONTAG: pp->continuation.continuation = correct( pp->continuation.continuation ); size = CONTINUATIONSIZE( pp->continuation.length ); break; case RECORDTAG: pp->record.methods = correct( pp->record.methods ); cnt = pp->record.length; obj = &pp->record.element0; while (cnt--) { *obj = correct( *obj ); obj++; } size = RECORDSIZE( pp->record.length ); break; case DOUBLEFLOATTAG: size = DOUBLEFLOATSIZE; break; case WORDALIGNTAG: size = WORDALIGNSIZE; break; default: sc_log_string( "***** COLLECT Unknown extended object: " ); sc_log_hex( (S2CUINT)pp ); sc_log_string( " " ); sc_log_hex( (S2CUINT)pp->extendedobj.tag ); sc_log_string( "\n" ); sc_abort(); } pp = (SCP)( ((S2CINT*)pp)+size ); } } /* Pointer correction to lists of pages is done by the following procedure. The list is terminated by a -1, and the sc_pagelink field for each page is set to linkvalue. */ static void correct_pointers( S2CINT page, S2CINT linkvalue ) { S2CINT count, i; PATSCP ptr; /* Correct the newly allocated pages */ while (page != -1) { switch (sc_pagetype[ page ]) { case PAIRTAG: ptr = (PATSCP)PAGE_ADDRESS( page ); count = PAGEBYTES/(CONSBYTES/2); while (count--) { if ((*((S2CINT*)ptr) & 1) && (T_U(*ptr)->forward.tag == FORWARDTAG) && (sc_pagelock[ ADDRESS_PAGE( *ptr ) ] == 0)) *ptr = T_U(*ptr)->forward.forward; ptr++; } i = page; page = sc_pagelink[ page ]; sc_pagelink[ i ] = linkvalue; break; case EXTENDEDTAG: correct_object( (SCP)PAGE_ADDRESS( page ) ); i = page; page = sc_pagelink[ page ]; do sc_pagelink[ i++ ] = linkvalue; while (i <= sc_lastpage && sc_pagetype[ i ] == BIGEXTENDEDTAG); break; } } } /* After pointers have been corrected, the items on locked pages need to have their correct version (found in the new copy) copied to the old page. In addition, objects which were not forwarded must be changed so that their pointers will no longer be followed. This is done by setting the CAR and CDR of the pair to 0, and turning extended objects into strings. Pages that are locked are added to sc_genlist so that will be checked on the next collection. */ static void copyback_locked_pages( S2CINT locklist ) { S2CINT page, count, vpage; SCP obj, fobj, sobj; while (locklist != -1) { page = locklist; obj = (SCP)PAGE_ADDRESS( page ); sc_pagelock[ page ] = 0; sc_pagegeneration[ page ] = sc_next_generation; locklist = sc_pagelink[ locklist ]; sc_pagelink[ page ] = sc_genlist; sc_genlist = page; if (sc_pagetype[ page ] == PAIRTAG) { /* Move back only the forwarded CONS cells */ count = PAGEBYTES/CONSBYTES; while (count--) { if (obj->forward.tag == FORWARDTAG) { fobj = T_U( obj->forward.forward ); obj->pair.car = fobj->pair.car; obj->pair.cdr = fobj->pair.cdr; } else { obj->pair.car = 0; obj->pair.cdr = 0; } obj = (SCP)((char*)(obj)+CONSBYTES); } } else if (sc_pagetype[ page ] == EXTENDEDTAG) { /* Move extra pages into the next generation */ if (obj->wordalign.tag == WORDALIGNTAG) { obj = (SCP)( ((S2CINT*)obj)+WORDALIGNSIZE ); } count = extendedsize( obj ); vpage = page; while (count > PAGEWORDS) { sc_pagegeneration[ ++vpage ] = sc_next_generation; sc_pagelink[ vpage ] = OKTOSET; count = count-PAGEWORDS; } /* Move back the forwarded extended items */ while (ADDRESS_PAGE( obj ) == page && (obj != sc_extobjp || sc_extobjwords == 0) && obj->unsi.gned != ENDOFPAGE) { if (obj->forward.tag == FORWARDTAG) { sobj = obj; fobj = T_U( obj->forward.forward ); count = obj->forward.length; while (count--) { *((S2CINT*)obj) = *((S2CINT*)fobj); obj = (SCP)(((S2CINT*)obj)+1); fobj = (SCP)(((S2CINT*)fobj)+1); } if (sobj->symbol.tag == SYMBOLTAG) { vpage = ADDRESS_PAGE( sobj->symbol.ptrtovalue ); if (S2CPAGE( vpage )) sobj->symbol.ptrtovalue = &sobj->symbol.value; } } else if (obj->wordalign.tag == WORDALIGNTAG) { obj = (SCP)( ((S2CINT*)obj)+WORDALIGNSIZE ); } else { count = extendedsize( obj ); obj->string.length = ((count-2)*sizeof(S2CINT))+ sizeof(S2CINT)-1; obj->string.tag = STRINGTAG; obj = (SCP)( ((S2CINT*)obj)+count ); } } } } } /* Object cleanup actions are invoked here at the end of garbage collection. */ void sc_apply_when_unreferenced() { TSCP freed, object_procedure; struct { /* Save sc_unknowncall's state here */ TSCP arg[MAXARGS]; TSCP proc[4]; S2CINT count; } save; S2CINT i; /* Save sc_freed and sc_unknowncall's state */ for (i = 0; i < 4; i++) save.proc[ i ] = sc_unknownproc[ i ]; for (i = 0; i < MAXARGS; i++) save.arg[ i ] = sc_arg[ i ]; save.count = sc_unknownargc; freed = sc_freed; sc_freed = EMPTYLIST; /* Apply the when-unreferenced procedures */ while (freed != EMPTYLIST) { object_procedure = PAIR_CAR( freed ); sc_apply_2dtwo( PAIR_CDR( object_procedure ), sc_cons( PAIR_CAR( object_procedure ), EMPTYLIST ) ); freed = PAIR_CDR( freed ); } /* Restore sc_unknowncall's state */ for (i = 0; i < 4; i++) sc_unknownproc[ i ] = save.proc[ i ]; for (i = 0; i < MAXARGS; i++) sc_arg[ i ] = save.arg[ i ]; sc_unknownargc = save.count; } /* This function is called to check the obarray to make sure that it is intact. */ static void check_obarray() { S2CINT i, len, page; PATSCP ep; TSCP lp, symbol, value; SCP obarray; obarray = T_U( sc_obarray ); if (TSCPTAG( sc_obarray ) != EXTENDEDTAG || obarray->vector.tag != VECTORTAG) { sc_log_string( "***** COLLECT OBARRAY is not a vector " ); sc_log_hex( (S2CUINT)sc_obarray ); sc_log_string( "\n" ); sc_abort(); } len = obarray->vector.length; if (len != 1023) { sc_log_string( "***** COLLECT OBARRAY length is wrong " ); sc_log_hex( (S2CUINT)sc_obarray ); sc_log_string( "\n" ); sc_abort(); } ep = &obarray->vector.element0; for (i = 0; i < len; i++) { lp = *ep++; while (lp != EMPTYLIST) { if (TSCPTAG( lp ) != PAIRTAG) { sc_log_string( "***** COLLECT OBARRAY element is not a list " ); sc_log_hex( (S2CUINT)lp ); sc_log_string( "\n" ); sc_abort(); } symbol = T_U( lp )->pair.car; if (T_U( symbol )->symbol.tag != SYMBOLTAG) { sc_log_string( "***** COLLECT OBARRAY entry is not a symbol " ); sc_log_hex( (S2CUINT)symbol ); sc_log_string( "\n" ); sc_abort(); } page = ADDRESS_PAGE( symbol ); if (sc_pagegeneration[ page ] & 1 && sc_pagegeneration[ page ] != sc_current_generation) { sc_log_string( "***** COLLECT OBARRAY symbol generation error " ); sc_log_hex( (S2CUINT)symbol ); sc_log_string( "\n" ); sc_abort(); } value = *T_U( symbol )->symbol.ptrtovalue; page = ADDRESS_PAGE( value ); if (TSCPTAG( value ) & 1 && S2CPAGE( page ) && sc_pagegeneration[ page ] & 1 && sc_pagegeneration[ page ] != sc_current_generation) { sc_log_string( "***** COLLECT OBARRAY value generation error " ); sc_log_hex( (S2CUINT)value ); sc_log_string( "\n" ); sc_abort(); } if (TSCPTAG( value ) & 1 && S2CPAGE( page ) && (~sc_pagegeneration[ ADDRESS_PAGE( symbol ) ]) & 1 && sc_pagegeneration[ page ] == sc_current_generation && sc_pagelink[ ADDRESS_PAGE( symbol ) ] == 0 && ADDRESS_PAGE( symbol ) == ADDRESS_PAGE( T_U( symbol )->symbol.ptrtovalue )) { sc_log_string( "***** COLLECT OBARRAY missed a top-level set! " ); sc_log_hex( (S2CUINT)symbol ); sc_log_string( "\n" ); sc_abort(); } if (sc_pagetype[ ADDRESS_PAGE( symbol ) ] != EXTENDEDTAG) { sc_log_string( "***** COLLECT OBARRAY symbol page type error " ); sc_log_hex( (S2CUINT)symbol ); sc_log_string( "\n" ); sc_abort(); } lp = T_U( lp )->pair.cdr; } } } /* The following procedure verifies that a pointer is correct. */ static void check_ptr( TSCP tpp ) { S2CINT page; page = ADDRESS_PAGE( tpp ); if (((S2CINT) tpp) & 1) { if (S2CPAGE( page )) { if ((sc_pagegeneration[ page ] != sc_current_generation && sc_pagegeneration[ page ] & 1) || sc_pagetype[ page ] != TSCPTAG( tpp )) { pointererror( " fails check_ptr\n", ((S2CUINT)T_U( tpp )) ); } } else if (TSCPTAG( tpp ) == PAIRTAG) { pointererror( " fails check_ptr\n", ((S2CUINT)T_U( tpp )) ); } } } /* A page of objects is checked by the following procedure. */ static SCP check_object( SCP pp ) { S2CINT page, size, cnt, vpage; PATSCP obj; page = ADDRESS_PAGE( pp ); while (ADDRESS_PAGE( pp ) == page && (pp != sc_extobjp || sc_extobjwords == 0) && pp->unsi.gned != ENDOFPAGE) { moving_object = pp; switch ( pp->extendedobj.tag ) { case SYMBOLTAG: check_ptr( pp->symbol.name ); vpage = ADDRESS_PAGE( pp->symbol.ptrtovalue ); check_ptr( *pp->symbol.ptrtovalue ); check_ptr( pp->symbol.propertylist ); size = SYMBOLSIZE; break; case STRINGTAG: size = STRINGSIZE( pp->string.length ); break; case VECTORTAG: cnt = pp->vector.length; obj = &pp->vector.element0; while (cnt--) check_ptr( *obj++ ); size = VECTORSIZE( pp->vector.length ); break; case PROCEDURETAG: check_ptr( pp->procedure.closure ); size = PROCEDURESIZE; break; case CLOSURETAG: check_ptr( pp->closure.closure ); cnt = pp->closure.length; obj = &pp->closure.var0; while (cnt--) check_ptr( *obj++ ); size = CLOSURESIZE( pp->closure.length ); break; case CONTINUATIONTAG: check_ptr( pp->continuation.continuation ); size = CONTINUATIONSIZE( pp->continuation.length ); break; case RECORDTAG: check_ptr( pp->record.methods ); cnt = pp->record.length; obj = &pp->record.element0; while (cnt--) check_ptr( *obj++ ); size = RECORDSIZE( pp->record.length ); break; case DOUBLEFLOATTAG: size = DOUBLEFLOATSIZE; break; case WORDALIGNTAG: size = WORDALIGNSIZE; break; default: pointererror( " is not a valid extended object tag\n", pp->extendedobj.tag ); } pp = (SCP)( ((S2CINT*)pp)+size ); } if (ADDRESS_PAGE( pp ) == page && pp == sc_extobjp && sc_extobjwords != 0) return( pp ); return( NULL ); } /* A page of pairs is checkled by the following procedure. */ static void check_pairs( SCP pp ) { S2CINT count; PATSCP ptr; ptr = (PATSCP)pp; count = (PAGEBYTES/CONSBYTES)*2; while (count-- && (ptr != (PATSCP)sc_consp || sc_conscnt == 0)) { moving_object = (SCP)(((S2CUINT)ptr) & 0xfffffff8L); check_ptr( *ptr ); ptr++; } } /* The following function can be called to check that all objects in the heap are valid. */ static void check_heap( ) { S2CINT i; /* Verify that all pages containing pairs are in good shape */ for (i = sc_firstpage; i <= sc_lastpage; i++) { if ((sc_pagegeneration[ i ] == sc_current_generation || ~sc_pagegeneration[ i ] & 1) && sc_pagegeneration[ i ] != 0) { if (sc_pagetype[ i ] == PAIRTAG) { check_pairs( (SCP)PAGE_ADDRESS( i ) ); } if (sc_pagetype[ i ] == EXTENDEDTAG) { check_object( (SCP)PAGE_ADDRESS( i ) ); } } } if (pointer_errors) sc_abort(); } /* Check the weakconsl for proper format. */ static void check_weakconsl() { TSCP wl = weakconsl; while (wl != EMPTYLIST) { check_ptr( wl ); check_ptr( WEAK_LINK( wl ) ); check_ptr( WEAK_CONS( wl ) ); check_ptr( WEAK_CAR( wl ) ); wl = WEAK_LINK( wl ); } if (pointer_errors) abort(); } /* Garbage collection is invoked to attempt to recover free storage when a request for storage cannot be met. It will recover using a generational version of the "mostly copying" method. See the .h file or the research reports for more details. */ TSCP sc_collect_v; TSCP sc_collect() { S2CINT i, wasallocated, savemutex; TSCP fl; double thisgctime; if (sc_collecting) { sc_log_string( "***** COLLECT Out of space during collection\n" ); sc_abort(); } sc_collecting = 1; savemutex = sc_mutex; sc_stoptimer( &sc_usertime ); sc_initiallink = NOTOKTOSET; wasallocated = sc_allocatedheappages; if (sc_gcinfo == 2 || CHECK_S2C_HEAP) { /* Perform additional consistency checks */ check_heap(); check_obarray(); check_weakconsl(); } if (sc_gcinfo) { sc_log_string( "\n***** COLLECT " ); sc_log_dec( (wasallocated*100)/sc_heappages ); sc_log_string( "% allocated (" ); sc_log_dec( (sc_extwaste*100)/(sc_heappages*PAGEWORDS) ); sc_log_string( "% waste, " ); sc_log_dec( (sc_heappages*PAGEBYTES+ONEMB/2)/ONEMB ); sc_log_string( " MB) -> \n" ); } /* Zero the current cons block, end the current extended block, initialize sc_locklist, advance the generation. */ sc_conscnt = sc_conscnt+sc_conscnt; while (sc_conscnt-- > 0) { *((S2CINT*)sc_consp) = 0; sc_consp = (SCP)(((S2CINT*)sc_consp)+1); } sc_conscnt = 0; if (sc_extobjwords) { sc_extobjp->unsi.gned = ENDOFPAGE; sc_extobjwords = 0; } sc_extwaste = 0; sc_allocatedheappages = 0; sc_newlist = -1; sc_locklist = -1; sc_lockcnt = 0; sc_next_generation = INC_GENERATION( sc_current_generation ); /* Hide the car's of pairs on the weakconsl. */ save_weakconsl(); /* Move the globals, display, and constants */ for ( i = 0; i < sc_globals->count; i++ ) { move_ptr( *(sc_globals->ptrs[ i ]) ); } for ( i = 0; i < sc_maxdisplay; i++ ) move_ptr( sc_display[ i ] ); for ( i = 0; i < sc_constants->count; i++ ) { move_ptr( *(sc_constants->ptrs[ i ]) ); } /* Look into the stack and the registers and treat anything that might be a pointer as a root and move it. */ trace_stack_and_registers(); /* Lock down user program's frozen objects. */ fl = sc__2afrozen_2dobjects_2a_v; while (TSCPTAG( fl ) == PAIRTAG) { move_continuation_ptr( T_U( PAIR_CAR( fl ) ) ); fl = PAIR_CDR( fl ); } /* Move new objects referenced in previous generations */ move_the_generations(); /* Continue moving the current generation until it terminates and then handle weak pointers and unreferenced. */ move_the_heap(); sc_allocatedheappages = sc_allocatedheappages+sc_lockcnt; /* Fully allocate partial pages */ sc_conscnt = sc_conscnt+sc_conscnt; while (sc_conscnt-- > 0) { *((S2CINT*)sc_consp) = 0; sc_consp = (SCP)(((S2CINT*)sc_consp)+1); } sc_conscnt = 0; if (sc_extobjwords) { sc_extobjp->unsi.gned = ENDOFPAGE; sc_extobjwords = 0; } /* Correct pointers in the copied heap */ correct_pointers( sc_newlist, sc_initiallink ); /* Correct pointers in previous generations */ correct_pointers( sc_genlist, 0 ); /* Correct pointers in globals, display, and constants */ for ( i = 0; i < sc_globals->count; i++ ) *(sc_globals->ptrs[ i ]) = correct( *(sc_globals->ptrs[ i ]) ); for ( i = 0; i < sc_maxdisplay; i++ ) sc_display[ i ] = correct( sc_display[ i ] ); for ( i = 0; i < sc_constants->count; i++ ) *(sc_constants->ptrs[ i ]) = correct( *(sc_constants->ptrs[ i ]) ); /* Copy back the locked objects and add locked pages to sc_genlist */ sc_genlist = -1; copyback_locked_pages( sc_locklist ); /* Step to the next odd generation, reset before overflow */ sc_next_generation = sc_current_generation = INC_GENERATION( sc_next_generation ); sc_generationpages = sc_generationpages+sc_allocatedheappages; sc_allocatedheappages = sc_generationpages; if (sc_current_generation > 200) { for (i = sc_firstpage; i <= sc_lastpage; i++) { if (sc_pagegeneration[ i ] != 0 && ~sc_pagegeneration[ i ] & 1) sc_pagegeneration[ i ] = 2; } sc_next_generation = sc_current_generation = 3; } /* Finish up */ thisgctime = sc_stoptimer( &sc_gctime ); if (sc_gcinfo) { sc_log_string( " " ); sc_log_dec( (sc_lockcnt*100)/sc_heappages ); sc_log_string( "% locked " ); sc_log_dec( (sc_generationpages*100)/sc_heappages ); sc_log_string( "% retained " ); sc_log_dec( (S2CINT)(thisgctime*1000.0) ); sc_log_string( " msec\n" ); } if (sc_gcinfo == 2 || CHECK_S2C_HEAP) { /* Perform additional consistency checks */ check_heap(); check_obarray(); check_weakconsl(); } /* Compact the whole heap if > sc_limit % of pages allocated */ sc_initiallink = OKTOSET; sc_mutex = savemutex; sc_collecting = 0; if (sc_mutex == 0) MUTEXOFF; if ((sc_allocatedheappages*100)/sc_heappages > sc_limit) { sc_collect_2dall(); if (sc_allocatedheappages > (sc_limit*sc_heappages*8)/1000) { MUTEXON; sc_expandheap(); MUTEXOFF; } } if (sc_after_2dcollect_v != FALSEVALUE) sc_apply_2dtwo( sc_after_2dcollect_v, sc_cons( C_FIXED( sc_heappages*PAGEBYTES ), sc_cons( C_FIXED( sc_allocatedheappages*PAGEBYTES ), sc_cons( C_FIXED( sc_limit ), EMPTYLIST ) ) ) ); sc_collect_done(); return( TRUEVALUE ); } /* A complete garbage collection can be forced by calling the following procedure. */ TSCP sc_collect_2dall_v; TSCP sc_collect_2dall() { S2CINT i, save_sc_limit = sc_limit; MUTEXON; sc_limit = 100; if (sc_generationpages != sc_allocatedheappages) sc_collect(); sc_limit = save_sc_limit; MUTEXOFF; MUTEXON; sc_next_generation = INC_GENERATION( INC_GENERATION( sc_next_generation ) ); sc_current_generation = sc_next_generation; for (i = sc_firstpage; i <= sc_lastpage; i++) { if (sc_pagegeneration[ i ] != 0 && ~sc_pagegeneration[ i ] & 1) sc_pagegeneration[ i ] = sc_current_generation; } sc_generationpages = 0; sc_genlist = -1; sc_limit = 100; sc_collect(); sc_limit = save_sc_limit; MUTEXOFF; return( TRUEVALUE ); } /* Information about the heap is returned by the following procedure. It returns a list of the currently allocated heap (in bytes), the total size of the heap (in bytes), the total time spent in the application (in seconds), the total time spent garbage collecting (in seconds), the maximum size of the heap (in bytes), and the generational collection limit (a per cent). */ TSCP sc_collect_2dinfo_v; TSCP sc_collect_2dinfo() { double currenttime; currenttime = sc_cputime(); return( sc_cons( C_FIXED( sc_allocatedheappages*PAGEBYTES ), sc_cons( C_FIXED( sc_heappages*PAGEBYTES ), sc_cons( DOUBLE_TSCP( sc_usertime+currenttime-starttime ), sc_cons( DOUBLE_TSCP( sc_gctime ), sc_cons( C_FIXED( sc_maxheappages*PAGEBYTES ), sc_cons( C_FIXED( sc_limit ), EMPTYLIST ) ) ) ) ) ) ); } /* The logging of garbage collection information in controlled by the following procedure. */ TSCP sc_set_2dgcinfo_21_v; TSCP sc_set_2dgcinfo_21( TSCP flag ) { S2CINT old_sc_gcinfo = sc_gcinfo; if (TSCPTAG( flag ) != FIXNUMTAG || FIXED_C( flag ) < 0 || FIXED_C( flag ) > 2) sc_error( "SET-GCINFO!", "ARGUMENT is not in the range [0-2]: ~s", LIST1( flag ) ); sc_gcinfo = FIXED_C( flag ); return( C_FIXED( old_sc_gcinfo ) ); } /* The generational collection limit is set by the following procedure. */ TSCP sc_2dlimit_21_de4d3427_v; TSCP sc_2dlimit_21_de4d3427( TSCP limit ) { if (TSCPTAG( limit ) != FIXNUMTAG || FIXED_C( limit ) < 10 || FIXED_C( limit ) > 45) sc_error( "SET-GENERATION-LIMIT!", "ARGUMENT is not in the range [10-45]: ~s", LIST1( limit ) ); sc_limit = FIXED_C( limit ); return( limit ); } /* The maximum heap size is set by the following procedure. */ TSCP sc_set_2dmaximum_2dheap_21_v; TSCP sc_set_2dmaximum_2dheap_21( TSCP maxheap ) { /* changed by Qobi R24Dec98 */ if (TSCPTAG(maxheap)==FIXNUMTAG) { if (FIXED_C(maxheap)SCMAXHEAP*ONEMB) sc_error("SET-MAXIMUM-HEAP!", "ARGUMENT is less than current heap or is too large: ~s", LIST1(maxheap)); sc_maxheappages = FIXED_C(maxheap)/PAGEBYTES;} else if (TSCPTAG(maxheap)==EXTENDEDTAG&& TSCP_EXTENDEDTAG(maxheap)==DOUBLEFLOATTAG) { if (FLOAT_VALUE(maxheap)SCMAXHEAP*ONEMB) sc_error("SET-MAXIMUM-HEAP!", "ARGUMENT is less than current heap or is too large: ~s", LIST1(maxheap)); sc_maxheappages = ((int)FLOAT_VALUE(maxheap))/PAGEBYTES;} else sc_error("SET-MAXIMUM-HEAP!", "ARGUMENT is not a number: ~s", LIST1(maxheap)); return(maxheap); } /* Pages in the heap are allocated by the following function. It is called with a page count and sets the appropriate allocation pointers as required. The sc_pagegeneration, sc_pagelink, sc_pagetype fields are set for each page here. The garbage collector is invoked as needed. */ static S2CINT allocatepage_failed = 0; /* Set following collection, cleared on successful allocation */ static void allocatepage( S2CINT count, S2CINT tag ) { S2CINT start, page, freecnt, generation; if ((count+sc_allocatedheappages) > sc_heappages/2) { failed: if ((allocatepage_failed || sc_collecting) && sc_expandheap() == 0) { sc_log_string( "***** ALLOCATEPAGE cannot allocate " ); sc_log_dec( count*PAGEBYTES ); sc_log_string( " bytes with " ); sc_log_dec( (sc_allocatedheappages*100)/sc_heappages ); sc_log_string( "% of heap allocated\n" ); sc_abort(); } if (sc_collecting == 0) sc_collect(); allocatepage_failed = 1; return; } start = sc_freepage; freecnt = 0; do { generation = sc_pagegeneration[ sc_freepage ]; if (generation & 1 && generation != sc_current_generation) { if (freecnt == 0) page = sc_freepage; freecnt++; } else freecnt = 0; if (sc_freepage == sc_lastpage) { if (freecnt != count) freecnt = 0; sc_freepage = sc_firstpage; } else sc_freepage++; if (sc_freepage == start) goto failed; } while (count != freecnt); allocatepage_failed = 0; sc_allocatedheappages = sc_allocatedheappages+count; sc_pagegeneration[ page ] = sc_next_generation; sc_pagetype[ page ] = tag; sc_pagelink[ page ] = sc_initiallink; if (tag == PAIRTAG) { sc_conscnt = PAGEBYTES/CONSBYTES; sc_consp = (SCP)PAGE_ADDRESS( page ); if (sc_collecting) { QUEUE_PAGE( cons_pages, page ); } } else { sc_extobjp = (SCP)PAGE_ADDRESS( page ); sc_extobjwords = count*PAGEWORDS; if (sc_collecting) { QUEUE_PAGE( extended_pages, page ); } while (--count) { sc_pagegeneration[ ++page ] = sc_next_generation; sc_pagetype[ page ] = BIGEXTENDEDTAG; sc_pagelink[ page ] = sc_initiallink; } } } /* When a pointer to a new object may be stored in a old page, the following procedure is called to add the old page to the list of changed older pages and then do the assignment. N.B. set-top-level-value! may set global values outside the heap. */ TSCP sc_setgeneration( TSCP* a, TSCP b ) { S2CINT oldpage = ADDRESS_PAGE( a ); MUTEXON; if (S2CPAGE( oldpage ) && sc_pagelink[ oldpage ] == 0) { if (sc_pagetype[ oldpage ] == PAIRTAG) { if (sc_pagegeneration[ oldpage ] == sc_current_generation) { sc_pagelink[ oldpage ] = OKTOSET; } else { sc_pagelink[ oldpage ] = sc_genlist; sc_genlist = oldpage; } } else { while (sc_pagetype[ oldpage ] == BIGEXTENDEDTAG) oldpage--; if (sc_pagegeneration[ oldpage ] == sc_current_generation) { sc_pagelink[ oldpage ] = OKTOSET; } else { sc_pagelink[ oldpage ] = sc_genlist; sc_genlist = oldpage; } while (++oldpage <= sc_lastpage && sc_pagetype[ oldpage ] == BIGEXTENDEDTAG) { sc_pagelink[ oldpage ] = OKTOSET; } } } *a = b; MUTEXOFF; return( b ); } /* Heap based storage is allocated by the following function. It is called with a word count and a value to put in the first word. It will return an UNTAGGED pointer to the storage. Note that the minimum permissible allocation size is two words. N.B. IT IS THE CALLER'S RESPONSIBILITY TO ASSURE THAT SIGNALS DO NOT CAUSE PROBLEMS DURING ALLOCATION. */ SCP sc_allocateheap( S2CINT wordsize, S2CINT tag, S2CINT rest ) { SCP alloc; S2CINT isastring = (tag == STRINGTAG); EVEN_EXTOBJP( tag == DOUBLEFLOATTAG ); ODD_EXTOBJP( isastring ); if (wordsize <= sc_extobjwords) { alloc = sc_extobjp; sc_extobjp = (SCP)(((S2CINT*)alloc)+wordsize); sc_extobjwords = sc_extobjwords-wordsize; } else if (wordsize < PAGEWORDS) { while (wordsize > sc_extobjwords) { sc_extwaste = sc_extwaste+sc_extobjwords; if (sc_extobjwords) sc_extobjp->unsi.gned = ENDOFPAGE; sc_extobjwords = 0; allocatepage( 1, EXTENDEDTAG ); EVEN_EXTOBJP( tag == DOUBLEFLOATTAG ); ODD_EXTOBJP( isastring ); } alloc = sc_extobjp; sc_extobjwords = sc_extobjwords-wordsize; sc_extobjp = (SCP)(((S2CINT*)alloc)+wordsize); } else { while (wordsize > sc_extobjwords) { sc_extwaste = sc_extwaste+sc_extobjwords; if (sc_extobjwords) sc_extobjp->unsi.gned = ENDOFPAGE; sc_extobjwords = 0; allocatepage( (wordsize+PAGEWORDS-1+isastring)/PAGEWORDS, EXTENDEDTAG ); } ODD_EXTOBJP( isastring ); alloc = sc_extobjp; sc_extobjp = NULL; sc_extobjwords = 0; } alloc->extendedobj.tag = tag; alloc->extendedobj.rest = rest; return( alloc ); } /* Double floating point numbers are constructed by the following function. It is called with a double floating point value and it returns a pointer to the Scheme object with that value. */ #ifdef SPARC extern void sc_set_double( XAL2( int* , double ) ); #define SET_FLOAT_VALUE( scp, val ) sc_set_double(&(scp)->doublefloat.value[0], (val) ) #else #define SET_FLOAT_VALUE( scp, val ) (scp)->doublefloat.value = (val) #endif TSCP sc_makedoublefloat( double value ) { SCP pp; MUTEXON; EVEN_EXTOBJP( 1 ); if (sc_extobjwords >= DOUBLEFLOATSIZE) { pp = sc_extobjp; sc_extobjp = (SCP)(((S2CINT*)sc_extobjp)+DOUBLEFLOATSIZE); sc_extobjwords = sc_extobjwords-DOUBLEFLOATSIZE; pp->unsi.gned = DOUBLEFLOATTAG; } else pp = sc_allocateheap( DOUBLEFLOATSIZE, DOUBLEFLOATTAG, 0 ); SET_FLOAT_VALUE( pp, value ); MUTEXOFF; return( U_T( pp, EXTENDEDTAG ) ); } /* The following function forms a dotted-pair with any two Scheme pointers. It returns a tagged pointer to the pair as its value. */ TSCP sc_cons_v; TSCP sc_cons( TSCP x, TSCP y ) { SCP oconsp; MUTEXON; retry: if (sc_conscnt > 0) { oconsp = sc_consp; sc_consp->pair.car = x; sc_consp->pair.cdr = y; sc_consp = (SCP)(((S2CINT*)sc_consp)+2); sc_conscnt--; MUTEXOFF; return( U_T( oconsp, PAIRTAG ) ); } allocatepage( 1, PAIRTAG ); goto retry; } /* The following boolean is used by the stack tracing code to decide whether a pointer is a TSCP or a C string. */ TSCP sc_schemepointer( TSCP any ) { SCP pp = T_U( any ); if (((S2CUINT)pp >= (S2CUINT)sc_firstheapp && (S2CUINT)pp < (S2CUINT)sc_lastheapp) && S2CPAGE( ADDRESS_PAGE( pp ) )) return TRUEVALUE; else return FALSEVALUE; } /* The following procedure is used to verify that a Scheme data structure is correct. If the structure is correct, it is returned. If it is not correct, then the structure is dumped on the log and #f is returned. */ struct SEEN { struct SEEN* prev; TSCP value; }; struct SEEN* seenp; /* Put a breakpoint on this procedure to catch verification problems */ #ifdef __GNUC__ static void verifyfail() __attribute__((noreturn)); #endif static void verifyfail() { sc_abort(); } TSCP sc_verifyobject( TSCP any ) { S2CINT i; struct SEEN seen, *sp; if ((S2CINT)any & 1) { sp = seenp; while (sp != NULL) { if (sp->value == any) return( any ); sp = sp->prev; } seen.prev = seenp; seenp = &seen; seen.value = any; } switch TSCPTAG( any ) { case FIXNUMTAG: return( any ); case EXTENDEDTAG: if (any == sc_emptyvector || any == sc_emptystring) { seenp = seen.prev; return( any ); } if (sc_schemepointer( any ) == FALSEVALUE) verifyfail(); switch TSCP_EXTENDEDTAG( any ) { case SYMBOLTAG: sc_verifyobject( SYMBOL_NAME( any ) ); sc_verifyobject( SYMBOL_VALUE( any ) ); sc_verifyobject( SYMBOL_PROPERTYLIST( any ) ); seenp = seen.prev; return( any ); case STRINGTAG: seenp = seen.prev; return( any ); case VECTORTAG: for (i = 0; i < VECTOR_LENGTH( any ); i++ ) sc_verifyobject( VECTOR_ELEMENT( any, C_FIXED( i ) ) ); seenp = seen.prev; return( any ); case PROCEDURETAG: sc_verifyobject( PROCEDURE_CLOSURE( any ) ); seenp = seen.prev; return( any ); case CLOSURETAG: sc_verifyobject( CLOSURE_CLOSURE( any ) ); for (i = 0; i < CLOSURE_LENGTH( any ); i++) sc_verifyobject( CLOSURE_VAR( any, i ) ); seenp = seen.prev; return( any ); case CONTINUATIONTAG: seenp = seen.prev; return( any ); case RECORDTAG: sc_verifyobject( RECORD_METHODS( any ) ); for (i = 0; i < RECORD_LENGTH( any ); i++ ) sc_verifyobject( RECORD_ELEMENT( any, C_FIXED( i ) ) ); seenp = seen.prev; return( any ); case DOUBLEFLOATTAG: seenp = seen.prev; return( any ); default: verifyfail(); } case IMMEDIATETAG: if (any == EMPTYLIST || any == FALSEVALUE || any == TRUEVALUE || any == EOFOBJECT || any == UNDEFINED || TSCPIMMEDIATETAG( any ) == CHARACTERTAG) return( any ); verifyfail(); case PAIRTAG: if (sc_schemepointer( any ) == FALSEVALUE) verifyfail(); sc_verifyobject( PAIR_CAR( any ) ); sc_verifyobject( PAIR_CDR( any ) ); seenp = seen.prev; return( any ); default: verifyfail(); } } /* The following function forms a weak dotted-pair with any two Scheme pointers. A weak dotted-pair is a pair that has the property that the CAR of the pair may be set to #F by the garbage collector if it contains the only pointer to an object. */ TSCP sc_weak_2dcons_v; TSCP sc_weak_2dcons( TSCP x, TSCP y ) { TSCP cons, /* cons cell holding x & y */ weak; /* 3 element "weak" string: link, cons, car */ cons = sc_cons( x, y ); weak = MAKE_WEAK; MUTEXON; WEAK_LINK( weak ) = weakconsl; WEAK_CONS( weak ) = cons; WEAK_CAR( weak ) = FALSEVALUE; weakconsl = weak; MUTEXOFF; return( cons ); } scheme2c-2012.10.14/scrt/heap.h000066400000000000000000000404551203736146400156520ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module implements the object storage storage system for SCHEME->C. Unlike most Lisp systems, it is not intended that SCHEME->C provide a "one language" environment divorced from other programming languages. Instead, it is intended that SCHEME->C co-exist with other languages and share their development tools and runtime environment. Nor, is it intended that SCHEME->C have detailed knowledge and intimate control over the hardware. Instead of generating actual instructions, it generates C intermediate language. By adhering to these two design goals, SCHEME->C can be a powerful tool for delivering Lisp based technology to non-Lisp environments. However, these design goals also place some significant constraints on the design of the storage system. For example: 1. The system must tolerate both Scheme and non-Scheme storage and data types. 2. The system will not have any control over register allocation or instruction sequences. 3. In examining register or stack contents, one can make a statement that something is not a pointer, but one cannot say that something is a pointer. At best, one can say that it looks exactly like a pointer. Given these constraints, a conventional "stop-and-copy" garbage collector cannot be used. Instead, a storage allocation method called "mostly-copying" is used (see WRL Research Report 88/2, Compacting Garbage Collection with Ambiguous Roots). In its simplist form, the algorithm works as follows. The heap is divided into pages (which need not be the same size as the processor's page). Objects are allocated entirely within a page, or in a dedicated set of pages. When half the storage in the heap has been allocated, the garbage collector is invoked. Garbage collection is divided into three phases. The first is the a copy phase similar to that of the Minsky-Fenichel-Yochelson-Chaeny-Arnborg collector. Items will be copied from the oldspace (pages in the current generation) to the newspace (pages in the next generation). Indirect pointers to new objects will be placed in the old objects, but pointers to new objects are never stored in new objects. During this phase, the contents of continuations (including the current continuation which is in the registers and the stack) get special processing. Each word in them is examined to see if it might be a pointer. If it is a pointer, then the object that it points to is copied, and the page is marked as locked. Thus at the end of the phase, all accessibile storage has been copied, and all pointers are indirect through the old space. All pages which have items which must be left in place are marked as locked. The next phase is the correction phase which turns all indirect pointers into their correct values. At the end of this phase, all pointers will point to the correct place, but items which were locked will be located in the newspace. The final phase is the copy back phase where items that are locked are copied back from the newspace to their correct position in the locked pages. At this time, locked pages are unlocked and promoted to newspace. At this point, garbage collection is done and the generation number is advanced. As with the classical "stop-and-copy" algorithm, the time used is proportional to the amount of storage retained, rather than the total amount of storage. It needs somewhat more storage as it must retain locked pages, and has duplicate copies of items of locked pages. In order to avoid repeated copying of retained data, the collector implements a generational version of the algorithm. Objects that survive a collection are retained and not moved until more than SCLIMIT of the heap is allocated following a collection. At this point, the entire heap is collected (see WRL Technical Note TN-12, Mostly-Copying Garbage Collection Picks Up Generations and C++). A few simple changes to the previously described algorithm result in a generational collector. Even generation numbers represent retained storage and storage is always allocated out of an odd numbered generation when the user program is executing. During garbage collection, all retained objects in the odd generation are copied into a new even numbered space. During this copy phase, pointers into an object in an even numbered space need not be followed. A total collection is done by changing the space number on all even numbered pages to the current odd generation and then doing a collection. In order for a generational scheme to work, all stores of pointers to new objects in old pages must be detected. This is done by explicit checks in: SET-CAR!, SET-CDR!, VECTOR-SET!, SET!, SET-TOP-LEVEL-VALUE!, PUTPROP, and SCHEME-TSCP-SET!. While at first glance, explicit checks seem a slow way of doing things, the reduction in copying more than makes up for them. The garbage collector may be configured by the user setting any of the following environment variables: name: range: default: action: SCHEAP [1:1000] 4 Number of megabytes to initially allocate for the heap (total). SCMAXHEAP [SCHEAP:1000] heap*5 Number of megabytes to allow the heap to grow to. SCLIMIT [10:45] 40 Cause of total collection of the heap when more than this % of the heap is allocated following a generational collection. SCGCINFO [0:2] 0 C boolean indicating that garbage collection statistics should be printed on stderr. When set to 2, additional debugging information is printed and additional tests are done. Default settings (SCHEAP and SCMAXHEAP may already be defined in options.h) */ #define SCMINHEAP 1 #ifndef SCHEAP #define SCHEAP 8 #endif #ifndef SCMAXHEAP #define SCMAXHEAP 1000 #endif #define MINSCLIMIT 10 #define MAXSCLIMIT 45 #define SCLIMIT 40 /* Page related definitions. The page size is defined as a power of 2, where 2**PAGEPOWER = PAGEBYTES. */ #define PAGEPOWER 9 /* 512 bytes/page */ #define PAGEBYTES (1<> PAGEBIT)) #define ADDRESS_PAGE( adr ) (ADDRESS_PHYPAGE( adr ) - sc_firstphypagem1) #define PAGE_ADDRESS( page ) ((page+sc_firstphypagem1) << PAGEBIT) #define PAGE_PHYPAGE( page ) ((page) +sc_firstphypagem1) #define PHYPAGE_PAGE( phypage ) ((phypage) - sc_firstphypagem1) #define ADDRESS_OFFSET( adr ) (((S2CINT)(adr)) & (PAGEBYTES-1)) #define SEGMENT_PAGE_0( page ) ((page & 127) == 0) /* Each page in the pool has the following flags associated with it: PAGEGENERATION generation number associated with the page. Even numbered generations are objects that survived a garbage collection. Odd numbered generations are where storage is allocated during the execution of the user's program. A zero value indicates that the page is not available for garbage collection. PAGETYPE tag field indicating the type of data stored in the page. It is either PAIRTAG, EXTENDEDTAG, or BIGEXTENDEDTAG. PAGELOCK boolean indicating whether or not the page is locked by the garbage collector. PAGELINK next page (or -1) of the lock list whose head is kept in LOCKLIST, and length in LOCKCNT (only during gc). -or- OKTOSET or ~OKTOSET (-1 or 0) indicating status of a just allocated page (value of INITIALLINK). -or- next page (or -1) of the GENLIST, whose head is kept in GENLIST. This list contains all pages in older generations that might contain a pointer to a newer generation. If this value is non-zero, then it is possible to set pointers in the page without going through sc_setgeneration. Objects which are longer than one page are allocated on an integral number of pages. Pages other than the head are marked with a BIGEXTENDEDTAG in pagetype field to indicate that they are related to the previous page. CURRENT_GENERATION holds the generation number that is presently being allocated. NEXT_GENERATION holds the obvious during garbage collection. N.B.: There may be pages in the range 1 through sc_heappages that are not managed by the garbage collector. This is why the 0 flag is used in PAGEGENERATION. */ extern unsigned char *sc_pagegeneration, *sc_pagetype, *sc_pagelock; extern PAGELINK *sc_pagelink; extern S2CINT sc_initiallink, sc_locklist, sc_genlist, sc_lockcnt, sc_current_generation, sc_next_generation; #define INC_GENERATION( g ) (g + 1) #define NEXTPAGE( page ) ((page==sc_heappages) ? 1 : page+1) #define BIGEXTENDEDTAG 0xFF #define OKTOSET -1 #define NOTOKTOSET 0 #define S2CPAGE( p ) (p > 0 && p <= sc_lastpage && \ sc_pagegeneration[ p ] != 0) #define NOT_S2CPAGE( p ) (p <= 0 || p > sc_lastpage || \ sc_pagegeneration[ p ] == 0) extern S2CINT sc_firstphypagem1, /* first phypage-1 inScheme's heap */ sc_firstphypage, /* first phypage in Scheme's heap */ sc_lastphypage, /* last phypage in Scheme's heap */ sc_firstpage, /* first logical page in heap, = 1 */ sc_lastpage, /* last logical page in heap */ sc_heappages, /* # of pages in the Scheme heap */ sc_limit, /* % of heap allocated after collecton that forces total collection */ sc_freepage, /* Free page index */ sc_maxheappages, /* Maximum # of pages in Scheme heap */ sc_allocatedheappages, /* # of pages currently allocated */ *sc_firstheapp, /* ptr to first word in the heap */ *sc_lastheapp; /* ptr to last word in the heap */ /* In order to speed up allocation of CONS cells, blocks of potential CONS cells are preallocated. CONSP points to the next free cell, and CONSCNT is the number of free cells left. */ extern int sc_conscnt; extern SCP sc_consp; /* In order to speed up allocation of extended objects, EXTOBJWORDS is the number of words available in the current page pointed to by EXTOBJP. EXTWASTE keeps track of the number of words lost because of page alignment problems. When only a part of the page is used, the first unused word is marked with ENDOFPAGE. */ extern S2CINT sc_extobjwords, sc_extwaste; extern SCP sc_extobjp; #define ENDOFPAGE 0xAAAAAAAA /* Some implementations require extended storage always be allocated so that double floating point objects in it are on double S2CINT boundaries (addr mod (sizeof(S2CINT)*2) = 0). This is handled by the following define that is used to force pointer alignment. */ #ifdef DOUBLE_ALIGN #define ODD_EXTOBJP( e ) if ((e) && sc_extobjwords &&\ (sc_extobjwords & 1) == 0) {\ sc_extobjp->unsi.gned = WORDALIGNTAG;\ sc_extobjp = (SCP)(((S2CINT*)sc_extobjp)+1);\ sc_extobjwords = sc_extobjwords-1;\ } #define EVEN_EXTOBJP( e ) if ((e) && sc_extobjwords & 1) {\ sc_extobjp->unsi.gned = WORDALIGNTAG;\ sc_extobjp = (SCP)(((S2CINT*)sc_extobjp)+1);\ sc_extobjwords = sc_extobjwords-1;\ } #endif #ifndef DOUBLE_ALIGN #define ODD_EXTOBJP( e ) #define EVEN_EXTOBJP( e ) #endif /* A running total of garbage collection resource usage in kept in GCRU. Garbage collection statistics are printed on stderr following each collection when SCGCINFO is true (set by the environment variable SCGCINFO, or by the command line flag -scgc, default = 0). */ extern S2CINT sc_gcinfo; extern S2CINT sc_collecting; /* Garbage collection and call-with-current-continuation need to know the base of the stack, i.e. the value of the stack pointer when the stack is empty. It is computed at initialization time and stored in SC_STACKBASE. STACKPTR( x ) sets x to the address of the current top of stack (defined in objects.h as it needs to be inlined in compiled code). */ extern S2CINT *sc_stackbase; /* # of bytes to reserve in user supplied stack for handling stack overflow, garbage collection, etc. N.B. This number is subject to change. */ #define STACKFUDGE 1500 /* Some objects require cleanup actions when they are freed. For example, when a file port is recovered, the corresponding file needs to be closed. Such objects are noted by the procedure (WHEN-UNREFERENCED object action), where object is any Scheme object and action is either #F indicating that nothing should be done, or a procedure that takes one argument. When a procedure is supplied, it will be called when a garbage collection occurs and there are no references to that object. In order to implement this function, the runtime system will keep two alists, SC_WHENFREED and SC_FREED. The first list is those items requiring cleanup when they become free, and the second list is those items freed that require cleanup now. */ extern TSCP sc_whenfreed, sc_freed; /* A Scheme program can register a callback with the garbage collector that will be called following each collection. This is done by setting the value of AFTER-COLLECT to a procedure that takes three arguments: the heap size in bytes, the current allocation in bytes, and the percent of allocation that will force a total collection. */ extern TSCP sc_after_2dcollect_v; /* Objects on the *FROZEN-OBJECTS* list are never moved by the garbage collector. User programs can use this to "lock" objects that are passed to other languages. */ extern TSCP sc__2afrozen_2dobjects_2a_v; /* The garbage collector also keeps track of processor time used. The following values record processor time consumption in seconds. */ extern double sc_usertime, /* Time spent doing Scheme */ sc_idletime, /* Time spent outside Scheme */ sc_gctime; /* Time spent collecting */ /* The procedural interfaces to this module are: */ extern double sc_stoptimer( XAL1( double* ) ); extern S2CINT *sc_processor_register( XAL1( S2CINT ) ); extern void sc_apply_when_unreferenced(); extern TSCP sc_collect_v; extern TSCP sc_collect(); extern TSCP sc_collect_2dall_v; extern TSCP sc_collect_2dall(); extern TSCP sc_collect_2dinfo_v; extern TSCP sc_collect_2dinfo(); extern TSCP sc_set_2dgcinfo_21_v; extern TSCP sc_set_2dgcinfo_21( XAL1( TSCP ) ); extern TSCP sc_2dlimit_21_de4d3427_v; extern TSCP sc_2dlimit_21_de4d3427( XAL1( TSCP ) ); extern TSCP sc_set_2dmaximum_2dheap_21_v; extern TSCP sc_set_2dmaximum_2dheap_21( XAL1( TSCP ) ); extern TSCP sc_setgeneration( XAL2( TSCP *, TSCP ) ); extern SCP sc_allocateheap( XAL3( S2CINT, S2CINT, S2CINT ) ); extern TSCP sc_makedoublefloat( XAL1( double ) ); extern TSCP sc_cons_v; extern TSCP sc_cons( XAL2( TSCP, TSCP ) ); extern TSCP sc_verifyobject( XAL1( TSCP ) ); extern TSCP sc_weak_2dcons_v; extern TSCP sc_weak_2dcons( XAL2( TSCP, TSCP ) ); scheme2c-2012.10.14/scrt/makefile000066400000000000000000000115141203736146400162560ustar00rootroot00000000000000# # This file is used to compile the runtime library for SCHEME->C. # # Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. # All Rights Reserved # Permission is hereby granted, free of charge, to any person obtaining a # copy of this software and associated documentation files (the "Software"), # to deal in the Software without restriction, including without limitation # the rights to use, copy, modify, merge, publish, distribute, sublicense, # and/or sell copies of the Software, and to permit persons to whom the # Software is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER # DEALINGS IN THE SOFTWARE. # # all: prefix=/usr/local LIBDIR=${prefix}/lib BINDIR=${prefix}/bin ## previously value was LIBSUBDIR = schemetoc LIBSUBDIR = scheme2c INSTALL = install INSTALL_DATA = ${INSTALL} -m 644 INSTALL_PROGRAM = ${INSTALL} INSTALL_SCRIPT = ${INSTALL} .SUFFIXES: .SUFFIXES: .o .c .sc .s SCC = ../scsc/Xs2cc SCCFLAGS = SRCDIR = ../../scrt Cruntime = scinit.o apply.o callcc.o cio.o heap.o objects.o mtraps.o Cruntimec = scinit.c apply.c callcc.c cio.c heap.c objects.c mtraps.c Chfiles = scinit.h apply.h callcc.h cio.h heap.h objects.h options.h Sruntime = scdebug.o sceval.o scexpand.o scexpnd1.o scexpnd2.o \ scqquote.o screp.o \ scrt1.o scrt2.o scrt3.o scrt4.o scrt5.o scrt6.o scrt7.o scrtuser.o Sruntimec = scdebug.c sceval.c scexpand.c scexpnd1.c scexpnd2.c \ scqquote.c screp.c \ scrt1.c scrt2.c scrt3.c scrt4.c scrt5.c scrt6.c scrt7.c scrtuser.c Sruntimesc = scdebug.sc sceval.sc scexpand.sc scexpnd1.sc scexpnd2.sc \ scqquote.sc screp.sc \ scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc \ scrtuser.sc Smisc = embedded.c predef.sc repdef.sc sci.sc sci.c ${Sruntimec} sci.c: predef.sc ${Sruntime} sci.o: options.h objects.h ${Cruntime}: ${Chfiles} .sc.c: ${SCC} -C ${SCCFLAGS} $*.sc .c.o: ${CC} -c ${CFLAGS} -I. $*.c .s.o: ${CC} -c ${CFLAGS} $*.s sc-to-c: ${Sruntimec} sci.c c-to-o: ${Sruntimec} ${Sruntime} ${Cruntime} s-to-o: ${Aruntime} Xlibs2c.a: ${Sruntimec} ${Sruntime} ${Cruntime} ${Aruntime} rm -f Xlibs2c.a ar q Xlibs2c.a ${Cruntime} ${Sruntime} ${Aruntime} ${RANLIB} Xlibs2c.a libs2csrv.a: Xlibs2c.a mv Xlibs2c.a libs2csrv.a embedded: ${Sruntimec} ${Sruntime} ${Cruntime} ${Aruntime} \ embedded.o ${CC} -o embedded ${CFLAGS} ${Sruntime} ${Cruntime} ${Aruntime} \ embedded.o -lm ${LDFLAGS} Xs2ci: ${Sruntimec} ${Sruntime} ${Cruntime} ${Aruntime} \ sci.c sci.o ${CC} -o Xs2ci ${CFLAGS} ${Sruntime} ${Cruntime} ${Aruntime} sci.o \ -lm ${LDFLAGS} Xmv: Xs2ci Xlibs2c.a mv Xs2ci s2ci mv Xlibs2c.a libs2c.a port: $(MAKE) "CC=${CC}" "CFLAGS=${CFLAGS}" "SCC=echo" \ Xlibs2c.a Xs2ci Xmv ${Plib} libs2c_p.a: libs2c.a mkdir -p saveobj mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj/ rm -f libs2c_p.a $(MAKE) "CC=${CC}" "CFLAGS=${CFLAGS} -pg" ${Sruntime} ${Cruntime} \ ${Aruntime} ar q libs2c_p.a ${Cruntime} ${Sruntime} ${Aruntime} ${RANLIB} libs2c_p.a mv saveobj/* ./ rmdir saveobj install: ${INSTALL} -d ${DESTDIR}${LIBDIR}/${LIBSUBDIR} ${INSTALL_DATA} libs2c.a ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ ln -sf libs2c.a ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/libsc.a -${INSTALL_DATA} libs2c_p.a ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ \ && ln -sf libs2c_p.a ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/libsc_p.a ${INSTALL_DATA} objects.h ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ ${INSTALL_DATA} options.h ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ ${INSTALL_DATA} predef.sc ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ ${INSTALL} -d ${DESTDIR}${BINDIR} ${INSTALL_PROGRAM} s2ci ${DESTDIR}${BINDIR}/ ln -sf s2ci ${DESTDIR}${BINDIR}/sci clean: rm -f ${Sruntime} ${Cruntime} ${Aruntime} sci.o embedded.o \ *.CKP *.BAK *.S2C core Xs2ci Xlibs2c.a clean-sc-to-c: rm -f ${Sruntimec} sci.c noprogs: rm -f Xs2ci Xlibs2c.a s2ci libs2c.a libs2c_p.a embedded libs2csrv.a srcdist: rdist -c README *.c *.h *.s *.sc makefile ${destdir} bindist: rdist -c README makefile makefile-tail predef.sc objects.h \ libs2c.a ${Plib} s2ci ${destdir} all: $(MAKE) "CC=${CC}" "CFLAGS=${CFLAGS}" "SCC=${SCC}" \ "SCCFLAGS=${SCCFLAGS}" Xlibs2c.a Xs2ci Xmv ${Plib} srclinks: for x in ${Cruntimec} ${Chfiles} ${Sruntimec} ${Sruntimesc} ${Smisc}; \ do ln -s ${SRCDIR}/$$x $$x;\ done rm options.h scheme2c-2012.10.14/scrt/mtraps.c000066400000000000000000000170321203736146400162310ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ #if MATHTRAPS #include "objects.h" #include "heap.h" #include "apply.h" #include "/usr/include/signal.h" #ifdef MIPS #ifdef BIGMIPS #include #include #else #include #include #endif #endif /* Arithmetic traps are handled by the following machine dependent code. Overflow on exact computation results in the correct, but inexact result being returned. All other arithmetic traps are considered to be errors. */ static void emulate_branch(); /* sc_trap_handler is a generalized fault handler for TRAP and FLOATING POINT exceptions. */ sc_trap_handler (sig,code,scp) int sig, code; struct sigcontext *scp; { #ifdef MIPS unsigned long opcode, func, rs, rt, rd; union mips_instruction branch_inst, exception_inst; #endif /********************************** Unrecoverable exceptions **********************************/ #ifdef MIPS if (sig == SIGTRAP) { if (code == BRK_DIVZERO) /***** divide by zero exception ****/ sc_error ( "?????", "Divide by zero", EMPTYLIST ); else if (code == BRK_OVERFLOW) /** overflow check **/ sc_error ( "????", "Overflow", EMPTYLIST ); else if (code == BRK_RANGE) /** range error check **/ sc_error ( "????", "Out of range", EMPTYLIST ); else /** other misc types of bpt errors */ sc_error ( "????", "Break point or branch error", EMPTYLIST ); } #endif #ifdef VAX 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", EMPTYLIST ); if (code == FPE_FLTOVF_TRAP || code == FPE_FLTOVF_FAULT) /***** floating point overflow *****/ sc_error ( "?????", "Overflow", EMPTYLIST ); if (code == FPE_FLTUND_FAULT || code == FPE_FLTUND_TRAP) /***** floating point underflow *****/ sc_error ( "?????", "Underflow", EMPTYLIST ); sc_error ("?????", "Floating point exception: %s", LIST1( C_FIXED( code ) ) ); } #endif /*************************************** other possibly recoverable exceptions ***************************************/ #ifdef MIPS if (scp->sc_cause & CAUSE_BD) { branch_inst.word = *(unsigned long *) scp->sc_pc ; exception_inst.word = *(unsigned long *) (scp->sc_pc + 4); /* printf ("it was a branch delay.\n"); */ } else { exception_inst.word = *(unsigned long *) (scp->sc_pc); /* printf ("it wasn't a branch delay.\n"); */ } opcode = exception_inst.j_format.opcode; /* get opcode field */ switch (opcode) { case spec_op: func = exception_inst.r_format.func; /* get function field */ switch (func) { case add_op: if (sig == SIGFPE && code == EXC_OV) { /**** integer add overflow ***/ rs = exception_inst.r_format.rs; rt = exception_inst.r_format.rt; rd = exception_inst.r_format.rd; scp->sc_regs[rd] = (unsigned int) FLTV_FLT( (double) FIXED_C(scp->sc_regs[rs]) + (double) FIXED_C(scp->sc_regs[rt]) ); if (scp->sc_cause & CAUSE_BD) emulate_branch(scp, branch_inst); else scp->sc_pc += 4; } else sc_error ("+", "unknown floating point exception code", 0); break; case sub_op: if (sig == SIGFPE && code == EXC_OV) { /**** integer sub overflow ****/ rs = exception_inst.r_format.rs; rt = exception_inst.r_format.rt; rd = exception_inst.r_format.rd; scp->sc_regs[rd] = (unsigned int) FLTV_FLT( (double) FIXED_C(scp->sc_regs[rs]) - (double) FIXED_C(scp->sc_regs[rt]) ); if (scp->sc_cause & CAUSE_BD) emulate_branch(scp, branch_inst); else scp->sc_pc += 4; } else sc_error ("-", "Unknown floating point exception code", 0); break; default: sc_error ("UNKNOWN", "Other instructions of type special not decoded",0); break; } /* close switch (func) */ break; case bcond_op: sc_error ("sc_trap_handler", "BCOND op decoded", 0); break; case j_op: sc_error ("sc_trap_handler", "J op decoded", 0); break; case jal_op: sc_error ("sc_trap_handler", "JAL op decoded",0); break; default: sc_error ("sc_trap_handler", "Other opcodes not decoded", 0); break; } #endif } /* emulate_branch modifies the value of the program counter in the signal context structure (sc_pc) to the target of the branch instruction. */ #ifdef MIPS static void emulate_branch(scp, branch_inst) struct sigcontext *scp; union mips_instruction branch_inst; { unsigned long target = branch_inst.j_format.target, opcode = branch_inst.j_format.opcode, pc = *(unsigned long *) scp->sc_pc, func, rs; /*********************************************** note: the current implementation only takes care of jr and j branch instructions. Other cases can be added as need arises. ***********************************************/ switch (opcode) { case spec_op: func = branch_inst.r_format.func; /* get function field */ rs = branch_inst.r_format.rs; /* reg with branch addr */ switch (func) { case jr_op: /**** branch instruction is jump register ****/ /* set program counter to be target of * * branch instruction. * * */ scp->sc_pc = scp->sc_regs[rs]; break; case jalr_op: sc_error ("emulate_branch", "Branch instruction is JALR", 0); break; default: sc_error ("emulate_branch", "Special inst not decoded", 0); break; } break; case j_op: /**** jump instruction ****/ /* new pc is calculated by left shifting target field 2 bits and combining result with high 4 bits of current pc */ target = target<<2; scp->sc_pc = (unsigned long) ((pc & 036000000000) | target); break; case jal_op: sc_error ("emulate_branch", "Branch instruction is jal", 0); break; default: sc_error ("emulate_branch", "Instruction not decoded", 0); break; } } #endif #endif /* The following function is called during initialization to enable the arithmetic trap handlers. */ void sc_arm_mathtraps() { #if MATHTRAPS signal(SIGFPE, sc_trap_handler); #if MIPS signal(SIGTRAP, sc_trap_handler); #endif #endif } scheme2c-2012.10.14/scrt/objects.c000066400000000000000000000454561203736146400163670ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module implements the object storage allocation functions. */ /* Imported definitions */ #include "objects.h" #include "scinit.h" #include "heap.h" #include "apply.h" #include "cio.h" #include #ifndef NULL #define NULL 0 #endif extern TSCP scrt1_reverse( XAL1( TSCP ) ); /* Allocate storage for objects defined in objects.h */ TSCP sc_obarray; /* OBARRAY for symbols */ struct SCPTRS *sc_constants; /* Table of compile time constant addresses */ struct SCPTRS *sc_globals; /* Table of top level variable addresses */ S2CINT sc_maxdisplay = 0; /* The DISPLAY */ TSCP sc_display[ 200 ]; TSCP sc_emptylist, /* Immediate denoting empty list */ sc_emptystring, /* Pointer to the empty string */ sc_emptyvector, /* Pointer to the empty vector */ sc_falsevalue, /* Immediate denoting false */ sc_truevalue, /* Immediate denoting true */ sc_eofobject, /* Immediate denoting end-of-file */ sc_undefined; /* Immediate denoting the undefined value */ struct STACKTRACE *sc_stacktrace; /* Ptr to debug stack trace records */ S2CINT sc_schememode = STANDALONESCHEME; #define CSTRING_SYMBOL( x ) sc_string_2d_3esymbol( CSTRING_TSCP( x ) ) /* Entries are added to SCPTRS structures by the following procedure. It is called with a pointer to the structure and a value to add. It returns the pointer to the expanded structure. */ struct SCPTRS *addtoSCPTRS( s, p ) struct SCPTRS *s; TSCP *p; { struct SCPTRS *t; S2CINT i; MUTEXON; if (s == NULL) { /* Initially allocate the table */ s = (struct SCPTRS *)sc_gettable( sizeofSCPTRS( 500 ), 1 ); s->count = 0; s->limit = 500; } else if (s->count == s->limit) { /* Expand the table */ t = (struct SCPTRS *)sc_gettable( sizeofSCPTRS( s->limit+100 ), 1 ); for (i = 0; i < s->count; i++) { t->ptrs[ i ] = s->ptrs[ i ]; } t->limit = s->limit+100; t->count = s->count; sc_freetable( s ); s = t; } s->ptrs[ s->count++ ] = p; MUTEXOFF; return( s ); } /* Entries are deleted from an SCPTRS structure by the following procedure. It is called with a pointer to the structure and a value to delete. */ void deletefromSCPTRS( s, p ) struct SCPTRS *s; TSCP *p; { S2CINT i; MUTEXON; for (i = s->count-1; i >= 0; i--) { if (s->ptrs[ i ] == p) { while (i < s->count-2) { s->ptrs[ i ] = s->ptrs[ i+1 ]; i++; } s->count = s->count-1; i = -1; } } MUTEXOFF; } /* Strings are allocated by the following function which takes a length (as a tsfixed value), and a char initialization value. It will return a Scheme pointer to the new string. The strings will be null terminated in order to be compatible with C strings. This function is visible as MAKE-STRING inside Scheme. */ TSCP sc_make_2dstring_v; TSCP sc_make_2dstring( length, initial ) TSCP length, initial; { S2CINT len, x; char initchar, *cp; SCP sp; len = FIXED_C( length ); if ((TSCPTAG( length ) != FIXNUMTAG) || len < 0 || len > MAXSTRINGSIZE) sc_error( "MAKE-STRING", "Argument is not a POSITIVE INTEGER <= ~s", LIST1( C_FIXED( MAXSTRINGSIZE ) ) ); if (len == 0) return( sc_emptystring ); if (initial != EMPTYLIST) { initial = T_U( initial )->pair.car; if (TSCPIMMEDIATETAG( initial ) != CHARACTERTAG) sc_error( "MAKE-STRING", "Argument is not a CHARACTER", EMPTYLIST ); initchar = CHAR_C( initial ); } MUTEXON; sp = sc_allocateheap( STRINGSIZE( len ), STRINGTAG, len ); cp = &sp->string.char0; if (initial != EMPTYLIST) { x = len; while (x--) *cp++ = initchar; } else cp = cp+len; /* Null bytes in rest of last word */ x = sizeof(S2CINT)-(len & (sizeof(S2CINT)-1)); while (x--) *cp++ = 0; MUTEXOFF; return( U_T( sp, EXTENDEDTAG ) ); } /* A copy of a string is made by the following procedure. It is available inside Scheme as STRING-COPY. */ TSCP sc_string_2dcopy_v; TSCP sc_string_2dcopy( string ) TSCP string; { SCP ustring, newstring; S2CINT words, *from, *to; ustring = T_U( string ); if ((TSCPTAG( string ) != EXTENDEDTAG) || ustring->string.tag != STRINGTAG) sc_error( "STRING-COPY", "Argument is not a STRING", EMPTYLIST ); if (string == sc_emptystring) return( string ); words = STRINGSIZE( ustring->string.length ); MUTEXON; newstring = sc_allocateheap( words, 0, 0 ); from = (S2CINT *)ustring; to = (S2CINT *)newstring; while (words--) *to++ = *from++; MUTEXOFF; return( U_T( newstring, EXTENDEDTAG ) ); } /* C strings are converted to heap allocated Scheme strings by the following function. */ TSCP sc_cstringtostring( char* cstring ) { S2CINT len, x; char *cp; SCP sp; len = 0; cp = cstring; if (cp) while (*cp++) len++; if (len == 0) return( sc_emptystring ); MUTEXON; sp = sc_allocateheap( STRINGSIZE( len ), STRINGTAG, len ); cp = &sp->string.char0; x = len; while (x--) *cp++ = *cstring++; /* Null bytes in rest of last word */ x = sizeof(S2CINT)-(len & (sizeof(S2CINT)-1)); while (x--) *cp++ = 0; MUTEXOFF; return( U_T( sp, EXTENDEDTAG ) ); } TSCP sc_c_2dstring_2d_3estring_v; TSCP sc_c_2dstring_2d_3estring( TSCP cstring ) { return( sc_cstringtostring( (char*)TSCP_POINTER( cstring ) ) ); } /* Vectors are allocated by the following functions which takes a length (as a tsfixed value), and an initialization value. It will return a Scheme pointer to the new vector. It has the name MAKE-VECTOR in Scheme. */ TSCP sc_make_2dvector_v; TSCP sc_make_2dvector( length, initial ) TSCP length, initial; { S2CINT len; SCP vp; PATSCP ve; len = FIXED_C( length ); if ((TSCPTAG( length ) != FIXNUMTAG) || len < 0 || len > MAXVECTORSIZE) sc_error( "MAKE-VECTOR", "Argument is not a POSITIVE INTEGER <= ~s", LIST1( C_FIXED( MAXVECTORSIZE ) ) ); if (len == 0) return( sc_emptyvector ); MUTEXON; vp = sc_allocateheap( VECTORSIZE( len ), VECTORTAG, len ); ve = &vp->vector.element0; if (initial != EMPTYLIST) initial = T_U( initial )->pair.car; while (len--) *ve++ = initial; MUTEXOFF; return( U_T( vp, EXTENDEDTAG ) ); } /* Closures are constructed by the following function. It takes a previous closure pointer, a closure size, and the values to be closed. It returns a Scheme pointer to the closure. It is used by compiled code to heap allocate variables and is visible within the compiler as MAKECLOSURE. */ TSCP sc_makeclosure( TSCP prevclosure, ... ) { va_list argl; int count; SCP cp; PATSCP vars; MUTEXON; va_start( argl, prevclosure ); count = va_arg( argl, int ); cp = sc_allocateheap( CLOSURESIZE( count ), CLOSURETAG, count ); cp->closure.closure = prevclosure; vars = &cp->closure.var0; while (count--) *vars++ = va_arg( argl, TSCP ); MUTEXOFF; return( U_T( cp, EXTENDEDTAG ) ); } /* Records are constructed by the following function. It takes a size and an optional initial value It returns the resulting record with all elements set to the initial value (or ()) and a null list of methods. It has the name MAKE-%RECORD in Scheme. */ TSCP sc_make_2d_25record_v; TSCP sc_make_2d_25record( length, initial ) TSCP length, initial; { S2CINT len; SCP rp; PATSCP re; len = FIXED_C( length ); if ((TSCPTAG( length ) != FIXNUMTAG) || len < 0 || len > MAXRECORDSIZE) sc_error( "MAKE-%RECORD", "Argument is not a POSITIVE INTEGER <= ~s", LIST1( C_FIXED( MAXRECORDSIZE ) ) ); MUTEXON; rp = sc_allocateheap( RECORDSIZE( len ), RECORDTAG, len ); rp->record.methods = EMPTYLIST; re = &rp->record.element0; if (initial != EMPTYLIST) initial = T_U( initial )->pair.car; while (len--) *re++ = initial; MUTEXOFF; return( U_T( rp, EXTENDEDTAG ) ); } /* Procedure objects are constructed by the following function. It takes the required variable count, the optvars flag, the function, and the current closure. It returns a Scheme pointer to the procedure. It is used by compiled code to make the value of a (LAMBDA (...) ...) expression. It is visible within the compiler as MAKEPROCEDURE. */ TSCP sc_makeprocedure( reqvars, optvars, function, closure ) int reqvars, optvars; TSCP closure; TSCPP function; { SCP pp; if (reqvars > MAXARGS) sc_error( "MAKEPROCEDURE", "PROCEDURE requires too many arguments", EMPTYLIST ); if (optvars) reqvars = reqvars+256; MUTEXON; pp = sc_allocateheap( PROCEDURESIZE, PROCEDURETAG, reqvars ); pp->procedure.code = function; pp->procedure.closure = closure; MUTEXOFF; return( U_T( pp, EXTENDEDTAG ) ); } /* Compiled global variables are "registered" by this function. It will add them to the symbol table (sc_obarray) and set their initial values. The function is visible within the compiler as INITIALIZEVAR. */ void sc_initializevar( symbolname, location, value ) char *symbolname; TSCP *location, value; { SCP sp; sp = T_U( sc_string_2d_3esymbol( CSTRING_TSCP( symbolname ) ) ); if (*sp->symbol.ptrtovalue != UNDEFINED) { sc_log_string( "***** INITIALIZEVAR Duplicately defined symbol " ); sc_log_string( &(T_U(sp->symbol.name)->string.char0) ); sc_log_string( "\n" ); } sp->symbol.ptrtovalue = location; *location = value; sc_globals = addtoSCPTRS( sc_globals, location ); } /* Global TSCP's declared in languages other than Scheme are registered with the garbage collector by the following function. N.B. The garbage collector may reloacte objects pointed to by these cells. */ void sc_global_TSCP( location ) TSCP *location; { sc_globals = addtoSCPTRS( sc_globals, location ); } /* Global TSCP's declared in languages other than Scheme my be unregistered by calling the following procedure. */ void sc_delete_global_TSCP( location ) TSCP *location; { deletefromSCPTRS( sc_globals, location ); } /* Compiled constants which are constructed from the heap during initialization must be "registered" with the runtime system so that they will not be treated as garbage. This function is visible as CONSTANTEXP within the compiler. */ void sc_constantexp( constantaddress ) TSCP *constantaddress; { sc_constants = addtoSCPTRS( sc_constants, constantaddress ); } /* Strings are converted to symbols by the following function. It will examine the obarray to see if an identifier with the same name already exists. If it does then it will return a pointer to that symbol. If not then it will either add the symbol to the table or return #F as determined by the value of add. */ static TSCP stringtosymbol( symbolstring, add ) TSCP symbolstring, add; { TSCP tp, cell; SCP sp, utp; S2CFINT x, *oldp, *newp, *endnewp; PATSCP buckets; newp = (S2CFINT *)T_U( symbolstring ); endnewp = newp+(T_U( symbolstring )->string.length+sizeof(S2CFINT))/ sizeof(S2CINT); x = 0; do x = x ^ *newp; while (newp++ != endnewp); #ifndef SPARC if (x < 0) x = -x; #endif x = x % T_U( sc_obarray )->vector.length; buckets = &T_U( sc_obarray )->vector.element0; tp = buckets[ x ]; while (tp != EMPTYLIST) { utp = T_U( tp ); oldp = (S2CFINT *)(T_U( T_U( utp->pair.car )->symbol.name )); newp = (S2CFINT *)(T_U( symbolstring )); while (*oldp++ == *newp) if (newp++ == endnewp) return( utp->pair.car ); tp = utp->pair.cdr; } if ((add == EMPTYLIST) || (add == FALSEVALUE)) return( FALSEVALUE ); cell = sc_cons( EMPTYLIST, EMPTYLIST ); symbolstring = sc_string_2dcopy( symbolstring ); MUTEXON; sp = sc_allocateheap( SYMBOLSIZE, SYMBOLTAG, 0 ); sp->symbol.name = symbolstring; sp->symbol.ptrtovalue = &sp->symbol.value; sp->symbol.value = UNDEFINED; sp->symbol.propertylist = EMPTYLIST; PAIR_CAR( cell ) = U_T( sp, EXTENDEDTAG ); PAIR_CDR( cell ) = buckets[ x ]; sc_setgeneration( &buckets[ x ], cell ); MUTEXOFF; return( U_T( sp, EXTENDEDTAG ) ); } /* The following function implements STRING->SYMBOL. */ TSCP sc_string_2d_3esymbol_v; TSCP sc_string_2d_3esymbol( symbolstring ) TSCP symbolstring; { if ((TSCPTAG( symbolstring ) != EXTENDEDTAG) || (T_U( symbolstring )->string.tag != STRINGTAG)) sc_error( "STRING->SYMBOL", "Argument is not a STRING", EMPTYLIST ); return( stringtosymbol( symbolstring, TRUEVALUE ) ); } /* The following function implements STRING->UNINTERNED-SYMBOL. */ TSCP sc_d_2dsymbol_ab4b4447_v; TSCP sc_d_2dsymbol_ab4b4447( symbolstring ) TSCP symbolstring; { SCP sp; if ((TSCPTAG( symbolstring ) != EXTENDEDTAG) || (T_U( symbolstring )->string.tag != STRINGTAG)) sc_error( "STRING->UNINTERNED-SYMBOL?", "Argument is not a STRING", EMPTYLIST ); symbolstring = sc_string_2dcopy( symbolstring ); MUTEXON; sp = sc_allocateheap( SYMBOLSIZE, SYMBOLTAG, 0 ); sp->symbol.name = symbolstring; sp->symbol.ptrtovalue = &sp->symbol.value; sp->symbol.value = UNDEFINED; sp->symbol.propertylist = EMPTYLIST; MUTEXOFF; return( U_T( sp, EXTENDEDTAG ) ); } /* The following function implements UNINTERNED-SYMBOL?. */ TSCP sc_uninterned_2dsymbol_3f_v; TSCP sc_uninterned_2dsymbol_3f( symbol ) TSCP symbol; { if ((TSCPTAG( symbol ) != EXTENDEDTAG) || (T_U( symbol )->symbol.tag != SYMBOLTAG)) sc_error( "UNINTERNED-SYMBOL?", "Argument is not a SYMBOL", EMPTYLIST ); return ( (stringtosymbol( T_U( symbol )->symbol.name, FALSEVALUE ) == symbol) ? FALSEVALUE : TRUEVALUE ); } /* Argument conversion for calling C external procedures is provided by the following functions. A character is converted to a C character by the following function. */ char sc_tscp_char( p ) TSCP p; { if (TSCPIMMEDIATETAG( p ) != CHARACTERTAG) sc_error( "TSCP_CHAR", "Argument is not a CHARACTER: ~s", LIST1( p ) ); return( CHAR_C( p ) ); } /* The a fixed integer or a floating point number is converted to an integer. by the following function. */ S2CINT sc_tscp_s2cint( p ) TSCP p; { switch TSCPTAG( p ) { case FIXNUMTAG: return( FIXED_C( p ) ); break; case EXTENDEDTAG: if (TX_U( p )->extendedobj.tag == DOUBLEFLOATTAG) return( (S2CINT) FLOAT_VALUE( p ) ); break; } sc_error( "TSCP_S2CINT", "Argument cannot be converted to C int", EMPTYLIST ); } /* The a fixed integer or a floating point number is converted to an unsigned integer by the following function. The special case testing is present as many C compilers do not correctly cast double <-> unsigned. */ S2CUINT sc_tscp_s2cuint( p ) TSCP p; { double v; switch TSCPTAG( p ) { case FIXNUMTAG: return( (S2CUINT)FIXED_C( p ) ); break; case EXTENDEDTAG: if (TX_U( p )->extendedobj.tag == DOUBLEFLOATTAG) { v = FLOAT_VALUE( p ); if (v <= MAXS2CINTF) return( (S2CUINT)( v ) ); else return( (S2CUINT)( v-MSBS2CUINTF ) | MSBS2CUINT ); } break; } sc_error( "TSCP_S2CUINT", "Argument cannot be converted to C unsigned", EMPTYLIST ); } /* Numbers, strings, and procedures are converted to C pointers by the following function. */ VOIDP sc_tscp_pointer( p ) TSCP p; { SCP s; double v; switch TSCPTAG( p ) { case FIXNUMTAG: return( (void*)((S2CUINT)FIXED_C( p )) ); break; case EXTENDEDTAG: s = T_U( p ); switch (s->extendedobj.tag) { case STRINGTAG: return( (void*)&s->string.char0 ); break; case PROCEDURETAG: return( (void*)sc_procedureaddress( p ) ); break; case DOUBLEFLOATTAG: v = FLOAT_VALUE( p ); if (v <= MAXS2CINTF) return( (void*)((S2CUINT)( v )) ); else return( (void*)((S2CUINT)(v-MSBS2CUINTF) | MSBS2CUINT) ); break; } break; } sc_error( "TSCP_POINTER", "Argument cannot be converted to C pointer", EMPTYLIST ); } /* The following function produces a double value from a Scheme pointer. */ double sc_tscp_double( p ) TSCP p; { switch TSCPTAG( p ) { case FIXNUMTAG: return( (double)(FIXED_C( p )) ); break; case EXTENDEDTAG: if (TX_U( p )->extendedobj.tag == DOUBLEFLOATTAG) return( FLOAT_VALUE( p ) ); break; } sc_error( "TSCP_DOUBLE", "Argument cannot be converted to C double", EMPTYLIST ); } /* The following function converts an integer returned by C into either a fixed or float value. */ TSCP sc_s2cint_tscp( n ) S2CINT n; { if (n <= MAXTSCPINT && n >= MINTSCPINT) return( C_FIXED( n ) ); return( MAKEFLOAT( (double)n ) ); } /* The following function converts an unsigned returned by C into either a fixed or float value. The special case testing is present as many C compilers do not correctly cast double <-> unsigned. */ TSCP sc_s2cuint_tscp( n ) S2CUINT n; { if (n <= MAXTSCPINT) return( C_FIXED( n ) ); if (n & MSBS2CUINT) return( MAKEFLOAT( (double)(n ^ MSBS2CUINT)+MSBS2CUINTF ) ); return( MAKEFLOAT( (double)n ) ); } /* The address of a procedure is returned by the following function. */ S2CUINT sc_procedureaddress( pp ) TSCP pp; { return( (S2CUINT)(TX_U( pp )->procedure.code) ); } /* The following procedure is called to return the process's Scheme execution mode: EMBEDDED INTERACTIVE STAND-ALONE */ TSCP sc_scheme_2dmode() { switch (sc_schememode) { case STANDALONESCHEME: return( CSTRING_SYMBOL( "STAND-ALONE" ) ); case EMBEDDEDSCHEME: return( CSTRING_SYMBOL( "EMBEDDED" ) ); case INTERACTIVESCHEME: return( CSTRING_SYMBOL( "INTERACTIVE" ) ); default: sc_error( "SCHEME_MODE", "selected mode unknown", EMPTYLIST ); } } /* The following procedure is called to set the Scheme execution mode. */ TSCP sc_set_2dscheme_2dmode_21( TSCP mode ) { if (mode == CSTRING_SYMBOL( "STAND-ALONE" )) sc_schememode = STANDALONESCHEME; else if (mode == CSTRING_SYMBOL( "EMBEDDED" )) sc_schememode = EMBEDDEDSCHEME; else sc_schememode = INTERACTIVESCHEME; return( mode ); } scheme2c-2012.10.14/scrt/objects.h000066400000000000000000001154701203736146400163660ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module defines basic data objects and their associated functions. */ /* Specific runtime system options are found in options.h */ #include "options.h" /* Once the system dependent types have been defined, other system dependent constants can be derived from them. */ #define S2CINTBITS (sizeof(S2CINT)*8) /* # of bits in an S2CINT */ #define MAXTSCPINT ((1L<<(S2CINTBITS-3))-1L) /* Maximum fixed integer */ #define MAXTSCPINTF ((double)MAXTSCPINT) /* its double value */ #define MINTSCPINT (-(1L<<(S2CINTBITS-3))) /* Minimum fixed integer */ #define MINTSCPINTF ((double)MINTSCPINT) /* its double value */ #define MSBS2CUINTF (((double)MAXS2CINT)+1.0) /* Dbl value of MSBS2CUINT */ #define MAXS2CINTF ((double)(MAXS2CINT)) /* Dbl value of MAXS2CINT */ /* If BIGENDIAN is defined, then architecture is big endian, otherwise it is little endian. S2CUINT_FIELDSx defines bit fields in pointer size words from least signigicant to most significant bits. */ #ifdef BIGENDIAN #define S2CUINT_FIELDS2( a, b ) S2CUINT b; S2CUINT a #define S2CUINT_FIELDS3( a, b, c ) S2CUINT c; S2CUINT b; S2CUINT a #else #define S2CUINT_FIELDS2( a, b ) S2CUINT a; S2CUINT b #define S2CUINT_FIELDS3( a, b, c ) S2CUINT a; S2CUINT b; S2CUINT c #endif #ifdef SPARC #define S2CFINT S2CUINT #else #define S2CFINT S2CINT #endif /* Define the type VOIDP which is either void* or char*. */ typedef void *VOIDP; /* The data encoding scheme is similar to that used by Vax NIL and T, where all objects are represented by S2CINT size pointers, with a "low tag" encoded in the two least significant bits encoding the type. All objects are multiples of S2CINT and must be allocated on S2CINT boundaries. The basic data object is a "Scheme to C Object", or SCOBJ. It is defined by the following UNION type. In addition, the following types are also defined: SCP pointer to a SCOBJ. TSCP tagged pointer to a SCOBJ PATSCP pointer to an array of TSCP's. TSCPP function which returns a TSCP as its value. The most common type conversion is that which converts SCP's and TSCP's. It is done by the following: U_T( tsp, tag ) convert Untagged SCP to a Tagged TSCP. U_TX( tsp ) convert Untagged SCP to an Extended Tagged TSCP. U_TP( tsp ) convert Untagged SCP to an Pair Tagged TSCP. T_U( tscp ) convert Tagged TSCP to an Untagged SCP. TX_U( tscp ) convert Tagged eXtended pointer to an Untagged SCP. TP_U( tscp ) convert Tagged Pair pointer to an Untagged SCP. */ struct STACKTRACE; typedef char *TSCP; typedef union SCOBJ { /* SCHEME to C OBJECT */ struct { /* as an unsigned value */ S2CUINT gned; } unsi; struct { /* EXTENDEDOBJ */ S2CUINT_FIELDS2( tag:8, rest:S2CINTBITS-8 ); } extendedobj; struct { /* SYMBOL */ S2CUINT_FIELDS2( tag:8, rest:S2CINTBITS-8 ); TSCP name; TSCP *ptrtovalue; TSCP value; TSCP propertylist; } symbol; struct { /* STRING */ S2CUINT_FIELDS2( tag:8, length:S2CINTBITS-8 ); char char0; } string; struct { /* VECTOR */ S2CUINT_FIELDS2( tag:8, length:S2CINTBITS-8 ); TSCP element0; } vector; struct { /* PROCEDURE */ S2CUINT_FIELDS3( tag:8, required:8, optional:S2CINTBITS-16 ); TSCP (*code)(); TSCP closure; } procedure; struct { /* CLOSURE */ S2CUINT_FIELDS2( tag:8, length:S2CINTBITS-8 ); TSCP closure; TSCP var0; } closure; struct { /* CONTINUATION */ S2CUINT_FIELDS2( tag:8, length:S2CINTBITS-8 ); TSCP continuation; S2CINT stackbytes; sc_jmp_buf savedstate; char *address; struct STACKTRACE* stacktrace; S2CINT word0; } continuation; struct { /* RECORD */ S2CUINT_FIELDS2( tag:8, length:S2CINTBITS-8 ); TSCP methods; TSCP element0; } record; struct { /* DOUBLEFLOAT */ S2CUINT_FIELDS2( tag:8, rest:S2CINTBITS-8 ); #ifdef SPARC int value[2]; #else double value; #endif } doublefloat; struct { /* FORWARD */ S2CUINT_FIELDS2( tag:8, length:S2CINTBITS-8 ); TSCP forward; } forward; struct { /* WORDALIGN */ S2CUINT_FIELDS2( tag:8, length:S2CINTBITS-8 ); } wordalign; struct { /* PAIR */ TSCP car; TSCP cdr; } pair; } *SCP; typedef TSCP *PATSCP; /* PTR to ARRAY of TAGGED SCHEME to C PTRs */ typedef TSCP (*TSCPP)(); /* TAGGED SCHEME to C PTR returning PROCEDURE */ #define TAGMASK 3 #define TSCPTAG( x ) ((S2CINT)x & TAGMASK) #define U_T( scp, tag ) ((TSCP)((char*)(scp)+tag)) #define U_TX( scp ) ((TSCP)((char*)(scp)+EXTENDEDTAG)) #define U_TP( scp ) ((TSCP)((char*)(scp)+PAIRTAG)) #define T_U( tscp ) ((SCP)((S2CINT)(tscp) & (~((S2CINT)TAGMASK)))) #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) /* 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 the right. A tag value of 0 is used to allow fixed point numbers to be added and subtracted without any tag extraction and insertion. Note that the define FIXED_C assumes that >> provides an arithmetic right shift. +--------+--------+--------+--------+ |....signed fixed point value.....00| +--------+--------+--------+--------+ */ #define FIXNUMTAG 0 typedef S2CINT SCFIXED; /* Scheme to C fixed point number */ #define FIXED_C( x ) (((S2CINT)(x))>>2) #define C_FIXED( x ) ((TSCP)(((S2CINT)(x))<<2)) /* The second type of object is an "extended" object. This is where the pointer points to the header of a multi-word object. +--------+--------+--------+--------+ |........pointer to object........01| +--------+--------+--------+--------+ This header in turn has an immediate tag (tag = 2) and the remaining 6 bits of the first byte define the type of the object as follows. Note that while the pictures show each object being composed of 32-bit words, the width of each word is the width of S2CINT. A SYMBOL is represented by: +--------+--------+--------+--------+ | 0 | 0 | 0 |10000010| symbol (tag = 130) +--------+--------+--------+--------+ | symbol name | +--------+--------+--------+--------+ | pointer to value | +--------+--------+--------+--------+ | value | +--------+--------+--------+--------+ | property list | +--------+--------+--------+--------+ where the first word contains the tag. Following the tag is the symbol name. It is a string and is of the form "symbol-name" for top-level symbols and "module-name_symbol-name" for other symbols. Next comes a pointer to the top-level value of the symbol. If the symbol is bound to a compiled global value, then the pointer will point to that value and the following field will not be used. On the other hand, if the symbol is not bound to a compiled global, then the pointer will point to the following word which will hold its value. The final field points to the property list for the symbol. All "interned" symbols are kept in a data structure called the OBARRAY. It is a Scheme array which maintains bucket-hash lists of all allocated symbols. Symbols are created and entered into the data structure by the function "sc_string_2d_3esymbol". A STRING is represented by: +--------+--------+--------+--------+ | length of string |10000110| string (tag = 134) +--------+--------+--------+--------+ | i | r | t | s | +--------+--------+--------+--------+ | - | 0 | g | n | +--------+--------+--------+--------+ where the first word contains the tag and the length (in bytes) of the string. The string storage starts in the next word. Following the last character of the string is a null byte. A VECTOR is represented by: +--------+--------+--------+--------+ | number of elements |10001010| vector (tag = 138) +--------+--------+--------+--------+ | element 0 | +--------+--------+--------+--------+ | element 1 | +--------+--------+--------+--------+ | ... | where the first word contains the tag and the length (in elements) of the vector. The vector storage starts in the next word, where each element is a scheme pointer. A PROCEDURE is represented by: +--------+--------+--------+--------+ | 0 |optional|required|10001110| procedure (tag = 142) +--------+--------+--------+--------+ | code address | +--------+--------+--------+--------+ | pointer to enclosing closure | +--------+--------+--------+--------+ where the first word contains the tag and the argument flags. The optional flag is 0 when the function takes a fixed number of arguments and 1 when it takes a list of optional arguments as its final argument. The required field is the number of required arguments that the function takes. This is followed by the code address and a pointer to the enclosing closure (which may be () or a continuation). A CLOSURE is represented by: +--------+--------+--------+--------+ | # closed values |10010010| closure (tag = 146) +--------+--------+--------+--------+ | pointer to enclosing closure | +--------+--------+--------+--------+ | 1st closed variable | +--------+--------+--------+--------+ | 2nd closed variable | +--------+--------+--------+--------+ | ... | where the first word contains the tag and the number of closed variables. The next word contains a pointer to the enclosing closure (which may be ()) and the closed variables then follow. A CONTINUATION is a formed by CALL-WITH-CURRENT-CONTINUATION. It is represented by: +--------+--------+--------+--------+ | # saved words |10010110| continuation (tag=150) +--------+--------+--------+--------+ | pointer to enclosing continuation | +--------+--------+--------+--------+ | # saved stack bytes | +--------+--------+--------+--------+ . . . state saved by setjmp . . . +--------+--------+--------+--------+ | address of byte 0 of saved stack | +--------+--------+--------+--------+ | saved value of sc_stacktrace | +--------+--------+--------+--------+ . . . saved display . . . +--------+--------+--------+--------+ | 1st word of saved stack | +--------+--------+--------+--------+ | 2nd word of saved stack | +--------+--------+--------+--------+ | ... | where the first word contains the tag and the count of the number of words required to hold the continuation (does not include word for pointer to enclosing continuation). Next is a pointer to the enclosing continuation (or () if there isn't one) and the count of the number of bytes of stack saved. Following this is the state saved by setjmp. The continuation is terminated by the stack address, the value of sc_stacktrace, the saved display, and the saved stack block. Note the contents of any of these saved words may be pointers or derived from pointers. A RECORD is represented by: +--------+--------+--------+--------+ | number of elements |10001010| record (tag = 154) +--------+--------+--------+--------+ | A-list of methods | +--------+--------+--------+--------+ | element 0 | +--------+--------+--------+--------+ | ... | where the first word contains the tag and the length (in elements) of the record. The next word is an a-list of methods. Following this is a scheme pointer for each element of the record. A DOUBLE FLOATING POINT number is represented by: +--------+--------+--------+--------+ | 0 | 0 | 0 |10011110| double (tag = 158) +--------+--------+--------+--------+ | optional alignment pad | +--------+--------+--------+--------+ | | +-- double floating point value --+ | | +--------+--------+--------+--------+ A forwarded object (which may be a pair or an extended object) is represented by: +--------+--------+--------+--------+ | word count |10100010| forward (tag = 162) +--------+--------+--------+--------+ | tagged pointer to new copy | +--------+--------+--------+--------+ where the first word contains the tag and the size of the object (in words). The next word contains a Scheme pointer to the new copy of the object. When storage must be allocated to correctly align objects, a wordalign object is allocated: +--------+--------+--------+--------+ | 0 | 0 | 0 |10100110| word align (tag = 166) +--------+--------+--------+--------+ */ #define EXTENDEDTAG 1 #define SYMBOLTAG 130 #define STRINGTAG 134 #define VECTORTAG 138 #define PROCEDURETAG 142 #define CLOSURETAG 146 #define CONTINUATIONTAG 150 #define RECORDTAG 154 #define DOUBLEFLOATTAG 158 #define FORWARDTAG 162 #define WORDALIGNTAG 166 /* The following definitions define the size in S2CINT's of each extended object. */ #define SYMBOLSIZE 5 #define STRINGSIZE( x ) ((((x)+sizeof(S2CINT))/sizeof(S2CINT))+1) #define VECTORSIZE( x ) ((x)+1) #define PROCEDURESIZE 3 #define CLOSURESIZE( x ) ((x)+2) #define CONTINUATIONSIZE( x ) ((x)+2) #define RECORDSIZE( x ) ((x)+2) #ifdef DOUBLE_ALIGN #define DOUBLEFLOATSIZE ((sizeof(double)*2)/sizeof(S2CINT)) #else #define DOUBLEFLOATSIZE (1+sizeof(double)/sizeof(S2CINT)) #endif #define FORWARDSIZE( x ) (x) #define WORDALIGNSIZE 1 #ifndef MAXSTRINGSIZE #define MAXSTRINGSIZE 16777215 #endif #ifndef MAXVECTORSIZE #define MAXVECTORSIZE 16777215 #endif #define MAXRECORDSIZE (MAXVECTORSIZE-1) /* A pointer that points to an extended object must pass the following test. Note that some things which aren't pointers can pass this test too. The pointer P must be untagged. */ #define EXTENDEDHEADER( p ) ((p->extendedobj.tag >= SYMBOLTAG) && \ (TSCPTAG( p->extendedobj.tag ) == IMMEDIATETAG)) /* The number of closed variables in a contination with 0 saved stack words is NULLCONTINUATIONSIZE. */ #define NULLCONTINUATIONSIZE ((sizeof( sc_jmp_buf )/sizeof(S2CINT))+3) /* There is one string which is the empty string and one vector which is the empty vector. */ #define EMPTYSTRING sc_emptystring #define EMPTYVECTOR sc_emptyvector extern TSCP sc_emptystring, sc_emptyvector; /* The third type of object is an "immediate" object where the actual object type is encoded in the rest of the pointer. The objects of this type are: +--------+--------+--------+--------+ | 0 | 0 | 0 |00000010| empty list +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | 0 |00001010| #F +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | 0 |00001110| #T +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | char |00010010| character +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | 0 |00010110| eof object +--------+--------+--------+--------+ +--------+--------+--------+--------+ | 0 | 0 | 0 |00011010| undefined +--------+--------+--------+--------+ Tags are allocated with an eye toward null testing. Note that the the boolean #F and the list () are separate objects, but both are treated as false to conform to the Scheme definition. () == 2 == emptylist #F == 10 == falsevalue #T == 14 == truevalue (NOT P) == $1 := P and 247; $1 := $1 =i 2; */ #define IMMEDIATETAG 2 #define IMMEDIATETAGMASK 255 #define EMPTYLIST ((TSCP)2) #define FALSEVALUE ((TSCP)10) #define TRUEVALUE ((TSCP)14) #define CHARACTERTAG 18 #define EOFOBJECT ((TSCP)22) #define UNDEFINED ((TSCP)26) #define C_CHAR( i ) ((TSCP)(((S2CUINT)( i )<< 8)+CHARACTERTAG)) #ifdef SPARC #define CHAR_C( c ) ((int)(((S2CUINT)( c )) >> 8)) #else #define CHAR_C( c ) ((char)(((S2CUINT)( c )) >> 8)) #endif #define CHAR_FIX( c ) ((TSCP)(((S2CUINT)( c )) >> 6)) #define FIX_CHAR( fix ) ((TSCP)(((S2CUINT)( fix ) << 6)+CHARACTERTAG)) #define TSCPIMMEDIATETAG( p ) ((S2CINT)(p) & IMMEDIATETAGMASK) extern TSCP sc_emptylist, /* Immediate denoting empty list */ sc_falsevalue, /* Immediate denoting false */ sc_truevalue, /* Immediate denoting true */ sc_eofobject, /* Immediate denoting end-of-file */ sc_undefined; /* Immediate denoting the undefined value */ /* The final type of object is a list cell. The CAR of the cell is a word stored at (pointer), and the CDR of the cell is the next word. +--------+--------+--------+--------+ | CAR of the pair | pair +--------+--------+--------+--------+ | CDR of the pair | +--------+--------+--------+--------+ */ #define PAIRTAG 3 #define CONSSIZE 2 #define CONSBYTES (CONSSIZE*sizeof(S2CINT)) /* Symbols are kept in the "obarray" which is a data structure internal to this module. It is used by SYMBOL->STRING to make symbols unique. */ extern TSCP sc_obarray; /* In order for garbage collection to work correctly, the addresses of all globals containing constants and top level variables must be known. They are maintained in two extensible structures: sc_constants and sc_globals. Entries are added by addtoSCPTRS and may be deleted by deletefromSCPTRS. */ struct SCPTRS { S2CINT count; /* # of pointers in the structure */ S2CINT limit; /* # of pointers it could hold */ TSCP *ptrs[ 1 ]; /* pointers */ }; #define sizeofSCPTRS( x ) (sizeof(struct SCPTRS)+sizeof(TSCP)*((x)-1)) extern struct SCPTRS *addtoSCPTRS(); extern void deletefromSCPTRS(); extern struct SCPTRS *sc_constants; extern struct SCPTRS *sc_globals; /* Access to lexically nested variables is via a display maintained by the following data structure. SC_DISPLAY is an array which maintains the display, and SC_MAXDISPLAY is the maximum number of cells in the display that are ever used. */ extern TSCP sc_display[]; extern S2CINT sc_maxdisplay; /* Stack height checks on procedure entry are controlled by the variable CHECKSTACK. */ #if CHECKSTACK #ifdef STACK_GROWS_POSITIVE #define CHECK_SP if (((char*)&st) >= sc_topofstack) sc_stackoverflow() #else #define CHECK_SP if (((char*)&st) <= sc_topofstack) sc_stackoverflow() #endif #else #define CHECK_SP #endif #ifndef STACK_OVERFLOW #define STACK_OVERFLOW 0 #endif /* Time-slicing is implemented by decrementing and checking a counter on each procedure entry and backward branch. The variable TIMESLICE enables it. Pending signals are also detected at these points. */ #if TIMESLICE #define CHECK_TS if (--sc_timeslice <= 0) sc_timesliced() #else #define CHECK_TS #endif /* Debugging information is kept on the stack in an implementation independent manner by using the following data structures and conventions. When a procedure is entered, it will allocate a STACKTRACE structure on the stack and set SC_STACKTRACE to point to it. The fields in the structure are set as follows: in sceval_exec: in any other procedure: prevstacktrace: previous value of previous value of sc_stacktrace sc_stacktrace procname: current environment C string naming the procedure exp: expression being unused interpreted When the procedure is exited, sc_stacktrace is restored. */ struct STACKTRACE { /* Stack trace back record */ struct STACKTRACE* prevstacktrace; VOIDP procname; TSCP exp; }; extern struct STACKTRACE *sc_stacktrace; #if COMPACTPUSHTRACE #define PUSHSTACKTRACE( procedure ) \ struct STACKTRACE st; \ TSCP result; \ sc_pushstacktrace( &st, procedure ) #else #define PUSHSTACKTRACE( procedure ) \ struct STACKTRACE st; \ TSCP result; \ st.prevstacktrace = sc_stacktrace; \ st.procname = (procedure); \ sc_stacktrace = &st; \ CHECK_SP; \ CHECK_TS #endif #if COMPACTPOPTRACE #define POPSTACKTRACE( exp ) \ return( sc_popstacktrace( &st, exp ) ) #else #define POPSTACKTRACE( exp ) \ return( (result=(exp), \ sc_stacktrace=st.prevstacktrace, \ result) ) #endif #define LOOPSTACKTRACE( expression, env ) \ (st.exp = (expression), st.procname = (env)) /* Scheme execution mode */ extern S2CINT sc_schememode; #define STANDALONESCHEME 0 #define EMBEDDEDSCHEME 1 #define INTERACTIVESCHEME 2 /* A define is used instead of goto on backward branches to allow code to be inserted to for check timeslice expiration and pending signals. */ #define GOBACK( l ) {CHECK_TS; goto l;} /* Macros of the form XALn are used to declare external procedure arguments as such arguments are not allowed by older C compilers. */ #ifdef NEED_MACRO_ARGS #define XAL0(dummy) #else #define XAL0() #endif #define XAL1(a) a v01 #define XAL2(a,b) a v01,b v02 #define XAL3(a,b,c) a v01,b v02,c v03 #define XAL4(a,b,c,d) a v01,b v02,c v03,d v04 #define XAL5(a,b,c,d,e) a v01,b v02,c v03,d v04,e v05 #define XAL6(a,b,c,d,e,f) a v01,b v02,c v03,d v04,e v05,f v06 #define XAL7(a,b,c,d,e,f,g) a v01,b v02,c v03,d v04,e v05,f v06,g v07 #define XAL8(a,b,c,d,e,f,g,h) a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08 #define XAL9(a,b,c,d,e,f,g,h,i) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09 #define XAL10(a,b,c,d,e,f,g,h,i,j) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10 #define XAL11(a,b,c,d,e,f,g,h,i,j,k) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11 #define XAL12(a,b,c,d,e,f,g,h,i,j,k,l) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,l v12 #define XAL13(a,b,c,d,e,f,g,h,i,j,k,l,m) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13 #define XAL14(a,b,c,d,e,f,g,h,i,j,k,l,m,n) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14 #define XAL15(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15 #define XAL16(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16 #define XAL17(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17 #define XAL18(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18 #define XAL19(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18,s v19 #define XAL20(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18,s v19,t v20 #define XAL21(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18,s v19,t v20,u v21 #define XAL22(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18,s v19,t v20,u v21,v v22 #define XAL23(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18,s v19,t v20,u v21,v v22,w v23 #define XAL24(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18,s v19,t v20,u v21,v v22,\ w v23,x v24 #define XAL25(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) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18,s v19,t v20,u v21,v v22,\ w v23,x v24,y v25 #define XAL26(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) \ a v01,b v02,c v03,d v04,e v05,f v06,g v07,h v08,i v09,j v10,k v11,\ l v12,m v13,n v14,o v15,p v16,q v17,r v18,s v19,t v20,u v21,v v22,\ w v23,x v24,y v25,z v26 /* The procedural interfaces to this module are: */ extern TSCP sc_make_2dstring_v; extern TSCP sc_make_2dstring(); extern TSCP sc_string_2dcopy_v; extern TSCP sc_string_2dcopy(); extern TSCP sc_cstringtostring(); extern TSCP sc_c_2dstring_2d_3estring_v; extern TSCP sc_c_2dstring_2d_3estring(); extern TSCP sc_make_2dvector_v; extern TSCP sc_make_2dvector(); #ifdef MAC extern TSCP sc_makeclosure(...); extern TSCP sc_makeprocedure(...); #else extern TSCP sc_makeclosure( TSCP va_alist, ... ); extern TSCP sc_makeprocedure(); #endif extern TSCP sc_make_2d_25record_v; extern TSCP sc_make_2d_25record(); extern void sc_initializevar(); extern void sc_global_TSCP(); extern void sc_delete_global_TSCP(); extern void sc_constantexp(); extern TSCP sc_string_2d_3esymbol_v; extern TSCP sc_string_2d_3esymbol(); extern TSCP sc_d_2dsymbol_ab4b4447_v; extern TSCP sc_d_2dsymbol_ab4b4447(); extern TSCP sc_uninterned_2dsymbol_3f_v; extern TSCP sc_uninterned_2dsymbol_3f(); extern char sc_tscp_char(); extern S2CINT sc_tscp_s2cint(); extern S2CUINT sc_tscp_s2cuint(); extern VOIDP sc_tscp_pointer(); extern double sc_tscp_double(); extern TSCP sc_s2cint_tscp(); extern TSCP sc_s2cuint_tscp(); extern S2CUINT sc_procedureaddress(); extern TSCP sc_scheme_2dmode(); extern TSCP sc_set_2dscheme_2dmode_21( XAL1( TSCP ) ); extern TSCP sc_osexit( XAL1( TSCP ) ); extern void sc_segv__handlers(); /* The definitions which follow are used by the code generated by the Scheme->C compiler. They are included in this file so that only one #include file will be required. */ /* Alternative C access to SCOBJ's */ #define UNSI_GNED( tscp ) (TX_U( tscp )->unsi.gned) #define TSCP_EXTENDEDTAG( tscp ) (TX_U( tscp )->extendedobj.tag) #define SYMBOL_NAME( tscp ) (TX_U( tscp )->symbol.name) #define SYMBOL_VALUEADDR( tscp ) (TX_U( tscp )->symbol.ptrtovalue) #define SYMBOL_VALUE( tscp ) (*TX_U( tscp )->symbol.ptrtovalue) #define SYMBOL_PROPERTYLIST( tscp ) (TX_U( tscp )->symbol.propertylist) #define STRING_LENGTH( tscp ) (TX_U( tscp )->string.length) #define STRING_CHAR( tscp, n ) (*(((unsigned char*)tscp)+FIXED_C( n )+ \ (sizeof(S2CINT)-1))) #define VECTOR_LENGTH( tscp ) (TX_U( tscp )->vector.length) #if defined(AOSF) || defined(AMD64) #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+ \ (sizeof(S2CINT)-1)+ \ ((S2CINT)n)*2))) #else #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+ \ (sizeof(S2CINT)-1)+((S2CINT)n)))) #endif #define PROCEDURE_REQUIRED( tscp ) (TX_U( tscp )->procedure.required) #define PROCEDURE_OPTIONAL( tscp ) (TX_U( tscp )->procedure.optional) #define PROCEDURE_CLOSURE( tscp ) (TX_U( tscp )->procedure.closure) #define PROCEDURE_CODE( tscp ) (TX_U( tscp )->procedure.code) #define CLOSURE_LENGTH( tscp ) (TX_U( tscp )->closure.length) #define CLOSURE_CLOSURE( tscp ) (TX_U( tscp )->closure.closure) #define CLOSURE_VAR( tscp, n ) (*(&TX_U( tscp )->closure.var0+(n))) #define RECORD_LENGTH( tscp ) (TX_U( tscp )->vector.length) #define RECORD_METHODS( tscp ) \ (*((PATSCP)(((char*)( tscp ))+(sizeof(S2CINT)-1)))) #if defined(AOSF) || defined(AMD64) #define RECORD_ELEMENT( tscp, n ) \ (*((PATSCP)(((char*)( tscp ))+((sizeof(S2CINT)*2)-1)+((S2CINT)n)*2))) #else #define RECORD_ELEMENT( tscp, n ) \ (*((PATSCP)(((char*)( tscp ))+((sizeof(S2CINT)*2)-1)+((S2CINT)n)))) #endif #ifdef SPARC extern double sc_get_double( XAL1( int* ) ); #define FLOAT_VALUE( tscp ) sc_get_double(&(TX_U( tscp )->doublefloat.value[0])) #else #define FLOAT_VALUE( tscp ) (TX_U( tscp )->doublefloat.value) #endif #define PAIR_CAR( tscp ) (TP_U( tscp )->pair.car) #define PAIR_CDR( tscp ) (TP_U( tscp )->pair.cdr) /* C declarations */ #define DEFCSTRING( name, chars ) static char *name = chars #define DEFTSCP( name ) TSCP name #define DEFSTATICTSCP( name ) static TSCP name #define EXTERNTSCP( a ) extern TSCP a #define EXTERNTSCPP( a, b ) extern TSCP a( b ) #define EXTERNINT( a ) extern int a #define EXTERNINTP( a, b ) extern int a( b ) #define EXTERNPOINTER( a ) extern VOIDP a #define EXTERNPOINTERP( a, b ) extern VOIDP a( b ) #define EXTERNARRAY( a ) extern unsigned a[] #define EXTERNARRAYP( a, b ) extern VOIDP a( b ) #define EXTERNCHAR( a ) extern char a #define EXTERNCHARP( a, b ) extern char a( b ) #define EXTERNSHORTINT( a ) extern short int a #define EXTERNSHORTINTP( a, b ) extern short int a( b ) #define EXTERNLONGINT( a ) extern long int a #define EXTERNLONGINTP( a, b ) extern long int a( b ) #define EXTERNUNSIGNED( a ) extern unsigned a #define EXTERNUNSIGNEDP( a, b ) extern unsigned a( b ) #define EXTERNSHORTUNSIGNED( a ) extern short unsigned a #define EXTERNSHORTUNSIGNEDP( a, b ) extern short unsigned a() #define EXTERNLONGUNSIGNED( a ) extern long unsigned a #define EXTERNLONGUNSIGNEDP( a, b ) extern long unsigned a( b ) #define EXTERNFLOAT( a ) extern float a #define EXTERNFLOATP( a, b ) extern float a( b ) #define EXTERNDOUBLE( a ) extern double a #define EXTERNDOUBLEP( a, b ) extern double a( b ) #define EXTERNVOIDP( a, b ) extern void a( b ) #define MAXDISPLAY( a ) if (a > sc_maxdisplay) sc_maxdisplay = a /* C operators */ #define EQ( a, b ) (a == b) #define NEQ( a, b ) (a != b) #define NOT( a ) (a == 0) #define GT( a, b ) (a > b) #define LT( a, b ) (a < b) #define GTE( a, b ) (a >= b) #define LTE( a, b ) (a <= b) #define OR( a, b ) (a || b) #define AND( a, b ) (a && b) #define SET( a, b ) (a = b) #define BITAND( a, b ) (a & b) #define BITOR( a, b ) (a | b) #define BITXOR( a, b ) (a ^ b) #define BITLSH( a, b ) (a << b) #define BITRSH( a, b ) (a >> b) #define BITAND32( a, b ) ((a & b) & 0xFFFFFFFF) #define BITOR32( a, b ) ((a | b) & 0xFFFFFFFF) #define BITXOR32( a, b ) ((a ^ b) & 0xFFFFFFFF) #define BITLSH32( a, b ) ((a << b) & 0xFFFFFFFF) #define BITRSH32( a, b ) ((a & 0xFFFFFFFF) >> b) #define PLUS( a, b ) (a + b) #define DIFFERENCE( a, b ) (a - b) #define NEGATE( a ) (- a) #define TIMES( a, b ) (a * b) #define QUOTIENT( a, b ) (a / b) #define REMAINDER( a, b ) (a % b) #define SHORTINT( a ) ((short int) a) #define INT( a ) ((int) a) #define LONGINT( a ) ((long int) a) #define SHORTUNSIGNED( a ) ((short unsigned) a) #define UNSIGNED( a ) ((unsigned) a) #define LONGUNSIGNED( a ) ((long unsigned) a) #define _S2CINT( a ) ((S2CINT) a) #define _S2CUINT( a ) ((S2CUINT) a) #define CFLOAT( a ) ((float) a) #define CDOUBLE( a ) ((double) a) #define _TSCP( a ) ((TSCP) a) #define VIA( a ) (*a) #define ADR( a ) (&a) #define SIZEOF( a ) (sizeof( a )) #define DISPLAY( a ) (sc_display[ a ]) /* Some implementations gracefully handle integer overflow. This option is enabled by MATHTRAPS. */ #if MATHTRAPS #define IPLUS( a, b ) sc_iplus( a, b ) #define IDIFFERENCE( a, b ) sc_idifference( a, b) #define INEGATE( a ) sc_inegate( a) #define ITIMES( a, b ) sc_itimes( a, b ) #else #define IPLUS( a, b ) (a + b) #define IDIFFERENCE( a, b ) (a - b) #define INEGATE( a ) (- a) #define ITIMES( a, b ) (a * b) #endif /* Generational garbage collection requires that stores of pointers to new objects in old objects be detected. This is done by requiring the use of the macro SETGEN to set cells in SET-CAR!, SET-CDR!, VECTOR-SET!, PUTPROP, SCHEME-TSCP-SET!, SET! of lexically bound variables, %RECORD-SET!, and %RECORD-METHODS-SET!. The macro SETGENTL must be used to set the values of top level variables. N.B. These macros assume a page size of 512 bytes. */ #define SETGEN( a, b ) \ ((sc_pagelink[ (((S2CUINT)(&a))>>9)-sc_firstphypagem1 ])? \ (a = b):sc_setgeneration( &a, b )) #define SETGENTL( a, b ) (sc_setgeneration( &a, b )) /* Scheme boolean tests */ #define TRUE( x ) ((((S2CINT)(x)) & 247) != 2) #define FALSE( x ) ((((S2CINT)(x)) & 247) == 2) /* Short circuiting for procedure application. In order for this code to work correctly, it requires that the tag field be in the least 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( (S2CINT)(FLOAT_VALUE( flt )) ) #define FIX_FLT( fix ) MAKEFLOAT( (double)(FIXED_C( fix )) ) #define FIX_FLTV( fix ) ((double)(FIXED_C( fix ))) #define FLTV_FLT( flt ) MAKEFLOAT( flt ) #ifdef SPARC #define FLTP_FLT( fltp ) MAKEFLOAT( sc_get_double((int*)(fltp)) ) #else #define FLTP_FLT( fltp ) MAKEFLOAT( *((double*)( fltp )) ) #endif #define STRING_C( s ) (&T_U( s )->string.char0) #define BOOLEAN( c ) ((c) ? TRUEVALUE : FALSEVALUE) /* Memory Access */ #define MBYTE( base, bx ) (*(((unsigned char*) base)+bx )) #define MSINT( base, bx ) (*((short int*)( ((char*)base) + bx ))) #define MINT( base, bx ) (*((int*)( ((char*)base) + bx ))) #define MLINT( base, bx ) (*((long int*)( ((char*)base) + bx ))) #define MSUNSIGNED(base,bx) (*((short unsigned*)( ((char*)base) + bx ))) #define MUNSIGNED(base, bx) (*((unsigned*)( ((char*)base) + bx ))) #define MLUNSIGNED(base,bx) (*((long unsigned*)( ((char*)base) + bx ))) #define MS2CUINT(base, bx) (*((S2CUINT*)( ((char*)base) + bx ))) #define MTSCP( base, bx ) (*((TSCP*)( ((char*)base) + bx ))) #define MFLOAT( base, bx ) (*((float*)( ((char*)base) + bx ))) #ifdef SPARC #define MDOUBLE(base,bx) sc_get_double( (int*)(((char*)base) + bx) ) #define SETMDOUBLE(base,bx,y) sc_set_double( (int*)(((char*)base) + bx), y ) #else #define MDOUBLE(base,bx) (*((double*)(((char*)base) + bx))) #define SETMDOUBLE(base,bx,y) (*((double*)(((char*)base) + bx)) = y) #endif /* Low-level builtins */ #define CONS sc_cons #define STRINGTOSYMBOL sc_string_2d_3esymbol #define CONSTANTEXP sc_constantexp #define MAKEPROCEDURE sc_makeprocedure #define MAKECLOSURE sc_makeclosure #define MAKEFLOAT sc_makedoublefloat #define INITIALIZEVAR sc_initializevar #define TSCP_CHAR sc_tscp_char #define TSCP_S2CUINT sc_tscp_s2cuint #define TSCP_S2CINT sc_tscp_s2cint #define TSCP_POINTER sc_tscp_pointer #define TSCP_DOUBLE sc_tscp_double #define CHAR_TSCP C_CHAR #define S2CINT_TSCP sc_s2cint_tscp #define S2CUINT_TSCP sc_s2cuint_tscp #define POINTER_TSCP sc_s2cuint_tscp #define DOUBLE_TSCP FLTV_FLT #define CSTRING_TSCP sc_cstringtostring #define INITHEAP( a,b,c,d ) \ if (sc_stackbase == 0) { STACKPTR( sc_stackbase ); }\ sc_restoreheap( a, b, c, d ) #define SCHEMEEXIT() sc_osexit( (TSCP)0 ) #define LISTTOVECTOR scrt4_list_2d_3evector #define CLARGUMENTS sc_clarguments /* External Functions and SCHEME->C globals which are defined in other modules. They are duplicated here so that this file contains all external definitions needed by a SCHEME->C program. */ extern TSCP sc_makedoublefloat( XAL1( double ) ); extern TSCP sc_cons(); extern TSCP sc_verifyobject( XAL1( TSCP ) ); extern S2CINT sc_unknownargc; extern TSCP sc_unknownproc[ 4 ]; extern void sc_restoreheap(); extern TSCP scrt4_list_2d_3evector( XAL1( TSCP ) ); extern void sc_arm_mathtraps(); extern S2CINT sc_iplus( XAL2( S2CINT, S2CINT ) ); extern S2CINT sc_idifference( XAL2( S2CINT, S2CINT ) ); extern S2CINT sc_inegate( XAL1( S2CINT ) ); extern S2CINT sc_itimes( XAL2( S2CINT, S2CINT ) ); extern PAGELINK *sc_pagelink; extern S2CINT sc_firstphypagem1; extern TSCP sc_setgeneration(); extern S2CINT sc_timeslice; extern TSCP scdebug_timeout(); extern char* sc_topofstack; extern S2CINT *sc_stackbase; extern TSCP sc_clarguments(); extern S2CINT *sc_processor_register( XAL1( S2CINT ) ); extern void sc_options( XAL3( int, int, int ) ); extern void sc_stackoverflow(); extern void sc_timesliced(); extern void sc_pushstacktrace( XAL2( struct STACKTRACE *, char* ) ); extern TSCP sc_popstacktrace( XAL2( struct STACKTRACE *, TSCP ) ); /* Linkage to external functions to implement math routines. N.B. These declarations may be machine specific. */ extern double floor( XAL1( double ) ); #define C_FLOOR( x ) DOUBLE_TSCP( floor( TSCP_DOUBLE( x ) ) ) extern double ceil( XAL1( double ) ); #define C_CEILING( x ) DOUBLE_TSCP( ceil( TSCP_DOUBLE( x ) ) ) extern double exp( XAL1( double ) ); #define C_EXP( x ) DOUBLE_TSCP( exp( TSCP_DOUBLE( x ) ) ) extern double log( XAL1( double ) ); #define C_LOG( x ) DOUBLE_TSCP( log( TSCP_DOUBLE( x ) ) ) extern double sin( XAL1( double ) ); #define C_SIN( x ) DOUBLE_TSCP( sin( TSCP_DOUBLE( x ) ) ) extern double cos( XAL1( double ) ); #define C_COS( x ) DOUBLE_TSCP( cos( TSCP_DOUBLE( x ) ) ) extern double tan( XAL1( double ) ); #define C_TAN( x ) DOUBLE_TSCP( tan( TSCP_DOUBLE( x ) ) ) extern double asin( XAL1( double ) ); #define C_ASIN( x ) DOUBLE_TSCP( asin( TSCP_DOUBLE( x ) ) ) extern double acos( XAL1( double ) ); #define C_ACOS( x ) DOUBLE_TSCP( acos( TSCP_DOUBLE( x ) ) ) extern double atan( XAL1( double ) ); #define C_ATAN( x ) DOUBLE_TSCP( atan( TSCP_DOUBLE( x ) ) ) extern double atan2( XAL2( double, double ) ); #define C_ATAN2( x, y ) DOUBLE_TSCP( atan2( TSCP_DOUBLE( x ), \ TSCP_DOUBLE( y ) ) ) extern double sqrt( XAL1( double ) ); #define C_SQRT( x ) DOUBLE_TSCP( sqrt( TSCP_DOUBLE( x ) ) ) extern double pow( XAL2( double, double ) ); #define C_POW( x, y ) DOUBLE_TSCP( pow( TSCP_DOUBLE( x ), \ TSCP_DOUBLE( y ) ) ) scheme2c-2012.10.14/scrt/options.h000066400000000000000000000233641203736146400164300ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This file defines compilation options for a specific implementation */ #define CHECKSTACK 0 /* 0 = don't check stack height */ /* 1 = check stack height */ #define TIMESLICE 0 /* 0 = don't time slice execution */ /* 1 = time slice execution */ #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 1 = emit procedure call for procedure entry checks. */ #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 1 = emit procedure call for procedure exit cleanup. */ #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ /* 1 = Scheme->C does handle signals */ #define MATHTRAPS 1 /* 0 = don't detect fixed point overflow */ /* 1 = recover on fixed point overflow */ /* Define only one of the supported processor types: AOSF Alpha AXP OSF/1 HP700 HP 9000/700 MAC Macintosh system 7.1 with Think-C 5.0 MC680X0 HP 9000/300, Sun 3, Next MIPS DECstation, SGI, Sony News VAX Vax ULTRIX FREEBSD x86 FreeBSD */ #define AOSF 1 #define HP700 1 #define MAC 1 #define MC680X0 1 #define MIPS 1 #define VAX 1 #define FREEBSD 1 /* Attributes of the selected architecture: The following four macros define specific aspects of the system. They are defined as strings, or specifically undefined: IMPLEMENTATION_MACHINE machine type IMPLEMENTATION_CPU cpu type IMPLEMENTATION_OS operating system IMPLEMENTATION_FS file system Big endian vs. little endian: BIGENDIAN defined to 1 to denote bigendian systems Alignment: DOUBLE_ALIGN defined to 1 to force doubles to be aligned on an even S2CINT boundary Macro expansion: NEED_MACRO_ARGS defined to 1 to declare a macro like X() as X(dummy) The types S2CINT and S2CUINT are defined to be signed and unsigned integers that are the same size as pointers. This is the basic "word" used by Scheme->C. The machine state when a continuation is created is captured in the sc_jmp_buf data structure. STACKPTR( x ) is a define that stores the address of the stack pointer in x. Unix flavors: POSIX POSIX.1 compliant SYSV System V or derivative SYSV4 System V release 4 (also define SYSV, POSIX) */ /**************/ /* AOSF */ /**************/ #ifdef AOSF #define IMPLEMENTATION_MACHINE "Alpha AXP" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_OS "OSF/1" #undef IMPLEMENTATION_FS typedef long int S2CINT; /* Signed pointer size integer */ typedef long unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffffffffffL /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x8000000000000000L /* S2CUINT with 1 in the MSB */ typedef long int sc_jmp_buf[ 9 ]; /* The buffer contains the following items: s0-s6 saved registers ra return address sp stack pointer */ #define STACKPTR( x ) x = sc_getsp() extern S2CINT* sc_getsp(); #define NEED_MACRO_ARGS 1 #endif /***************/ /* HP700 */ /***************/ #ifdef HP700 #ifdef __hp9000s700 #define IMPLEMENTATION_MACHINE "HP9000/700" #else #ifdef __hp9000s800 #define IMPLEMENTATION_MACHINE "HP9000/800" #endif #endif #define IMPLEMENTATION_CPU "HP-PA" #define BIGENDIAN 1 #define DOUBLE_ALIGN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register (30))) #define STACK_GROWS_POSITIVE 1 #endif #ifdef __hpux #define IMPLEMENTATION_OS "HP-UX" #undef IMPLEMENTATION_FS #include typedef jmp_buf sc_jmp_buf; #define SYSV 1 #define POSIX 1 #endif /***************/ /* FREEBSD */ /***************/ #ifdef FREEBSD #define IMPLEMENTATION_MACHINE "Generic PC" #define IMPLEMENTATION_CPU "Intelx86" #define IMPLEMENTATION_OS "FreeBSD" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR( x ) x = sc_processor_register( 0 ) #include typedef jmp_buf sc_jmp_buf; /* Horrid kludge. See callcc.c for the full story: */ #define LAZY_STACK_POP 1 #define LAZY_STACK_INCREMENT 4 #endif /*************/ /* MAC */ /*************/ #ifdef MAC #define IMPLEMENTATION_MACHINE "Apple Macintosh" #define IMPLEMENTATION_CPU "680x0" #define IMPLEMENTATION_OS "7.1" #undef IMPLEMENTATION_FS #define BIGENDIAN 1 typedef long int S2CINT; /* Signed pointer size integer */ typedef long unsigned S2CUINT; /* Unsigned pointer size interger */ typedef short int PAGELINK; /* 16-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffffL /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000L /* S2CUINT with 1 in the MSB */ #include typedef jmp_buf sc_jmp_buf; #undef TRUE #undef FALSE #define STACKPTR( x ) x = sc_getsp() extern S2CINT* sc_getsp(); #define SCHEAP 1 #define SCMAXHEAP 15 #endif /****************/ /* MC680X0 */ /****************/ #ifdef MC680X0 #define IMPLEMENTATION_CPU "680x0" #define BIGENDIAN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #define STACKPTR(x) ((x) = (sc_processor_register (15))) #ifdef __hp9000s400 #define IMPLEMENTATION_MACHINE "HP9000/400" #else #ifdef __hp9000s300 #define IMPLEMENTATION_MACHINE "HP9000/300" #endif #endif /* HP-UX dependent conditionalizations performed above. */ #endif /**************/ /* MIPS */ /**************/ #ifdef MIPS #define IMPLEMENTATION_MACHINE "DECstation" #define IMPLEMENTATION_CPU "Rx000" #define IMPLEMENTATION_OS "ULTRIX" #undef IMPLEMENTATION_FS #define DOUBLE_ALIGN 1 typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ #ifndef MIPSEL #define BIGMIPS 1 #define BIGENDIAN 1 #undef IMPLEMENTATION_MACHINE #define IMPLEMENTATION_MACHINE "Big Endian MIPS" #undef IMPLEMENTATION_OS /* Not sure what the correct conditionalization is here -- NEWS-OS 5.xx defines both "sony" and "sonyrisc", but apparently NEWS-OS 4.xx defines "sony_mips", because the previous version of Scheme->C was conditionalized on "sony_mips" which is *not* defined by NEWS-OS 5.xx. If there's an intersection between the symbols defined by 4.xx and 5.xx then a member of that intersection should be used for the conditionalization; otherwise test for both. */ #ifdef sonyrisc #undef IMPLEMENTATION_MACHINE #define IMPLEMENTATION_MACHINE "Sony MIPS" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_CPU "R3000" #undef IMPLEMENTATION_OS #define IMPLEMENTATION_OS "NEWS-OS" #ifdef SYSTYPE_SYSV #define SYSV4 1 #define SYSV 1 #define POSIX 1 /* This can be implemented but requires generalizing the signal handler to know about SYSV4 siginfo structure. */ #undef MATHTRAPS #define MATHTRAPS 0 #define NEED_MACRO_ARGS 1 #define COPY_STACK_BEFORE_LONGJMP 1 #endif #endif #endif #include typedef jmp_buf sc_jmp_buf; #define STACKPTR( x ) x = sc_processor_register( 29 ) #endif /*************/ /* VAX */ /*************/ #ifdef VAX #define IMPLEMENTATION_MACHINE "VAX" #undef IMPLEMENTATION_CPU #define IMPLEMENTATION_OS "ULTRIX" #undef IMPLEMENTATION_FS typedef int S2CINT; /* Signed pointer size integer */ typedef unsigned S2CUINT; /* Unsigned pointer size interger */ typedef int PAGELINK; /* 32-bit sc_pagelink values */ #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ typedef int sc_jmp_buf[ 16 ]; /* The buffer contains the following items: R2-R11 saved registers SIGM saved signal mask SP stack pointer on entry to setjmp PSW PSW word from stack frame AP saved argument ptr from frame FP saved frame ptr from frame PC saved program cntr from frame */ #define STACKPTR( x ) x = sc_processor_register( 14 ) #endif scheme2c-2012.10.14/scrt/predef.sc000066400000000000000000001036161203736146400163570ustar00rootroot00000000000000;;; SCHEME->C runtime ;;; ;;; This file contains the initial "predefined" information used by the ;;; compiler. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. ;;; Functions to be in-lined can be defined by the following form: ;;; ;;; (DEFINE-IN-LINE (func args ...) body ...) (define-macro DEFINE-IN-LINE (lambda (form expander) (let ((func (caadr form)) (args (cdadr form)) (body (cddr form))) (expander `(define-macro ,func (lambda (x e) (e (cons '(lambda ,args ,@body) (cdr x)) e))) expander)))) ;;; Run-time checking is controlled by the following flags which may be reset: (define-constant *TYPE-CHECK* #t) (define-constant *BOUNDS-CHECK* #t) (define-constant *FIXED-ONLY* #f) ;;; 4.2.5 Delayed Evaluation (define-macro DELAY (lambda (form expander) (if (= (length form) 2) (expander `(make-promise (lambda () ,@(cdr form))) expander) (expand-error 'delay form)))) ;;; 6.1 Booleans (define-external (not x) scrt1) (define-external (boolean? x) scrt1) ;;; 6.2 Equivalence Predicates. (define-in-line (EQV? x y) ((lap (x y) (BOOLEAN (OR (EQ (_S2CUINT x) (_S2CUINT y)) (AND (EQ (TSCPTAG x) EXTENDEDTAG) (AND (EQ (TSCP_EXTENDEDTAG x) DOUBLEFLOATTAG) (AND (EQ (TSCPTAG y) EXTENDEDTAG) (AND (EQ (TSCP_EXTENDEDTAG y) DOUBLEFLOATTAG) (EQ (FLOAT_VALUE x) (FLOAT_VALUE y))))))))) x y)) (define-external (eqv? x y) scrt1) (define-in-line (EQ? x y) ((lap (x y) (BOOLEAN (EQ (_S2CUINT x) (_S2CUINT y)))) x y)) (define-external (eq? x y) scrt1) (define-external (equal? x y) scrt1) ;;; 6.3 Pairs and Lists. (define-in-line (PAIR? x) ((lap (x) (BOOLEAN (EQ (TSCPTAG x) PAIRTAG))) x)) (define-external (pair? x) scrt1) (define-external (cons x y) sc) (define-external (cons* x . y) scrt1) (define-external ($_car-error x) scrt1) (define-in-line (CAR x) (if (and *type-check* (not (pair? x))) ($_car-error x)) ((lap (x) (PAIR_CAR x)) x)) (define-external (car x) scrt1) (define-external ($_cdr-error x) scrt1) (define-in-line (CDR x) (if (and *type-check* (not (pair? x))) ($_cdr-error x)) ((lap (x) (PAIR_CDR x)) x)) (define-external (cdr x) scrt1) (define-in-line (CAAR x) (car (car x))) (define-in-line (CADR x) (car (cdr x))) (define-in-line (CDAR x) (cdr (car x))) (define-in-line (CDDR x) (cdr (cdr x))) (define-external (caar x) scrt1) (define-external (cadr x) scrt1) (define-external (cdar x) scrt1) (define-external (cddr x) scrt1) (define-external (caaar x) scrt1) (define-external (caadr x) scrt1) (define-external (cadar x) scrt1) (define-external (caddr x) scrt1) (define-external (cdaar x) scrt1) (define-external (cdadr x) scrt1) (define-external (cddar x) scrt1) (define-external (cdddr x) scrt1) (define-external (caaaar x) scrt1) (define-external (caaadr x) scrt1) (define-external (caadar x) scrt1) (define-external (caaddr x) scrt1) (define-external (cadaar x) scrt1) (define-external (cadadr x) scrt1) (define-external (caddar x) scrt1) (define-external (cadddr x) scrt1) (define-external (cdaaar x) scrt1) (define-external (cdaadr x) scrt1) (define-external (cdadar x) scrt1) (define-external (cdaddr x) scrt1) (define-external (cddaar x) scrt1) (define-external (cddadr x) scrt1) (define-external (cdddar x) scrt1) (define-external (cddddr x) scrt1) (define-in-line (SET-CAR! x y) (if (and *type-check* (not (pair? x))) (error 'SET-CAR! "Argument not a PAIR: ~s" x)) ((lap (x y) (SETGEN (PAIR_CAR x) y)) x y)) (define-external (set-car! x y) scrt1) (define-in-line (SET-CDR! x y) (if (and *type-check* (not (pair? x))) (error 'SET-CDR! "Argument not a PAIR: ~s" x)) ((lap (x y) (SETGEN (PAIR_CDR x) y)) x y)) (define-external (set-cdr! x y) scrt1) (define-in-line (NULL? x) (eq? x '())) (define-external (null? x) scrt1) (define-external (list? x) scrt1) (define-in-line (LIST . x) x) (define-external (list . x) scrt1) (define-external (length x) scrt1) (define-macro APPEND (lambda (form expander) (case (length form) ((1) ''()) ((2) (expander (cadr form) expander)) ((3) (expander `(append-two ,(cadr form) ,(caddr form)) expander)) (else (expander `(append-two ,(cadr form) (append ,@(cddr form))) expander))))) (define-external (append-two x y) scrt1) (define-external (append . x) scrt1) (define-external (reverse x) scrt1) (define-external (list-tail x k) scrt1) (define-external (list-ref x k) scrt1) (define-external (last-pair x) scrt1) (define-external (memq x y) scrt1) (define-external (memv x y) scrt1) (define-external (member x y) scrt1) (define-external (assq x y) scrt1) (define-external (assv x y) scrt1) (define-external (assoc x y) scrt1) (define-external (remq x y) scrt1) (define-external (remv x y) scrt1) (define-external (remove x y) scrt1) (define-external (remq! x y) scrt1) (define-external (remv! x y) scrt1) (define-external (remove! x y) scrt1) ;;; 6.4 Symbols. (define-in-line (SYMBOL? x) ((lap (x) (BOOLEAN (AND (EQ (TSCPTAG x) EXTENDEDTAG) (EQ (TSCP_EXTENDEDTAG x) SYMBOLTAG)))) x)) (define-external (symbol? x) scrt2) (define-in-line (SYMBOL->STRING x) (if (and *type-check* (not (symbol? x))) (error 'SYMBOL->STRING "Argument is not a SYMBOL: ~s" x)) ((lap (x) (SYMBOL_NAME x)) x)) (define-external (symbol->string x) scrt2) (define-external (string->symbol x) sc) (define-external (string->uninterned-symbol x) sc) (define-external (uninterned-symbol? x) sc) (define-external (top-level-value symbol) scrt2) (define-external (set-top-level-value! symbol value) scrt2) (define-external (getprop symbol key) scrt2) (define-external (getprop-all symbol) scrt2) (define-external (putprop symbol key value) scrt2) ;;; 6.5 Numbers. (define-in-line (FIXED? x) ((lap (x) (BOOLEAN (EQ (TSCPTAG x) FIXNUMTAG))) x)) (define-external (fixed? x) scrt2) (define-in-line (FLOAT? x) ((lap (x) (BOOLEAN (AND (EQ (TSCPTAG x) EXTENDEDTAG) (EQ (TSCP_EXTENDEDTAG x) DOUBLEFLOATTAG)))) x)) (define-external (float? x) scrt2) (define-in-line (FLOAT->FIXED x) (if (and *type-check* (not (float? x))) (error 'FLOAT->FIXED "Argument is not a FLOAT: ~s" x)) (if (and *type-check* (or ((lap (x) (BOOLEAN (LT (FLOAT_VALUE x) MINTSCPINTF))) x) ((lap (x) (BOOLEAN (GT (FLOAT_VALUE x) MAXTSCPINTF))) x))) (error 'FLOAT->FIXED "Argument is out of range: ~s" x)) ((lap (x) (FLT_FIX x)) x)) (define-external (float->fixed x) scrt2) (define-in-line (FIXED->FLOAT x) (if (and *type-check* (not (fixed? x))) (error 'FIXED->FLOAT "Argument is not an FIXED: ~s" x)) ((lap (x) (FIX_FLT x)) x)) (define-external (fixed->float x) scrt2) (define-in-line (NUMBER? x) (or (fixed? x) (float? x))) (define-external (number? x) scrt2) (define-in-line (COMPLEX? x) (or (fixed? x) (float? x))) (define-external (complex? x) scrt2) (define-in-line (REAL? x) (or (fixed? x) (float? x))) (define-external (real? x) scrt2) (define-in-line (RATIONAL? x) (number? x)) (define-external (rational? x) scrt2) (define-in-line (INTEGER? x) (or (fixed? x) (and (float? x) (= x (round x))))) (define-external (integer? x) scrt2) (define-in-line (ONE-FIXED? x) (or (and (not *type-check*) *fixed-only*) (fixed? x))) (define-in-line (TWO-FIXEDS? x y) (or (and (not *type-check*) *fixed-only*) ((lap (x y) (BOOLEAN (NOT (BITAND (BITOR (_S2CINT x) (_S2CINT y)) 3)))) x y))) (define-in-line (ZERO? x) (if (one-fixed? x) (eq? x 0) (`,zero? x))) (define-external (zero? x) scrt2) (define-in-line (POSITIVE? x) (if (one-fixed? x) ((lap (x) (BOOLEAN (GT (_S2CINT x) 0))) x) (`,positive? x))) (define-external (positive? x) scrt2) (define-in-line (NEGATIVE? x) (if (one-fixed? x) ((lap (x) (BOOLEAN (LT (_S2CINT x) 0))) x) (`,negative? x))) (define-external (negative? x) scrt2) (define-in-line (ODD? x) (and (integer? x) (not (zero? (remainder x 2))))) (define-external (odd? x) scrt2) (define-in-line (EVEN? x) (and (integer? x) (zero? (remainder x 2)))) (define-external (even? x) scrt2) (define-in-line (EXACT? x) (if (and *type-check* (not (number? x))) (error 'EXACT? "Argument is not a NUMBER: ~s" x)) (fixed? x)) (define-external (exact? x) scrt2) (define-in-line (INEXACT? x) (if (and *type-check* (not (number? x))) (error 'INEXACT? "Argument is not a NUMBER: ~s" x)) (float? x)) (define-external (inexact? x) scrt2) (define-macro = (lambda (form expander) `(,(if (= (length form) 3) (expander '(lambda (x y) (if (two-fixeds? x y) (eq? x y) (=-two x y))) expander) '=) ,@(map (lambda (x) (expander x expander)) (cdr form))))) (define-external (=-two x y) scrt2) (define-external (= x y . z) scrt2) (define-macro < (lambda (form expander) `(,(if (= (length form) 3) (expander '(lambda (x y) (if (two-fixeds? x y) ((lap (x y) (BOOLEAN (LT (_S2CINT x) (_S2CINT y)))) x y) (<-two x y))) expander) '<) ,@(map (lambda (x) (expander x expander)) (cdr form))))) (define-external (<-two x y) scrt2) (define-external (< x y . z) scrt2) (define-macro > (lambda (form expander) `(,(if (= (length form) 3) (expander '(lambda (x y) (if (two-fixeds? x y) ((lap (x y) (BOOLEAN (GT (_S2CINT x) (_S2CINT y)))) x y) (>-two x y))) expander) '>) ,@(map (lambda (x) (expander x expander)) (cdr form))))) (define-external (>-two x y) scrt2) (define-external (> x y . z) scrt2) (define-macro <= (lambda (form expander) `(,(if (= (length form) 3) (expander '(lambda (x y) (if (two-fixeds? x y) ((lap (x y) (BOOLEAN (LTE (_S2CINT x) (_S2CINT y)))) x y) (<=-two x y))) expander) '<=) ,@(map (lambda (x) (expander x expander)) (cdr form))))) (define-external (<=-two x y) scrt2) (define-external (<= x y . z) scrt2) (define-macro >= (lambda (form expander) `(,(if (= (length form) 3) (expander '(lambda (x y) (if (two-fixeds? x y) ((lap (x y) (BOOLEAN (GTE (_S2CINT x) (_S2CINT y)))) x y) (>=-two x y))) expander) '>=) ,@(map (lambda (x) (expander x expander)) (cdr form))))) (define-external (>=-two x y) scrt2) (define-external (>= x y . z) scrt2) (define-macro MAX (lambda (form expander) `(,(if (= (length form) 3) (expander '(lambda (x y) (if (two-fixeds? x y) (if ((lap (x y) (BOOLEAN (GT (_S2CINT x) (_S2CINT y)))) x y) x y) (max-two x y))) expander) 'max) ,@(map (lambda (x) (expander x expander)) (cdr form))))) (define-external (max-two x y) scrt2) (define-external (max x . y) scrt2) (define-macro MIN (lambda (form expander) `(,(if (= (length form) 3) (expander '(lambda (x y) (if (two-fixeds? x y) (if ((lap (x y) (BOOLEAN (LT (_S2CINT x) (_S2CINT y)))) x y) x y) (min-two x y))) expander) 'min) ,@(map (lambda (x) (expander x expander)) (cdr form))))) (define-external (min-two x y) scrt2) (define-external (min x . y) scrt2) (define-macro + (lambda (form expander) (case (length form) ((1) 0) ((2) (expander (cadr form) expander)) ((3) (expander `((lambda (x y) (if (two-fixeds? x y) (if *fixed-only* ((lap (x y) (_TSCP (PLUS (_S2CINT x) (_S2CINT y)))) x y) ((lap (x y) (_TSCP (IPLUS (_S2CINT x) (_S2CINT y)))) x y)) (+-two x y))) ,(cadr form) ,(caddr form)) expander)) (else (expander `(+ ,(cadr form) (+ ,@(cddr form))) expander))))) (define-external (+-two x y) scrt2) (define-external (+ . x) scrt2) (define-macro * (lambda (form expander) (case (length form) ((1) 1) ((2) (expander (cadr form) expander)) ((3) (expander `((lambda (x y) (if (two-fixeds? x y) (if *fixed-only* ((lap (x y) (_TSCP (TIMES (FIXED_C x) (_S2CINT y)))) x y) ((lap (x y) (_TSCP (ITIMES (FIXED_C x) (_S2CINT y)))) x y)) (*-two x y))) ,(cadr form) ,(caddr form)) expander)) (else (expander `(* ,(cadr form) (* ,@(cddr form))) expander))))) (define-external (*-two x y) scrt2) (define-external (* . x) scrt2) (define-macro - (lambda (form expander) (case (length form) ((1) (expand-error '- form)) ((2) (expander `((lambda (x) (if (one-fixed? x) (if *fixed-only* ((lap (x) (_TSCP (NEGATE (_S2CINT x)))) x) ((lap (x) (_TSCP (INEGATE (_S2CINT x)))) x)) (--two 0.0 x))) ,(cadr form)) expander)) ((3) (expander `((lambda (x y) (if (two-fixeds? x y) (if *fixed-only* ((lap (x y) (_TSCP (DIFFERENCE (_S2CINT x) (_S2CINT y)))) x y) ((lap (x y) (_TSCP (IDIFFERENCE (_S2CINT x) (_S2CINT y)))) x y)) (--two x y))) ,@(cdr form)) expander)) (else (expander `(- (- ,(cadr form) ,(caddr form)) ,@(cdddr form)) expander))))) (define-external (--two x y) scrt2) (define-external (- x . y) scrt2) (define-macro / (lambda (form expander) (case (length form) ((1) (expand-error '/ form)) ((2) (expander `(/ 1 ,(cadr form)) expander)) ((3) (expander `((lambda (x y) (if (and (two-fixeds? x y) (not (eq? y 0)) (eq? ((lap (x y) (_TSCP (REMAINDER (_S2CINT x) (_S2CINT y)))) x y) 0)) ((lap (x y) (C_FIXED (QUOTIENT (_S2CINT x) (_S2CINT y)))) x y) (/-two x y))) ,@(cdr form)) expander)) (else (expander `(/ (/ ,(cadr form) ,(caddr form)) ,@(cdddr form)) expander))))) (define-external (/-two x y) scrt2) (define-external (/ x . y) scrt2) (define-in-line (ABS x) (if (one-fixed? x) (if (negative? x) (if *fixed-only* ((lap (x) (_TSCP (NEGATE (_S2CINT x)))) x) ((lap (x) (_TSCP (INEGATE (_S2CINT x)))) x)) x) (`,abs x))) (define-external (abs x) scrt2) (define-in-line (QUOTIENT x y) (if (and (two-fixeds? x y) (not (eq? y 0))) ((lap (x y) (C_FIXED (QUOTIENT (_S2CINT x) (_S2CINT y)))) x y) (`,quotient x y))) (define-external (quotient x y) scrt2) (define-in-line (REMAINDER x y) (if (and (two-fixeds? x y) (not (eq? y 0))) ((lap (x y) (_TSCP (REMAINDER (_S2CINT x) (_S2CINT y)))) x y) (`,remainder x y))) (define-external (remainder x y) scrt2) (define-external (modulo x y) scrt2) (define-external (gcd . x) scrt2) (define-external (lcm . x) scrt2) (define-external (floor x) scrt2) (define-external (ceiling x) scrt2) (define-external (truncate x) scrt2) (define-external (round x) scrt2) (define-external (exp x) scrt2) (define-external (log x) scrt2) (define-external (sin x) scrt2) (define-external (cos x) scrt2) (define-external (tan x) scrt2) (define-external (asin x) scrt2) (define-external (acos x) scrt2) (define-external (atan x . y) scrt2) (define-external (sqrt x) scrt2) (define-external (expt x y) scrt2) (define-external (exact->inexact x) scrt2) (define-external (inexact->exact x) scrt2) (define-external (number->string number . format-radix) scrt2) (define-external (string->number number . radix) scrt2) ;;; 6.6 Characters. (define-in-line (CHAR? x) ((lap (x) (BOOLEAN (EQ (TSCPIMMEDIATETAG x) CHARACTERTAG))) x)) (define-external (char? x) scrt3) (define-in-line (TWO-CHARS? x y) ((lap (x y) (BOOLEAN (AND (EQ (TSCPIMMEDIATETAG x) CHARACTERTAG) (EQ (TSCPIMMEDIATETAG y) CHARACTERTAG)))) x y)) (define-in-line (CHAR=? x y) (if (and *type-check* (not (two-chars? x y))) (error 'CHAR=? "Argument(s) not CHAR: ~s ~s" x y)) ((lap (x y) (BOOLEAN (EQ (_S2CINT x) (_S2CINT y)))) x y)) (define-external (char=? x y) scrt3) (define-in-line (CHAR? x y) (if (and *type-check* (not (two-chars? x y))) (error 'CHAR>? "Argument(s) not CHAR: ~s ~s" x y)) ((lap (x y) (BOOLEAN (GT (_S2CINT x) (_S2CINT y)))) x y)) (define-external (char>? x y) scrt3) (define-in-line (CHAR<=? x y) (if (and *type-check* (not (two-chars? x y))) (error 'CHAR<=? "Argument(s) not CHAR: ~s ~s" x y)) ((lap (x y) (BOOLEAN (LTE (_S2CINT x) (_S2CINT y)))) x y)) (define-external (char<=? x y) scrt3) (define-in-line (CHAR>=? x y) (if (and *type-check* (not (two-chars? x y))) (error 'CHAR>=? "Argument(s) not CHAR: ~s ~s" x y)) ((lap (x y) (BOOLEAN (GTE (_S2CINT x) (_S2CINT y)))) x y)) (define-external (char>=? x y) scrt3) (define-external (char-ci=? x y) scrt3) (define-external (char-ci? x y) scrt3) (define-external (char-ci<=? x y) scrt3) (define-external (char-ci>=? x y) scrt3) (define-external (char-alphabetic? x) scrt3) (define-external (char-numeric? x) scrt3) (define-external (char-whitespace? x) scrt3) (define-external (char-upper-case? x) scrt3) (define-external (char-lower-case? x) scrt3) (define-external (char-upcase x) scrt3) (define-external (char-downcase x) scrt3) (define-in-line (CHAR->INTEGER x) (if (and *type-check* (not (char? x))) (error 'CHAR->INTEGER "Argument not a CHAR: ~s" x)) ((lap (x) (CHAR_FIX x)) x)) (define-external (char->integer x) scrt3) (define-in-line (INTEGER->CHAR x) (if (and *type-check* (or (not (fixed? x)) (< x 0) (> x 255))) (error 'INTEGER->CHAR "Argument not an unsigned 8-bit INTEGER: ~s" x)) ((lap (x) (FIX_CHAR x)) x)) (define-external (integer->char x) scrt3) ;;; 6.7 Strings. (define-in-line (STRING? x) ((lap (x) (BOOLEAN (AND (EQ (TSCPTAG x) EXTENDEDTAG) (EQ (TSCP_EXTENDEDTAG x) STRINGTAG)))) x)) (define-external (string? x) scrt3) (define-external (make-string x . y) sc) (define-external (string . x) scrt3) (define-external (string-copy x) sc) (define-in-line (STRING-LENGTH x) (if (and *type-check* (not (string? x))) (error 'STRING-LENGTH "Argument is not a STRING: ~s" x)) ((lap (x) (C_FIXED (STRING_LENGTH x))) x)) (define-external (string-length x) scrt3) (define-in-line (STRING-REF x y) (if (and *type-check* (not (fixed? y))) (error 'STRING-REF "Argument is not an INTEGER: ~s" y)) (if (and *bounds-check* (or (negative? y) (>= y (string-length x)))) (error 'STRING-REF "Argument is out of range: ~s" y)) ((lap (x y) (C_CHAR (STRING_CHAR x y))) x y)) (define-external (string-ref x y) scrt3) (define-in-line (STRING-SET! x y z) (if (and *type-check* (not (fixed? y))) (error 'STRING-SET! "Argument is not an INTEGER: ~s" y)) (if (and *type-check* (not (char? z))) (error 'STRING-SET! "Argument is not a CHAR: ~s" z)) (if (and *bounds-check* (or (negative? y) (>= y (string-length x)))) (error 'STRING-SET! "Argument(s) incorrect")) ((lap (x y z) (SET (STRING_CHAR x y) (CHAR_C z)) z) x y z)) (define-external (string-set! x y z) scrt3) (define-external (string=? x y) scrt3) (define-external (string? x y) scrt3) (define-external (string<=? x y) scrt3) (define-external (string>=? x y) scrt3) (define-external (string-ci=? x y) scrt3) (define-external (string-ci? x y) scrt3) (define-external (string-ci<=? x y) scrt3) (define-external (string-ci>=? x y) scrt3) (define-external (substring x y z) scrt3) (define-external (string-append . x) scrt3) (define-external (string->list x) scrt3) (define-external (list->string x) scrt3) (define-external (string-fill! s c) scrt3) ;;; 6.8 Vectors. (define-in-line (VECTOR? x) ((lap (x) (BOOLEAN (AND (EQ (TSCPTAG x) EXTENDEDTAG) (EQ (TSCP_EXTENDEDTAG x) VECTORTAG)))) x)) (define-external (vector? x) scrt4) (define-in-line (VECTOR-BOUNDS? v x) ((lap (v x) (BOOLEAN (LT (_S2CUINT (FIXED_C x)) (_S2CUINT (VECTOR_LENGTH v))))) v x)) (define-external (make-vector x . y) sc) (define-external (vector . x) scrt4) (define-in-line (VECTOR-LENGTH x) (if (and *type-check* (not (vector? x))) (error 'VECTOR-LENGTH "Argument is not a VECTOR: ~s" x)) ((lap (x) (C_FIXED (VECTOR_LENGTH x))) x)) (define-external (vector-length x) scrt4) (define-in-line (VECTOR-REF x y) (if (and *type-check* (not (vector? x))) (error 'VECTOR-REF "Argument is not a VECTOR: ~s" x)) (if (and *type-check* (not (fixed? y))) (error 'VECTOR-REF "Argument is not an INTEGER: ~s" y)) (if (and (or *type-check* *bounds-check*) (not (vector-bounds? x y))) (error 'VECTOR-REF "Index is not in bounds: ~s" y)) ((lap (x y) (VECTOR_ELEMENT x y)) x y)) (define-external (vector-ref x y) scrt4) (define-in-line (VECTOR-SET! x y z) (if (and *type-check* (not (vector? x))) (error 'VECTOR-SET! "Argument is not a VECTOR: ~s" x)) (if (and *type-check* (not (fixed? y))) (error 'VECTOR-SET! "Argument is not an INTEGER: ~s" y)) (if (and (or *type-check* *bounds-check*) (not (vector-bounds? x y))) (error 'VECTOR-SET! "Index is not in bounds: ~s" y)) ((lap (x y z) (SETGEN (VECTOR_ELEMENT x y) z)) x y z)) (define-external (vector-set! x y z) scrt4) (define-external (vector->list x) scrt4) (define-external (list->vector x) scrt4) (define-external (vector-fill! x y) scrt4) ;;; 6.9 Control features. (define-in-line (PROCEDURE? x) ((lap (x) (BOOLEAN (AND (EQ (TSCPTAG x) EXTENDEDTAG) (EQ (TSCP_EXTENDEDTAG x) PROCEDURETAG)))) x)) (define-external (procedure? x) scrt4) (define-macro apply (lambda (form expander) (if (equal? (length form) 3) (expander `(apply-two ,@(cdr form)) expander) (expander `(apply-two ,(cadr form) (cons* ,@(cddr form))) expander)))) (define-external (apply-two x y) sc) (define-external (apply x y . z) scrt4) (define-macro MAP (lambda (form expander) (case (length form) ((3) (expander `(map-one ,@(cdr form)) expander)) ((4) (expander `(map-two ,@(cdr form)) expander)) ((5) (expander `(map-three ,@(cdr form)) expander)) (else `(map ,@(map (lambda (x) (expander x expander)) (cdr form))))))) (define-in-line (MAP-ONE proc args) (let loop ((args args) (head '()) (tail '())) (if (not (null? args)) (let ((val (cons (proc (car args)) '()))) (if (null? head) (loop (cdr args) val val) (loop (cdr args) head (set-cdr! tail val)))) head))) (define-in-line (MAP-TWO proc args brgs) (let loop ((args args) (brgs brgs) (head '()) (tail '())) (if (not (null? args)) (let ((val (cons (proc (car args) (car brgs)) '()))) (if (null? head) (loop (cdr args) (cdr brgs) val val) (loop (cdr args) (cdr brgs) head (set-cdr! tail val)))) head))) (define-in-line (MAP-THREE proc args brgs crgs) (let loop ((args args) (brgs brgs) (crgs crgs) (head '()) (tail '())) (if (not (null? args)) (let ((val (cons (proc (car args) (car brgs) (car crgs)) '()))) (if (null? head) (loop (cdr args) (cdr brgs) (cdr crgs) val val) (loop (cdr args) (cdr brgs) (cdr crgs) head (set-cdr! tail val)))) head))) (define-external (map x y . z) scrt4) (define-macro FOR-EACH (lambda (form expander) (case (length form) ((3) (expander `(for-each-one ,@(cdr form)) expander)) ((4) (expander `(for-each-two ,@(cdr form)) expander)) ((5) (expander `(for-each-three ,@(cdr form)) expander)) (else `(for-each ,@(map (lambda (x) (expander x expander)) (cdr form))))))) (define-in-line (FOR-EACH-ONE proc args) (do ((args args (cdr args))) ((null? args)) (proc (car args)))) (define-in-line (FOR-EACH-TWO proc args brgs) (do ((args args (cdr args)) (brgs brgs (cdr brgs))) ((null? args)) (proc (car args) (car brgs)))) (define-in-line (FOR-EACH-THREE proc args brgs crgs) (do ((args args (cdr args)) (brgs brgs (cdr brgs)) (crgs crgs (cdr crgs))) ((null? args)) (proc (car args) (car brgs) (car crgs)))) (define-external (for-each x y . z) scrt4) (define-in-line (FORCE object) (object)) (define-external (force object) scrt4) (define-external (make-promise proc) scrt4) (define-external call-with-current-continuation sc) (define-external (catch-error procedure) scrt4) ;;; 6.10 Input and output. (define-external (call-with-input-file filename proc) scrt5) (define-external (call-with-output-file filename proc) scrt5) (define-external (input-port? x) scrt5) (define-external (output-port? x) scrt5) (define-external (current-input-port) scrt5) (define-external (current-output-port) scrt5) (define-external stdin-port scrt5) (define-external stdout-port scrt5) (define-external stderr-port scrt5) (define-external debug-output-port scrt5) (define-external trace-output-port scrt5) (define-external (with-input-from-file filename proc) scrt5) (define-external (with-output-to-file filename proc) scrt5) (define-external (open-input-file filename) scrt5) (define-external (open-output-file filename) scrt5) (define-external (open-file filename type) scrt5) (define-external (make-file-port fileptr type) scrt5) (define-external (open-input-string string) scrt5) (define-external (open-output-string) scrt5) (define-external (close-input-port port) scrt5) (define-external (close-output-port port) scrt5) (define-external (close-port port) scrt5) (define-external (read . port) scrt6) (define-external (read-char . port) scrt6) (define-external (peek-char . port) scrt6) (define-external (char-ready? . port) scrt6) (define-external (eof-object? x) scrt6) (define-external $_eof-object "sc" "eofobject") (define-external (write obj . port) scrt6) (define-external (display obj . port) scrt6) (define-external (write-char char . port) scrt6) (define-external (newline . port) scrt6) (define-external (flush-buffer . port) scrt6) (define-external (get-output-string port) scrt6) (define-external (write-count . port) scrt6) (define-external (write-width . port) scrt6) (define-external (set-write-width! width . port) scrt6) (define-external (write-circle . port) scrt6) (define-external (set-write-circle! flag . port) scrt6) (define-external (write-level . port) scrt6) (define-external (set-write-level! level . port) scrt6) (define-external (write-length . port) scrt6) (define-external (set-write-length! length . port) scrt6) (define-external (write-pretty . port) scrt6) (define-external (set-write-pretty! flag . port) scrt6) (define-external (echo port . argl) scrt6) (define-external (transcript-on filename) scrt6) (define-external (transcript-off) scrt6) (define-external (port->stdio-file port) scrt6) (define-external (format form . args) scrt6) (define-external (pp form . output) scrt6) (define-external (rename-file old new) scrt6) (define-external (remove-file name) scrt6) (define-external (define-system-file-task file idle-task file-task) scrt6) (define-external (wait-system-file file) scrt6) (define-external (enable-system-file-tasks enable) scrt6) ;;; Extensions to the Scheme. (define-external (weak-cons x y) sc) (define-external (time-of-day) sc) (define-external (c-string->string x) sc) (define-external c-sizeof-short scrt4) (define-external c-sizeof-int scrt4) (define-external c-sizeof-long scrt4) (define-external c-sizeof-float scrt4) (define-external c-sizeof-double scrt4) (define-external c-sizeof-tscp scrt4) (define-external c-sizeof-s2cuint scrt4) (define-external (c-byte-ref x y) scrt4) (define-external (c-shortint-ref x y) scrt4) (define-external (c-int-ref x y) scrt4) (define-external (c-shortunsigned-ref x y) scrt4) (define-external (c-unsigned-ref x y) scrt4) (define-external (c-longint-ref x y) scrt4) (define-external (c-longunsigned-ref x y) scrt4) (define-external (c-s2cuint-ref x y) scrt4) (define-external (c-tscp-ref x y) scrt4) (define-external (c-float-ref x y) scrt4) (define-external (c-double-ref x y) scrt4) (define-external (c-byte-set! x y z) scrt4) (define-external (c-shortint-set! x y z) scrt4) (define-external (c-int-set! x y z) scrt4) (define-external (c-shortunsigned-set! x y z) scrt4) (define-external (c-unsigned-set! x y z) scrt4) (define-external (c-longint-set! x y z) scrt4) (define-external (c-longunsigned-set! x y z) scrt4) (define-external (c-s2cuint-set! x y z) scrt4) (define-external (c-tscp-set! x y z) scrt4) (define-external (c-float-set! x y z) scrt4) (define-external (c-double-set! x y z) scrt4) (define-external (scheme-byte-ref x y) scrt4) (define-external (scheme-int-ref x y) scrt4) (define-external (scheme-tscp-ref x y) scrt4) (define-external (scheme-s2cuint-ref x y) scrt4) (define-external (scheme-byte-set! x y z) scrt4) (define-external (scheme-int-set! x y z) scrt4) (define-external (scheme-tscp-set! x y z) scrt4) (define-external (scheme-s2cuint-set! x y z) scrt4) (define-external (bit-and x . y) scrt4) (define-external (bit-or x . y) scrt4) (define-external (bit-not x) scrt4) (define-external (bit-xor x . y) scrt4) (define-external (bit-lsh x y) scrt4) (define-external (bit-rsh x y) scrt4) (define-external (when-unreferenced obj proc) scrt4) (define-external (signal sig handler) scrt4) (define-external (system command) scrt4) (define-external (time-slice) sc) (define-external (set-time-slice! x) sc) (define-external (stack-size) sc) (define-external (set-stack-size! x) sc) (define-external (collect) sc) (define-external (collect-all) sc) (define-external after-collect top-level) (define-external (collect-info) sc) (define-external (set-gcinfo! x) sc) (define-external (set-generation-limit! x) sc) (define-external (set-maximum-heap! x) sc) (define-external *frozen-objects* top-level) (define-external *obarray* top-level) (define-external (eval form . env) sceval) (define-external (error procname format-string . args) scdebug) (define-external *error-handler* scdebug) (define-external reset screp) (define-external exit screp) (define-external top-level screp) (define-external (read-eval-print . flags) screp) (define-external (load file) screp) (define-external (loadq file) screp) (define-external (loade file) screp) (define-external *scheme2c-result* screp) (define-external implementation-information "sc" "implementation_v") (define-external $_undefined "sc" "undefined") (define-external $_empty-string "sc" "emptystring") (define-external $_empty-vector "sc" "emptyvector") (define-in-line (%RECORD? x) ((lap (x) (BOOLEAN (AND (EQ (TSCPTAG x) EXTENDEDTAG) (EQ (TSCP_EXTENDEDTAG x) RECORDTAG)))) x)) (define-external (%record? x) scrt4) (define-external (make-%record x . y) sc) (define-external (%record . x) scrt4) (define-in-line (%RECORD-LENGTH x) (if (and *type-check* (not (%record? x))) (error '%RECORD-LENGTH "Argument is not a %RECORD: ~s" x)) ((lap (x) (C_FIXED (RECORD_LENGTH x))) x)) (define-external (%record-length x) scrt4) (define-in-line (%RECORD-BOUNDS? v x) ((lap (v x) (BOOLEAN (LT (_S2CUINT (FIXED_C x)) (_S2CUINT (RECORD_LENGTH v))))) v x)) (define-in-line (%RECORD-REF x y) (if (and *type-check* (not (%record? x))) (error '%RECORD-REF "Argument is not a %RECORD: ~s" x)) (if (and *type-check* (not (fixed? y))) (error '%RECORD-REF "Argument is not an INTEGER: ~s" y)) (if (and (or *type-check* *bounds-check*) (not (%record-bounds? x y))) (error '%RECORD-REF "Index is not in bounds: ~s" y)) ((lap (x y) (RECORD_ELEMENT x y)) x y)) (define-external (%record-ref x y) scrt4) (define-in-line (%RECORD-SET! x y z) (if (and *type-check* (not (%record? x))) (error '%RECORD-SET! "Argument is not a %RECORD: ~s" x)) (if (and *type-check* (not (fixed? y))) (error '%RECORD-SET! "Argument is not an INTEGER: ~s" y)) (if (and (or *type-check* *bounds-check*) (not (%record-bounds? x y))) (error '%RECORD-SET! "Index is not in bounds: ~s" y)) ((lap (x y z) (SETGEN (RECORD_ELEMENT x y) z)) x y z)) (define-external (%record-set! x y z) scrt4) (define-in-line (%RECORD-METHODS x) (if (and *type-check* (not (%record? x))) (error '%RECORD-METHODS "Argument is not a %RECORD: ~s" x)) ((lap (x) (RECORD_METHODS x)) x)) (define-external (%record-methods x) scrt4) (define-in-line (%RECORD-METHODS-SET! x y) (if (and *type-check* (not (%record? x))) (error '%RECORD-SET! "Argument is not a %RECORD: ~s" x)) ((lap (x y) (SETGEN (RECORD_METHODS x) y)) x y)) (define-external (%record-methods-set! x y) scrt4) (define-external (%record->list x) scrt4) (define-external (list->%record x) scrt4) (define-external %RECORD-PREFIX-CHAR scrt4) (define-external %RECORD-READ scrt4) (define-external (%RECORD-LOOKUP-METHOD record method-name) scrt4) ;;; During debugging, the following symbols are defined: ;;; ;;; backtrace, *args*, *bpt-env*, *error-env*, *result*, proceed, ;;; proceed?, reset-bpt, reset-error scheme2c-2012.10.14/scrt/repdef.sc000066400000000000000000000071411203736146400163530ustar00rootroot00000000000000;;; Scheme->C ;;; ;;; This file contains external definitions for use in compiling the ;;; the interpreter. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (define-external *DEBUG-ON-ERROR* scdebug) (define-external *READING-STDIN* screp) (define-external *RESULT* scdebug) (define-external (ABORT) sc) (define-external (BACKTRACE-ERROR-HANDLER id format-string . args) scdebug) (define-external (CHARREADY file) sc) (define-external (CLEANUP-UNREFERENCED) scrt4) (define-external (COND-MACRO exp) scexpnd1) (define-external CURRENT-INPUT-PORT-VALUE scrt5) (define-external CURRENT-OUTPUT-PORT-VALUE scrt5) (define-external (DOBACKTRACE start stop lines port) scdebug) (define-external (EXPAND x) scexpand) (define-external (FCLOSE file) sc) (define-external (FFLUSH file) sc) (define-external (FGETC file) sc) (define-external (FILENO file) sc) (define-external (FOPEN name access) sc) (define-external (FORMATNUMBER number type length) sc) (define-external (FPUTC character file) sc) (define-external (INPUTREADY mask) sc) (define-external (INSTALL-EXPANDER keyword function) scexpand) (define-external (ISLIST l min . max) scexpand) (define-external (JUMP-TO-SCHEME2C . x) screp) (define-external (LET-MACRO exp) scexpnd2) (define-external (ERROR-DISPLAY x) sc) (define-external (ON-INTERRUPT sig) scdebug) (define-external OPEN-FILE-PORTS scrt5) (define-external (OSEXIT code) sc) (define-external (OSSIGNAL signal handler) sc) (define-external (OSSYSTEM command) sc) (define-external PROCEED scdebug) (define-external (QUASIQUOTATION d exp) scqquote) (define-external (READ-DATUM port) scrt7) (define-external (READNUMBER string type) sc) (define-external (REMOVEFILE name) sc) (define-external (RENAME old-name new-name) sc) (define-external (SCHEME-MODE) sc) (define-external (SET-SCHEME-MODE! mode) sc) (define-external SYSTEM-FILE-MASK scrt6) (define-constant SIG_IGN 1) (define-constant SIGINT 2) ;;; Return the current value of sc_stacktrace. It is not defined as a C ;;; external as the compiler emitted extern might conflict with the one ;;; in objects.h. (define-in-line (STACKTRACE) ((lap () (S2CUINT_TSCP "sc_stacktrace")))) (define-external STDIN sc) (define-external STDOUT sc) (define-external STDERR sc) (define-external (TMPNAM) sc) (define-external TRACE-LEVEL scdebug) (define-external UNDEFINED "sc" "undefined") (define-external (VALID-SCHEME-POINTER? x) "" "sc_schemepointer") (define-external WHENFREED "sc" "whenfreed") (define-external (WRITE/DISPLAY obj readable port) scrt7) scheme2c-2012.10.14/scrt/scdebug.c000066400000000000000000002317641203736146400163510ustar00rootroot00000000000000 /* SCHEME->C */ #include void scdebug__init(); DEFCSTRING( t2843, "SCDEBUG_TIMEOUT" ); DEFSTATICTSCP( c2795 ); DEFCSTRING( t2844, "main" ); DEFSTATICTSCP( c2765 ); DEFCSTRING( t2845, "ERROR" ); DEFSTATICTSCP( c2757 ); DEFCSTRING( t2846, "***** ~a " ); DEFSTATICTSCP( c2752 ); DEFSTATICTSCP( c2724 ); DEFCSTRING( t2847, "***** ERROR error handler failed!" ); DEFSTATICTSCP( c2721 ); DEFCSTRING( t2848, "SCRT4_CALLSIGNALHANDLER" ); DEFSTATICTSCP( c2710 ); DEFCSTRING( t2849, ">> " ); DEFSTATICTSCP( c2709 ); DEFCSTRING( t2850, "~%***** INTERRUPT *****~%" ); DEFSTATICTSCP( c2708 ); DEFSTATICTSCP( c2699 ); DEFSTATICTSCP( t2851 ); DEFSTATICTSCP( t2852 ); DEFSTATICTSCP( t2853 ); DEFSTATICTSCP( t2854 ); DEFSTATICTSCP( t2855 ); DEFSTATICTSCP( t2856 ); DEFSTATICTSCP( t2857 ); DEFSTATICTSCP( t2858 ); DEFSTATICTSCP( t2859 ); DEFSTATICTSCP( t2860 ); DEFSTATICTSCP( t2861 ); DEFSTATICTSCP( t2862 ); DEFSTATICTSCP( t2863 ); DEFSTATICTSCP( t2864 ); DEFSTATICTSCP( t2865 ); DEFSTATICTSCP( t2866 ); DEFSTATICTSCP( t2867 ); DEFSTATICTSCP( t2868 ); DEFSTATICTSCP( t2869 ); DEFSTATICTSCP( t2870 ); DEFSTATICTSCP( t2871 ); DEFSTATICTSCP( t2872 ); DEFSTATICTSCP( t2873 ); DEFSTATICTSCP( t2874 ); DEFSTATICTSCP( t2875 ); DEFSTATICTSCP( t2876 ); DEFSTATICTSCP( c2698 ); DEFSTATICTSCP( c2693 ); DEFCSTRING( t2877, " in " ); DEFSTATICTSCP( c2670 ); DEFCSTRING( t2878, " ..." ); DEFSTATICTSCP( c2669 ); DEFCSTRING( t2879, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c2667 ); DEFSTATICTSCP( c2666 ); DEFCSTRING( t2880, " ...)" ); DEFSTATICTSCP( c2645 ); DEFCSTRING( t2881, "(" ); DEFSTATICTSCP( c2644 ); DEFSTATICTSCP( c2640 ); DEFCSTRING( t2883, "LOOP [inside EXEC]" ); DEFSTATICTSCP( t2882 ); DEFCSTRING( t2885, "SCEVAL_INTERPRETED-PROC" ); DEFSTATICTSCP( t2884 ); DEFCSTRING( t2886, "~s is not breakpointed" ); DEFSTATICTSCP( c2541 ); DEFSTATICTSCP( c2536 ); DEFSTATICTSCP( c2471 ); DEFSTATICTSCP( c2464 ); DEFCSTRING( t2887, "~s- " ); DEFSTATICTSCP( c2460 ); DEFSTATICTSCP( c2459 ); DEFCSTRING( t2888, "~s -returns- ~s" ); DEFSTATICTSCP( c2458 ); DEFCSTRING( t2889, "READ-EVAL-PRINT" ); DEFSTATICTSCP( c2445 ); DEFSTATICTSCP( c2444 ); DEFSTATICTSCP( c2443 ); DEFCSTRING( t2890, "~%~s -calls - ~s" ); DEFSTATICTSCP( c2442 ); DEFSTATICTSCP( c2441 ); DEFCSTRING( t2891, "SCHEME2C" ); DEFSTATICTSCP( c2424 ); DEFCSTRING( t2892, "EMBEDDED [inside BPTER]" ); DEFSTATICTSCP( c2423 ); DEFCSTRING( t2893, " -returns- " ); DEFSTATICTSCP( c2410 ); DEFCSTRING( t2894, " -calls - " ); DEFSTATICTSCP( c2393 ); DEFSTATICTSCP( c2391 ); DEFCSTRING( t2895, "INTERACTIVE [inside BPTER]" ); DEFSTATICTSCP( c2365 ); DEFCSTRING( t2896, "Not at a breakpoint" ); DEFSTATICTSCP( c2363 ); DEFSTATICTSCP( c2362 ); DEFSTATICTSCP( c2341 ); DEFSTATICTSCP( t2897 ); DEFSTATICTSCP( t2898 ); DEFSTATICTSCP( t2899 ); DEFSTATICTSCP( t2900 ); DEFSTATICTSCP( t2901 ); DEFSTATICTSCP( c2326 ); DEFSTATICTSCP( c2325 ); DEFSTATICTSCP( c2324 ); DEFCSTRING( t2902, "Illegal arguments" ); DEFSTATICTSCP( c2321 ); DEFSTATICTSCP( c2305 ); DEFCSTRING( t2903, "~s is not traced" ); DEFSTATICTSCP( c2290 ); DEFSTATICTSCP( c2285 ); DEFCSTRING( t2904, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2270 ); DEFSTATICTSCP( c2269 ); DEFSTATICTSCP( c2218 ); DEFCSTRING( t2905, "==> " ); DEFSTATICTSCP( c2217 ); DEFCSTRING( t2906, "~a~a~s~%" ); DEFSTATICTSCP( c2204 ); DEFCSTRING( t2907, "~a~s~%" ); DEFSTATICTSCP( c2173 ); DEFCSTRING( t2908, "~s is already traced" ); DEFSTATICTSCP( c2164 ); DEFCSTRING( t2909, "Argument is not a PROCEDURE name" ); DEFSTATICTSCP( c2163 ); DEFSTATICTSCP( c2148 ); DEFSTATICTSCP( c2147 ); DEFSTATICTSCP( c2146 ); DEFSTATICTSCP( c2145 ); DEFSTATICTSCP( c2144 ); DEFSTATICTSCP( c2143 ); DEFSTATICTSCP( t2910 ); DEFSTATICTSCP( c2135 ); static void init_constants() { TSCP X2, X1; c2795 = CSTRING_TSCP( t2843 ); CONSTANTEXP( ADR( c2795 ) ); c2765 = CSTRING_TSCP( t2844 ); CONSTANTEXP( ADR( c2765 ) ); c2757 = CSTRING_TSCP( t2845 ); CONSTANTEXP( ADR( c2757 ) ); c2752 = CSTRING_TSCP( t2846 ); CONSTANTEXP( ADR( c2752 ) ); c2724 = STRINGTOSYMBOL( CSTRING_TSCP( "***** inside ERROR" ) ); CONSTANTEXP( ADR( c2724 ) ); c2721 = CSTRING_TSCP( t2847 ); CONSTANTEXP( ADR( c2721 ) ); c2710 = CSTRING_TSCP( t2848 ); CONSTANTEXP( ADR( c2710 ) ); c2709 = CSTRING_TSCP( t2849 ); CONSTANTEXP( ADR( c2709 ) ); c2708 = CSTRING_TSCP( t2850 ); CONSTANTEXP( ADR( c2708 ) ); c2699 = EMPTYLIST; t2851 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-25" ) ); c2699 = CONS( t2851, c2699 ); t2852 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-24" ) ); c2699 = CONS( t2852, c2699 ); t2853 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-23" ) ); c2699 = CONS( t2853, c2699 ); t2854 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-22" ) ); c2699 = CONS( t2854, c2699 ); t2855 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-21" ) ); c2699 = CONS( t2855, c2699 ); t2856 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-20" ) ); c2699 = CONS( t2856, c2699 ); t2857 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-19" ) ); c2699 = CONS( t2857, c2699 ); t2858 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-18" ) ); c2699 = CONS( t2858, c2699 ); t2859 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-17" ) ); c2699 = CONS( t2859, c2699 ); t2860 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-16" ) ); c2699 = CONS( t2860, c2699 ); t2861 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-15" ) ); c2699 = CONS( t2861, c2699 ); t2862 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-14" ) ); c2699 = CONS( t2862, c2699 ); t2863 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-13" ) ); c2699 = CONS( t2863, c2699 ); t2864 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-12" ) ); c2699 = CONS( t2864, c2699 ); t2865 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-11" ) ); c2699 = CONS( t2865, c2699 ); t2866 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-10" ) ); c2699 = CONS( t2866, c2699 ); t2867 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-9" ) ); c2699 = CONS( t2867, c2699 ); t2868 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-8" ) ); c2699 = CONS( t2868, c2699 ); t2869 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-7" ) ); c2699 = CONS( t2869, c2699 ); t2870 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-6" ) ); c2699 = CONS( t2870, c2699 ); t2871 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-5" ) ); c2699 = CONS( t2871, c2699 ); t2872 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-4" ) ); c2699 = CONS( t2872, c2699 ); t2873 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-3" ) ); c2699 = CONS( t2873, c2699 ); t2874 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-2" ) ); c2699 = CONS( t2874, c2699 ); t2875 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-1" ) ); c2699 = CONS( t2875, c2699 ); t2876 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-0" ) ); c2699 = CONS( t2876, c2699 ); CONSTANTEXP( ADR( c2699 ) ); c2698 = STRINGTOSYMBOL( CSTRING_TSCP( "INTERACTIVE" ) ); CONSTANTEXP( ADR( c2698 ) ); c2693 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV-0" ) ); CONSTANTEXP( ADR( c2693 ) ); c2670 = CSTRING_TSCP( t2877 ); CONSTANTEXP( ADR( c2670 ) ); c2669 = CSTRING_TSCP( t2878 ); CONSTANTEXP( ADR( c2669 ) ); c2667 = CSTRING_TSCP( t2879 ); CONSTANTEXP( ADR( c2667 ) ); c2666 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c2666 ) ); c2645 = CSTRING_TSCP( t2880 ); CONSTANTEXP( ADR( c2645 ) ); c2644 = CSTRING_TSCP( t2881 ); CONSTANTEXP( ADR( c2644 ) ); c2640 = EMPTYLIST; t2882 = CSTRING_TSCP( t2883 ); c2640 = CONS( t2882, c2640 ); t2884 = CSTRING_TSCP( t2885 ); c2640 = CONS( t2884, c2640 ); CONSTANTEXP( ADR( c2640 ) ); c2541 = CSTRING_TSCP( t2886 ); CONSTANTEXP( ADR( c2541 ) ); c2536 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUNBPT" ) ); CONSTANTEXP( ADR( c2536 ) ); c2471 = STRINGTOSYMBOL( CSTRING_TSCP( "UNBPT" ) ); CONSTANTEXP( ADR( c2471 ) ); c2464 = STRINGTOSYMBOL( CSTRING_TSCP( "EMBEDDED" ) ); CONSTANTEXP( ADR( c2464 ) ); c2460 = CSTRING_TSCP( t2887 ); CONSTANTEXP( ADR( c2460 ) ); c2459 = STRINGTOSYMBOL( CSTRING_TSCP( "RESULT" ) ); CONSTANTEXP( ADR( c2459 ) ); c2458 = CSTRING_TSCP( t2888 ); CONSTANTEXP( ADR( c2458 ) ); c2445 = CSTRING_TSCP( t2889 ); CONSTANTEXP( ADR( c2445 ) ); c2444 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV" ) ); CONSTANTEXP( ADR( c2444 ) ); c2443 = STRINGTOSYMBOL( CSTRING_TSCP( "PROMPT" ) ); CONSTANTEXP( ADR( c2443 ) ); c2442 = CSTRING_TSCP( t2890 ); CONSTANTEXP( ADR( c2442 ) ); c2441 = STRINGTOSYMBOL( CSTRING_TSCP( "HEADER" ) ); CONSTANTEXP( ADR( c2441 ) ); c2424 = CSTRING_TSCP( t2891 ); CONSTANTEXP( ADR( c2424 ) ); c2423 = CSTRING_TSCP( t2892 ); CONSTANTEXP( ADR( c2423 ) ); c2410 = CSTRING_TSCP( t2893 ); CONSTANTEXP( ADR( c2410 ) ); c2393 = CSTRING_TSCP( t2894 ); CONSTANTEXP( ADR( c2393 ) ); c2391 = STRINGTOSYMBOL( CSTRING_TSCP( "BACKTRACE:" ) ); CONSTANTEXP( ADR( c2391 ) ); c2365 = CSTRING_TSCP( t2895 ); CONSTANTEXP( ADR( c2365 ) ); c2363 = CSTRING_TSCP( t2896 ); CONSTANTEXP( ADR( c2363 ) ); c2362 = STRINGTOSYMBOL( CSTRING_TSCP( "PROCEED" ) ); CONSTANTEXP( ADR( c2362 ) ); c2341 = EMPTYLIST; t2897 = STRINGTOSYMBOL( CSTRING_TSCP( "BPT-PROCS" ) ); c2341 = CONS( t2897, c2341 ); X1 = EMPTYLIST; X2 = EMPTYLIST; t2898 = STRINGTOSYMBOL( CSTRING_TSCP( "X" ) ); X2 = CONS( t2898, X2 ); t2899 = STRINGTOSYMBOL( CSTRING_TSCP( "CAR" ) ); X2 = CONS( t2899, X2 ); X1 = CONS( X2, X1 ); X2 = EMPTYLIST; X2 = CONS( t2898, X2 ); X1 = CONS( X2, X1 ); t2900 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); X1 = CONS( t2900, X1 ); c2341 = CONS( X1, c2341 ); t2901 = STRINGTOSYMBOL( CSTRING_TSCP( "MAP" ) ); c2341 = CONS( t2901, c2341 ); CONSTANTEXP( ADR( c2341 ) ); c2326 = STRINGTOSYMBOL( CSTRING_TSCP( "LIST" ) ); CONSTANTEXP( ADR( c2326 ) ); c2325 = STRINGTOSYMBOL( CSTRING_TSCP( "DOBPT" ) ); CONSTANTEXP( ADR( c2325 ) ); c2324 = STRINGTOSYMBOL( CSTRING_TSCP( "APPLY" ) ); CONSTANTEXP( ADR( c2324 ) ); c2321 = CSTRING_TSCP( t2902 ); CONSTANTEXP( ADR( c2321 ) ); c2305 = STRINGTOSYMBOL( CSTRING_TSCP( "BPT" ) ); CONSTANTEXP( ADR( c2305 ) ); c2290 = CSTRING_TSCP( t2903 ); CONSTANTEXP( ADR( c2290 ) ); c2285 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUNTRACE" ) ); CONSTANTEXP( ADR( c2285 ) ); c2270 = CSTRING_TSCP( t2904 ); CONSTANTEXP( ADR( c2270 ) ); c2269 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2269 ) ); c2218 = STRINGTOSYMBOL( CSTRING_TSCP( "UNTRACE" ) ); CONSTANTEXP( ADR( c2218 ) ); c2217 = CSTRING_TSCP( t2905 ); CONSTANTEXP( ADR( c2217 ) ); c2204 = CSTRING_TSCP( t2906 ); CONSTANTEXP( ADR( c2204 ) ); c2173 = CSTRING_TSCP( t2907 ); CONSTANTEXP( ADR( c2173 ) ); c2164 = CSTRING_TSCP( t2908 ); CONSTANTEXP( ADR( c2164 ) ); c2163 = CSTRING_TSCP( t2909 ); CONSTANTEXP( ADR( c2163 ) ); c2148 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2148 ) ); c2147 = STRINGTOSYMBOL( CSTRING_TSCP( "DOTRACE" ) ); CONSTANTEXP( ADR( c2147 ) ); c2146 = STRINGTOSYMBOL( CSTRING_TSCP( "F" ) ); CONSTANTEXP( ADR( c2146 ) ); c2145 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2145 ) ); c2144 = STRINGTOSYMBOL( CSTRING_TSCP( "MAP" ) ); CONSTANTEXP( ADR( c2144 ) ); c2143 = EMPTYLIST; t2910 = STRINGTOSYMBOL( CSTRING_TSCP( "TRACED-PROCS" ) ); c2143 = CONS( t2910, c2143 ); X1 = EMPTYLIST; X2 = EMPTYLIST; X2 = CONS( t2898, X2 ); X2 = CONS( t2899, X2 ); X1 = CONS( X2, X1 ); X2 = EMPTYLIST; X2 = CONS( t2898, X2 ); X1 = CONS( X2, X1 ); X1 = CONS( c2145, X1 ); c2143 = CONS( X1, c2143 ); c2143 = CONS( c2144, c2143 ); CONSTANTEXP( ADR( c2143 ) ); c2135 = STRINGTOSYMBOL( CSTRING_TSCP( "TRACE" ) ); CONSTANTEXP( ADR( c2135 ) ); } DEFTSCP( scdebug_trace_2dlevel_v ); DEFCSTRING( t2911, "SCDEBUG_TRACE-LEVEL" ); DEFTSCP( scdebug_traced_2dprocs_v ); DEFCSTRING( t2912, "TRACED-PROCS" ); DEFTSCP( scdebug_bpt_2dprocs_v ); DEFCSTRING( t2913, "BPT-PROCS" ); DEFTSCP( scdebug__2aargs_2a_v ); DEFCSTRING( t2914, "*ARGS*" ); DEFTSCP( scdebug__2aresult_2a_v ); DEFCSTRING( t2915, "*RESULT*" ); DEFTSCP( scdebug__2abpt_2denv_2a_v ); DEFCSTRING( t2916, "*BPT-ENV*" ); EXTERNTSCPP( scexpand_install_2dexpander, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scexpand_install_2dexpander_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); TSCP scdebug_l2136( x2137, e2138 ) TSCP x2137, e2138; { TSCP X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2136 [inside TOP-LEVEL]" ); if ( EQ( TSCPTAG( x2137 ), PAIRTAG ) ) goto L2919; scrt1__24__cdr_2derror( x2137 ); L2919: if ( FALSE( PAIR_CDR( x2137 ) ) ) goto L2921; X1 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X1 = CONS( scrt1_cons_2a( c2148, CONS( PAIR_CDR( x2137 ), X2 ) ), X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( c2147, CONS( c2146, X3 ) ), X2 ); POPSTACKTRACE( scrt1_cons_2a( c2144, CONS( scrt1_cons_2a( c2145, CONS( scrt1_cons_2a( c2146, CONS( EMPTYLIST, EMPTYLIST ) ), X2 ) ), X1 ) ) ); L2921: POPSTACKTRACE( c2143 ); } DEFTSCP( scdebug_dotrace_v ); DEFCSTRING( t2924, "DOTRACE" ); EXTERNTSCPP( scrt1_assoc, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assoc_v ); EXTERNTSCPP( scdebug_dountrace, XAL1( TSCP ) ); EXTERNTSCP( scdebug_dountrace_v ); EXTERNTSCPP( scdebug_dounbpt, XAL1( TSCP ) ); EXTERNTSCP( scdebug_dounbpt_v ); EXTERNTSCPP( scrt2_top_2dlevel_2dvalue, XAL1( TSCP ) ); EXTERNTSCP( scrt2_top_2dlevel_2dvalue_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scdebug_tracer, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scdebug_tracer_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt2_2dvalue_21_c9d2a496, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_2dvalue_21_c9d2a496_v ); TSCP scdebug_dotrace( n2155 ) TSCP n2155; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2924 ); if ( FALSE( scrt1_assoc( n2155, scdebug_traced_2dprocs_v ) ) ) goto L2926; scdebug_dountrace( n2155 ); L2926: if ( FALSE( scrt1_assoc( n2155, scdebug_bpt_2dprocs_v ) ) ) goto L2928; scdebug_dounbpt( n2155 ); L2928: X1 = FALSEVALUE; X2 = scrt2_top_2dlevel_2dvalue( n2155 ); X1 = CONS( X1, EMPTYLIST ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), PROCEDURETAG ) ) ) goto L2931; scdebug_error( c2135, c2163, EMPTYLIST ); L2931: if ( FALSE( scrt1_assoc( n2155, scdebug_traced_2dprocs_v ) ) ) goto L2933; scdebug_error( c2135, c2164, CONS( n2155, EMPTYLIST ) ); L2933: X3 = scdebug_tracer( n2155, X2 ); SETGEN( PAIR_CAR( X1 ), X3 ); X6 = sc_cons( PAIR_CAR( X1 ), EMPTYLIST ); X5 = sc_cons( X2, X6 ); X4 = sc_cons( n2155, X5 ); X3 = X4; scdebug_traced_2dprocs_v = sc_cons( X3, scdebug_traced_2dprocs_v ); scrt2_2dvalue_21_c9d2a496( n2155, PAIR_CAR( X1 ) ); POPSTACKTRACE( n2155 ); } DEFTSCP( scdebug_tracer_v ); DEFCSTRING( t2936, "TRACER" ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCP( scrt5_trace_2doutput_2dport_v ); EXTERNTSCPP( sc_make_2dstring, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dstring_v ); EXTERNTSCPP( scrt2_min_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_min_2dtwo_v ); EXTERNTSCPP( scrt2__2a_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2a_2dtwo_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( sc_apply_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_apply_2dtwo_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); TSCP scdebug_l2171( x2172, c2938 ) TSCP x2172, c2938; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2171 [inside TRACER]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c2938, 0 ); X2 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c2938, 1 ); X4 = CONS( sc_cons( DISPLAY( 0 ), x2172 ), EMPTYLIST ); X7 = scdebug_trace_2dlevel_v; if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( _TSCP( 60 ) ) ), 3 ) ) goto L2941; if ( GTE( _S2CINT( X7 ), _S2CINT( _TSCP( 60 ) ) ) ) goto L2943; X6 = X7; goto L2942; L2943: X6 = _TSCP( 60 ); goto L2942; L2941: X6 = scrt2_min_2dtwo( X7, _TSCP( 60 ) ); L2942: if ( BITAND( BITOR( _S2CINT( _TSCP( 8 ) ), _S2CINT( X6 ) ), 3 ) ) goto L2946; X5 = _TSCP( ITIMES( FIXED_C( _TSCP( 8 ) ), _S2CINT( X6 ) ) ); goto L2947; L2946: X5 = scrt2__2a_2dtwo( _TSCP( 8 ), X6 ); L2947: X4 = CONS( sc_make_2dstring( X5, CONS( _TSCP( 8210 ), EMPTYLIST ) ), X4 ); scrt6_format( scrt5_trace_2doutput_2dport_v, CONS( c2173, X4 ) ); X4 = scdebug_trace_2dlevel_v; if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2949; X5 = _TSCP( IPLUS( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2950; L2949: X5 = scrt2__2b_2dtwo( X4, _TSCP( 4 ) ); L2950: scdebug_trace_2dlevel_v = X5; X4 = sc_apply_2dtwo( DISPLAY( 1 ), x2172 ); X5 = scdebug_trace_2dlevel_v; if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2953; X6 = _TSCP( IDIFFERENCE( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2954; L2953: X6 = scrt2__2d_2dtwo( X5, _TSCP( 4 ) ); L2954: scdebug_trace_2dlevel_v = X6; X5 = CONS( X4, EMPTYLIST ); X5 = CONS( c2217, X5 ); X8 = scdebug_trace_2dlevel_v; if ( BITAND( BITOR( _S2CINT( X8 ), _S2CINT( _TSCP( 60 ) ) ), 3 ) ) goto L2956; if ( GTE( _S2CINT( X8 ), _S2CINT( _TSCP( 60 ) ) ) ) goto L2958; X7 = X8; goto L2957; L2958: X7 = _TSCP( 60 ); goto L2957; L2956: X7 = scrt2_min_2dtwo( X8, _TSCP( 60 ) ); L2957: if ( BITAND( BITOR( _S2CINT( _TSCP( 8 ) ), _S2CINT( X7 ) ), 3 ) ) goto L2961; X6 = _TSCP( ITIMES( FIXED_C( _TSCP( 8 ) ), _S2CINT( X7 ) ) ); goto L2962; L2961: X6 = scrt2__2a_2dtwo( _TSCP( 8 ), X7 ); L2962: X5 = CONS( sc_make_2dstring( X6, CONS( _TSCP( 8210 ), EMPTYLIST ) ), X5 ); scrt6_format( scrt5_trace_2doutput_2dport_v, CONS( c2204, X5 ) ); X3 = X4; DISPLAY( 0 ) = X1; DISPLAY( 1 ) = X2; POPSTACKTRACE( X3 ); } TSCP scdebug_tracer( n2169, p2170 ) TSCP n2169, p2170; { TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SDVAL; PUSHSTACKTRACE( t2936 ); DISPLAY( 0 ) = n2169; DISPLAY( 1 ) = p2170; SDVAL = MAKEPROCEDURE( 0, 1, scdebug_l2171, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 0 ), DISPLAY( 1 ) ) ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; POPSTACKTRACE( SDVAL ); } EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); TSCP scdebug_l2219( x2220, e2221 ) TSCP x2220, e2221; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2219 [inside TOP-LEVEL]" ); x2220 = CONS( x2220, EMPTYLIST ); X2 = PAIR_CAR( x2220 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2967; scrt1__24__cdr_2derror( X2 ); L2967: X1 = PAIR_CDR( X2 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L2964; X2 = scdebug_traced_2dprocs_v; X3 = X2; X4 = EMPTYLIST; X5 = EMPTYLIST; L2971: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L2972; X1 = X4; goto L2983; L2972: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2975; scrt1__24__car_2derror( X3 ); L2975: X8 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L2979; scrt1__24__car_2derror( X8 ); L2979: X7 = PAIR_CAR( X8 ); X6 = sc_cons( X7, EMPTYLIST ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L2982; X7 = PAIR_CDR( X3 ); X5 = X6; X4 = X6; X3 = X7; GOBACK( L2971 ); L2982: X7 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L2987; scdebug_error( c2269, c2270, CONS( X5, EMPTYLIST ) ); L2987: X5 = SETGEN( PAIR_CDR( X5 ), X6 ); X3 = X7; GOBACK( L2971 ); L2983: SETGEN( PAIR_CAR( x2220 ), X1 ); goto L2965; L2964: X2 = PAIR_CAR( x2220 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2990; scrt1__24__cdr_2derror( X2 ); L2990: X1 = PAIR_CDR( X2 ); SETGEN( PAIR_CAR( x2220 ), X1 ); L2965: X1 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X1 = CONS( scrt1_cons_2a( c2148, CONS( PAIR_CAR( x2220 ), X2 ) ), X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( c2285, CONS( c2146, X3 ) ), X2 ); POPSTACKTRACE( scrt1_cons_2a( c2144, CONS( scrt1_cons_2a( c2145, CONS( scrt1_cons_2a( c2146, CONS( EMPTYLIST, EMPTYLIST ) ), X2 ) ), X1 ) ) ); } DEFTSCP( scdebug_dountrace_v ); DEFCSTRING( t2992, "DOUNTRACE" ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( scrt1_remove, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_remove_v ); TSCP scdebug_dountrace( n2287 ) TSCP n2287; { TSCP X3, X2, X1; PUSHSTACKTRACE( t2992 ); X1 = scrt1_assoc( n2287, scdebug_traced_2dprocs_v ); if ( TRUE( X1 ) ) goto L2995; scdebug_error( c2218, c2290, CONS( n2287, EMPTYLIST ) ); L2995: X2 = scrt2_top_2dlevel_2dvalue( n2287 ); X3 = scrt1_caddr( X1 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X3 ) ) ) goto L2997; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3000; scrt1__24__cdr_2derror( X1 ); L3000: X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3003; scrt1__24__car_2derror( X3 ); L3003: X2 = PAIR_CAR( X3 ); scrt2_2dvalue_21_c9d2a496( n2287, X2 ); L2997: scdebug_traced_2dprocs_v = scrt1_remove( X1, scdebug_traced_2dprocs_v ); POPSTACKTRACE( n2287 ); } EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); TSCP scdebug_l2306( x2307, e2308 ) TSCP x2307, e2308; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2306 [inside TOP-LEVEL]" ); X1 = scrt1_length( x2307 ); if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L3007; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 8 ) ) ) ) goto L3009; X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( x2307 ), PAIRTAG ) ) goto L3012; scrt1__24__cdr_2derror( x2307 ); L3012: X2 = CONS( scrt1_cons_2a( c2148, CONS( PAIR_CDR( x2307 ), X3 ) ), X2 ); POPSTACKTRACE( scrt1_cons_2a( c2324, CONS( c2325, X2 ) ) ); L3009: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 12 ) ) ) ) goto L3014; X4 = scrt1_caddr( x2307 ); X3 = e2308; X3 = UNKNOWNCALL( X3, 2 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( X4, e2308, PROCEDURE_CLOSURE( X3 ) ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( scrt1_cons_2a( c2148, CONS( X2, X5 ) ), X4 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( x2307 ), PAIRTAG ) ) goto L3018; scrt1__24__cdr_2derror( x2307 ); L3018: X6 = PAIR_CDR( x2307 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3021; scrt1__24__car_2derror( X6 ); L3021: X3 = CONS( scrt1_cons_2a( c2326, CONS( scrt1_cons_2a( c2148, CONS( PAIR_CAR( X6 ), X5 ) ), X4 ) ), X3 ); POPSTACKTRACE( scrt1_cons_2a( c2324, CONS( c2325, X3 ) ) ); L3014: POPSTACKTRACE( scdebug_error( c2305, c2321, EMPTYLIST ) ); L3007: POPSTACKTRACE( c2341 ); } DEFTSCP( scdebug_dobpt_v ); DEFCSTRING( t3023, "DOBPT" ); EXTERNTSCPP( scdebug_bpter, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_bpter_v ); EXTERNTSCPP( sceval_eval, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sceval_eval_v ); TSCP scdebug_dobpt( n2344, c2345 ) TSCP n2344, c2345; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3023 ); if ( FALSE( scrt1_assoc( n2344, scdebug_bpt_2dprocs_v ) ) ) goto L3025; scdebug_dounbpt( n2344 ); L3025: X1 = FALSEVALUE; X2 = scrt2_top_2dlevel_2dvalue( n2344 ); X1 = CONS( X1, EMPTYLIST ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), PROCEDURETAG ) ) ) goto L3028; scdebug_error( c2305, c2163, EMPTYLIST ); L3028: if ( FALSE( c2345 ) ) goto L3030; if ( EQ( TSCPTAG( c2345 ), PAIRTAG ) ) goto L3033; scrt1__24__car_2derror( c2345 ); L3033: X5 = PAIR_CAR( c2345 ); X4 = sceval_eval( X5, EMPTYLIST ); goto L3031; L3030: X4 = FALSEVALUE; L3031: X3 = scdebug_bpter( n2344, X2, X4 ); SETGEN( PAIR_CAR( X1 ), X3 ); X6 = sc_cons( PAIR_CAR( X1 ), EMPTYLIST ); X5 = sc_cons( X2, X6 ); X4 = sc_cons( n2344, X5 ); X3 = X4; scdebug_bpt_2dprocs_v = sc_cons( X3, scdebug_bpt_2dprocs_v ); scrt2_2dvalue_21_c9d2a496( n2344, PAIR_CAR( X1 ) ); POPSTACKTRACE( n2344 ); } DEFTSCP( scdebug_reset_2dbpt_v ); DEFCSTRING( t3036, "RESET-BPT" ); EXTERNTSCPP( scdebug_default_2dproceed, XAL0( ) ); EXTERNTSCP( scdebug_default_2dproceed_v ); EXTERNTSCP( scdebug_proceed_v ); TSCP scdebug_reset_2dbpt( ) { PUSHSTACKTRACE( t3036 ); scdebug_trace_2dlevel_v = _TSCP( 0 ); scdebug_proceed_v = scdebug_default_2dproceed_v; POPSTACKTRACE( SET( scdebug__2abpt_2denv_2a_v, FALSEVALUE ) ); } DEFTSCP( scdebug_default_2dproceed_v ); DEFCSTRING( t3038, "SCDEBUG_DEFAULT-PROCEED" ); TSCP scdebug_default_2dproceed( ) { PUSHSTACKTRACE( t3038 ); POPSTACKTRACE( scdebug_error( c2362, c2363, EMPTYLIST ) ); } DEFTSCP( scdebug_proceed_v ); DEFCSTRING( t3040, "PROCEED" ); DEFTSCP( scdebug_bpter_2dprocname_v ); DEFCSTRING( t3041, "SCDEBUG_BPTER-PROCNAME" ); DEFTSCP( scdebug_bpter_v ); DEFCSTRING( t3042, "SCDEBUG_BPTER" ); EXTERNTSCPP( scrt5_open_2doutput_2dstring, XAL0( ) ); EXTERNTSCP( scrt5_open_2doutput_2dstring_v ); EXTERNTSCPP( scdebug_dobacktrace, XAL4( TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_dobacktrace_v ); EXTERNTSCPP( scrt6_get_2doutput_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt6_get_2doutput_2dstring_v ); EXTERNTSCPP( scrt6_display, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_display_v ); EXTERNTSCP( scrt5_stderr_2dport_v ); TSCP scdebug_l2390( c3067 ) TSCP c3067; { TSCP X2, X1; PUSHSTACKTRACE( "scdebug_l2390 [inside BPTER]" ); X1 = DISPLAY( 3 ); DISPLAY( 3 ) = CLOSURE_VAR( c3067, 0 ); scrt6_display( DISPLAY( 3 ), CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); X2 = c2391; DISPLAY( 3 ) = X1; POPSTACKTRACE( X2 ); } EXTERNTSCP( scdebug_backtrace_v ); EXTERNTSCPP( scrt6_write, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_write_v ); EXTERNTSCPP( scrt6_newline, XAL1( TSCP ) ); EXTERNTSCP( scrt6_newline_v ); TSCP scdebug_l2396( c3071 ) TSCP c3071; { TSCP X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2396 [inside BPTER]" ); X1 = DISPLAY( 3 ); DISPLAY( 3 ) = CLOSURE_VAR( c3071, 0 ); X3 = DISPLAY( 3 ); X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( TRUEVALUE, PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 3 ) = X1; POPSTACKTRACE( X2 ); } EXTERNTSCPP( screp_jump_2dto_2dscheme2c, XAL1( TSCP ) ); EXTERNTSCP( screp_jump_2dto_2dscheme2c_v ); EXTERNTSCP( screp__2ascheme2c_2dresult_2a_v ); TSCP scdebug_l2394( c2395, c3069 ) TSCP c2395, c3069; { TSCP X1; TSCP SD3 = DISPLAY( 3 ); TSCP SDVAL; PUSHSTACKTRACE( "scdebug_l2394 [inside BPTER]" ); DISPLAY( 3 ) = c2395; scdebug_proceed_v = MAKEPROCEDURE( 0, 0, scdebug_l2396, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 3 ) ) ); X1 = CONS( _TSCP( 16 ), EMPTYLIST ); SDVAL = screp_jump_2dto_2dscheme2c( CONS( screp__2ascheme2c_2dresult_2a_v, X1 ) ); DISPLAY( 3 ) = SD3; POPSTACKTRACE( SDVAL ); } EXTERNTSCP( sc_ntinuation_1af38b9f_v ); TSCP scdebug_l2413( x2414, c3081 ) TSCP x2414, c3081; { TSCP X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2413 [inside BPTER]" ); X1 = DISPLAY( 3 ); DISPLAY( 3 ) = CLOSURE_VAR( c3081, 0 ); if ( EQ( _S2CUINT( x2414 ), _S2CUINT( EMPTYLIST ) ) ) goto L3083; if ( EQ( TSCPTAG( x2414 ), PAIRTAG ) ) goto L3086; scrt1__24__car_2derror( x2414 ); L3086: scdebug__2aresult_2a_v = PAIR_CAR( x2414 ); L3083: X3 = DISPLAY( 3 ); X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( TRUEVALUE, PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 3 ) = X1; POPSTACKTRACE( X2 ); } TSCP scdebug_l2411( c2412, c3079 ) TSCP c2412, c3079; { TSCP X1; TSCP SD3 = DISPLAY( 3 ); TSCP SDVAL; PUSHSTACKTRACE( "scdebug_l2411 [inside BPTER]" ); DISPLAY( 3 ) = c2412; scdebug_proceed_v = MAKEPROCEDURE( 0, 1, scdebug_l2413, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 3 ) ) ); X1 = CONS( _TSCP( 20 ), EMPTYLIST ); SDVAL = screp_jump_2dto_2dscheme2c( CONS( screp__2ascheme2c_2dresult_2a_v, X1 ) ); DISPLAY( 3 ) = SD3; POPSTACKTRACE( SDVAL ); } TSCP scdebug_e2373( x2375, c3045 ) TSCP x2375, c3045; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; TSCP SD3 = DISPLAY( 3 ); TSCP SDVAL; PUSHSTACKTRACE( "EMBEDDED [inside BPTER]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3045, 0 ); X2 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3045, 1 ); X3 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c3045, 2 ); if ( FALSE( scdebug__2abpt_2denv_2a_v ) ) goto L3047; X5 = FALSEVALUE; goto L3048; L3047: X5 = TRUEVALUE; L3048: if ( FALSE( X5 ) ) goto L3062; if ( FALSE( DISPLAY( 2 ) ) ) goto L3053; X6 = FALSEVALUE; goto L3054; L3053: X6 = TRUEVALUE; L3054: if ( TRUE( X6 ) ) goto L3059; if ( TRUE( sc_apply_2dtwo( DISPLAY( 2 ), x2375 ) ) ) goto L3059; L3062: X4 = sc_apply_2dtwo( DISPLAY( 1 ), x2375 ); goto L3063; L3059: X5 = scrt5_open_2doutput_2dstring( ); X6 = scdebug_dobacktrace( c2423, c2424, _TSCP( 80 ), X5 ); scdebug__2aargs_2a_v = x2375; scdebug__2abpt_2denv_2a_v = X6; DISPLAY( 3 ) = scrt6_get_2doutput_2dstring( X5 ); scdebug_backtrace_v = MAKEPROCEDURE( 0, 0, scdebug_l2390, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 3 ) ) ); scrt6_write( scdebug_trace_2dlevel_v, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scrt6_display( c2393, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); X7 = sc_cons( DISPLAY( 0 ), x2375 ); scrt6_write( X7, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scrt6_newline( CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); X8 = MAKEPROCEDURE( 1, 0, scdebug_l2394, EMPTYLIST ); X7 = sc_ntinuation_1af38b9f_v; X7 = UNKNOWNCALL( X7, 1 ); VIA( PROCEDURE_CODE( X7 ) )( X8, PROCEDURE_CLOSURE( X7 ) ); scdebug__2abpt_2denv_2a_v = FALSEVALUE; X7 = scdebug_trace_2dlevel_v; if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X7 ) ), 3 ) ) goto L3074; X8 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X7 ) ) ); goto L3075; L3074: X8 = scrt2__2b_2dtwo( _TSCP( 4 ), X7 ); L3075: scdebug_trace_2dlevel_v = X8; scdebug__2aresult_2a_v = sc_apply_2dtwo( DISPLAY( 1 ), scdebug__2aargs_2a_v ); X7 = scdebug_trace_2dlevel_v; if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X7 ) ), 3 ) ) goto L3077; X8 = _TSCP( IDIFFERENCE( _S2CINT( _TSCP( 4 ) ), _S2CINT( X7 ) ) ); goto L3078; L3077: X8 = scrt2__2d_2dtwo( _TSCP( 4 ), X7 ); L3078: scdebug_trace_2dlevel_v = X8; scdebug__2aargs_2a_v = x2375; scdebug__2abpt_2denv_2a_v = X6; scrt6_write( scdebug_trace_2dlevel_v, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scrt6_display( c2410, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scrt6_write( scdebug__2aresult_2a_v, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scrt6_newline( CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); X8 = MAKEPROCEDURE( 1, 0, scdebug_l2411, EMPTYLIST ); X7 = sc_ntinuation_1af38b9f_v; X7 = UNKNOWNCALL( X7, 1 ); VIA( PROCEDURE_CODE( X7 ) )( X8, PROCEDURE_CLOSURE( X7 ) ); scdebug__2abpt_2denv_2a_v = FALSEVALUE; X4 = scdebug__2aresult_2a_v; L3063: DISPLAY( 0 ) = X1; DISPLAY( 1 ) = X2; DISPLAY( 2 ) = X3; SDVAL = X4; DISPLAY( 3 ) = SD3; POPSTACKTRACE( SDVAL ); } EXTERNTSCPP( scrt6_le_2dtasks_e4d983f4, XAL1( TSCP ) ); EXTERNTSCP( scrt6_le_2dtasks_e4d983f4_v ); EXTERNTSCPP( screp_read_2deval_2dprint, XAL1( TSCP ) ); EXTERNTSCP( screp_read_2deval_2dprint_v ); TSCP scdebug_x2372( a2427 ) TSCP a2427; { TSCP X2, X1; PUSHSTACKTRACE( "XEQ [inside BPTER]" ); X1 = scrt6_le_2dtasks_e4d983f4( FALSEVALUE ); X2 = sc_apply_2dtwo( screp_read_2deval_2dprint_v, a2427 ); scrt6_le_2dtasks_e4d983f4( X1 ); POPSTACKTRACE( X2 ); } EXTERNTSCPP( scdebug_dbacktrace_a8071371, XAL1( TSCP ) ); EXTERNTSCP( scdebug_dbacktrace_a8071371_v ); TSCP scdebug_i2371( x2433, c3091 ) TSCP x2433, c3091; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "INTERACTIVE [inside BPTER]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3091, 0 ); X2 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3091, 1 ); X3 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c3091, 2 ); if ( FALSE( DISPLAY( 2 ) ) ) goto L3093; X5 = FALSEVALUE; goto L3094; L3093: X5 = TRUEVALUE; L3094: if ( TRUE( X5 ) ) goto L3099; if ( TRUE( sc_apply_2dtwo( DISPLAY( 2 ), x2433 ) ) ) goto L3099; X4 = sc_apply_2dtwo( DISPLAY( 1 ), x2433 ); goto L3102; L3099: X5 = scrt6_format( c2460, CONS( scdebug_trace_2dlevel_v, EMPTYLIST ) ); scdebug_backtrace_v = scdebug_dbacktrace_a8071371_v; scdebug__2aargs_2a_v = x2433; X6 = CONS( scdebug_dobacktrace( scdebug_bpter_2dprocname_v, c2445, _TSCP( 80 ), FALSEVALUE ), EMPTYLIST ); X6 = CONS( c2444, X6 ); X6 = CONS( X5, X6 ); X6 = CONS( c2443, X6 ); X7 = CONS( sc_cons( DISPLAY( 0 ), x2433 ), EMPTYLIST ); X6 = CONS( scrt6_format( c2442, CONS( scdebug_trace_2dlevel_v, X7 ) ), X6 ); scdebug_x2372( CONS( c2441, X6 ) ); X6 = scdebug_trace_2dlevel_v; if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3105; X7 = _TSCP( IPLUS( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3106; L3105: X7 = scrt2__2b_2dtwo( X6, _TSCP( 4 ) ); L3106: scdebug_trace_2dlevel_v = X7; scdebug__2aresult_2a_v = sc_apply_2dtwo( DISPLAY( 1 ), scdebug__2aargs_2a_v ); X6 = scdebug_trace_2dlevel_v; if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3108; X7 = _TSCP( IDIFFERENCE( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3109; L3108: X7 = scrt2__2d_2dtwo( X6, _TSCP( 4 ) ); L3109: scdebug_trace_2dlevel_v = X7; X6 = CONS( scdebug_dobacktrace( scdebug_bpter_2dprocname_v, c2445, _TSCP( 80 ), FALSEVALUE ), EMPTYLIST ); X6 = CONS( c2444, X6 ); X6 = CONS( scdebug__2aresult_2a_v, X6 ); X6 = CONS( c2459, X6 ); X6 = CONS( X5, X6 ); X6 = CONS( c2443, X6 ); X7 = CONS( scdebug__2aresult_2a_v, EMPTYLIST ); X6 = CONS( scrt6_format( c2458, CONS( scdebug_trace_2dlevel_v, X7 ) ), X6 ); X4 = scdebug_x2372( CONS( c2441, X6 ) ); L3102: DISPLAY( 0 ) = X1; DISPLAY( 1 ) = X2; DISPLAY( 2 ) = X3; POPSTACKTRACE( X4 ); } EXTERNTSCPP( sc_scheme_2dmode, XAL0( ) ); EXTERNTSCP( sc_scheme_2dmode_v ); TSCP scdebug_bpter( n2367, p2368, c2369 ) TSCP n2367, p2368, c2369; { TSCP X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( t3042 ); DISPLAY( 0 ) = n2367; DISPLAY( 1 ) = p2368; DISPLAY( 2 ) = c2369; X1 = _TSCP( 0 ); X2 = _TSCP( 0 ); X2 = CONS( X2, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); X3 = MAKEPROCEDURE( 0, 1, scdebug_e2373, MAKECLOSURE( EMPTYLIST, 3, DISPLAY( 0 ), DISPLAY( 1 ), DISPLAY( 2 ) ) ); SETGEN( PAIR_CAR( X1 ), X3 ); X3 = MAKEPROCEDURE( 0, 1, scdebug_i2371, MAKECLOSURE( EMPTYLIST, 3, DISPLAY( 0 ), DISPLAY( 1 ), DISPLAY( 2 ) ) ); SETGEN( PAIR_CAR( X2 ), X3 ); X3 = sc_scheme_2dmode( ); if ( EQ( _S2CUINT( X3 ), _S2CUINT( c2464 ) ) ) goto L3110; SDVAL = PAIR_CAR( X2 ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); L3110: SDVAL = PAIR_CAR( X1 ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } DEFTSCP( scdebug_backtrace_v ); DEFCSTRING( t3112, "BACKTRACE" ); DEFTSCP( scdebug_dbacktrace_a8071371_v ); DEFCSTRING( t3113, "SCDEBUG_INTERACTIVE-BACKTRACE" ); EXTERNTSCP( scrt5_debug_2doutput_2dport_v ); TSCP scdebug_dbacktrace_a8071371( c2466 ) TSCP c2466; { TSCP X1; PUSHSTACKTRACE( t3113 ); if ( FALSE( c2466 ) ) goto L3115; if ( EQ( TSCPTAG( c2466 ), PAIRTAG ) ) goto L3118; scrt1__24__car_2derror( c2466 ); L3118: X1 = PAIR_CAR( c2466 ); goto L3116; L3115: X1 = _TSCP( 80 ); L3116: scdebug_dobacktrace( scdebug_bpter_2dprocname_v, c2445, X1, scrt5_debug_2doutput_2dport_v ); POPSTACKTRACE( FALSEVALUE ); } TSCP scdebug_l2472( x2473, e2474 ) TSCP x2473, e2474; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2472 [inside TOP-LEVEL]" ); x2473 = CONS( x2473, EMPTYLIST ); X2 = PAIR_CAR( x2473 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3124; scrt1__24__cdr_2derror( X2 ); L3124: X1 = PAIR_CDR( X2 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3121; X2 = scdebug_bpt_2dprocs_v; X3 = X2; X4 = EMPTYLIST; X5 = EMPTYLIST; L3128: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3129; X1 = X4; goto L3140; L3129: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3132; scrt1__24__car_2derror( X3 ); L3132: X8 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3136; scrt1__24__car_2derror( X8 ); L3136: X7 = PAIR_CAR( X8 ); X6 = sc_cons( X7, EMPTYLIST ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3139; X7 = PAIR_CDR( X3 ); X5 = X6; X4 = X6; X3 = X7; GOBACK( L3128 ); L3139: X7 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3144; scdebug_error( c2269, c2270, CONS( X5, EMPTYLIST ) ); L3144: X5 = SETGEN( PAIR_CDR( X5 ), X6 ); X3 = X7; GOBACK( L3128 ); L3140: SETGEN( PAIR_CAR( x2473 ), X1 ); goto L3122; L3121: X2 = PAIR_CAR( x2473 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3147; scrt1__24__cdr_2derror( X2 ); L3147: X1 = PAIR_CDR( X2 ); SETGEN( PAIR_CAR( x2473 ), X1 ); L3122: X1 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X1 = CONS( scrt1_cons_2a( c2148, CONS( PAIR_CAR( x2473 ), X2 ) ), X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( c2536, CONS( c2146, X3 ) ), X2 ); POPSTACKTRACE( scrt1_cons_2a( c2144, CONS( scrt1_cons_2a( c2145, CONS( scrt1_cons_2a( c2146, CONS( EMPTYLIST, EMPTYLIST ) ), X2 ) ), X1 ) ) ); } DEFTSCP( scdebug_dounbpt_v ); DEFCSTRING( t3149, "DOUNBPT" ); TSCP scdebug_dounbpt( n2538 ) TSCP n2538; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3149 ); X1 = scrt1_assoc( n2538, scdebug_bpt_2dprocs_v ); if ( TRUE( X1 ) ) goto L3152; scdebug_error( c2471, c2541, CONS( n2538, EMPTYLIST ) ); L3152: X2 = scrt2_top_2dlevel_2dvalue( n2538 ); X3 = scrt1_caddr( X1 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X3 ) ) ) goto L3154; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3157; scrt1__24__cdr_2derror( X1 ); L3157: X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3160; scrt1__24__car_2derror( X3 ); L3160: X2 = PAIR_CAR( X3 ); scrt2_2dvalue_21_c9d2a496( n2538, X2 ); L3154: scdebug_bpt_2dprocs_v = scrt1_remove( X1, scdebug_bpt_2dprocs_v ); if ( NEQ( _S2CUINT( scdebug_bpt_2dprocs_v ), _S2CUINT( EMPTYLIST ) ) ) goto L3162; scdebug_reset_2dbpt( ); L3162: POPSTACKTRACE( n2538 ); } DEFTSCP( scdebug_procnamex_v ); DEFCSTRING( t3164, "SCDEBUG_PROCNAMEX" ); DEFTSCP( scdebug_expx_v ); DEFCSTRING( t3168, "SCDEBUG_EXPX" ); DEFTSCP( scdebug_dobacktrace_v ); DEFCSTRING( t3172, "SCDEBUG_DOBACKTRACE" ); EXTERNTSCP( sc_emptystring ); EXTERNTSCPP( scrt6_set_2dwrite_2dcircle_21, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_set_2dwrite_2dcircle_21_v ); EXTERNTSCPP( scrt6_set_2dwrite_2dlevel_21, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_set_2dwrite_2dlevel_21_v ); EXTERNTSCPP( scrt6_set_2dwrite_2dlength_21, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_set_2dwrite_2dlength_21_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( sc_schemepointer, XAL1( TSCP ) ); EXTERNTSCPP( scrt4_c_2dtscp_2dref, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_c_2dtscp_2dref_v ); EXTERNTSCPP( sc_c_2dstring_2d_3estring, XAL1( TSCP ) ); EXTERNTSCP( sc_c_2dstring_2d_3estring_v ); EXTERNTSCPP( scrt4_c_2ds2cuint_2dref, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_c_2ds2cuint_2dref_v ); EXTERNTSCPP( scrt1_member, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_member_v ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( scrt3_substring, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt3_substring_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_assq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assq_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); TSCP scdebug_dobacktrace( s2575, s2576, l2577, p2578 ) TSCP s2575, s2576, l2577, p2578; { TSCP X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3172 ); s2575 = CONS( s2575, EMPTYLIST ); l2577 = CONS( l2577, EMPTYLIST ); X1 = S2CUINT_TSCP( sc_stacktrace ); X3 = sc_scheme_2dmode( ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2698 ) ) ); X3 = sc_emptystring; X4 = EMPTYLIST; X5 = c2699; X7 = scrt5_open_2doutput_2dstring( ); scrt6_set_2dwrite_2dcircle_21( TRUEVALUE, CONS( X7, EMPTYLIST ) ); scrt6_set_2dwrite_2dlevel_21( _TSCP( 40 ), CONS( X7, EMPTYLIST ) ); scrt6_set_2dwrite_2dlength_21( _TSCP( 80 ), CONS( X7, EMPTYLIST ) ); X6 = X7; L3176: X5 = CONS( X5, EMPTYLIST ); X4 = CONS( X4, EMPTYLIST ); X3 = CONS( X3, EMPTYLIST ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L3177; X7 = BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ); goto L3178; L3177: X7 = scrt2__3d_2dtwo( X1, _TSCP( 0 ) ); L3178: if ( TRUE( X7 ) ) goto L3183; X9 = PAIR_CAR( l2577 ); if ( BITAND( BITOR( _S2CINT( X9 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L3185; X8 = BOOLEAN( EQ( _S2CUINT( X9 ), _S2CUINT( _TSCP( 0 ) ) ) ); goto L3186; L3185: X8 = scrt2__3d_2dtwo( X9, _TSCP( 0 ) ); L3186: if ( TRUE( X8 ) ) goto L3183; if ( EQ( _S2CUINT( PAIR_CAR( X5 ) ), _S2CUINT( EMPTYLIST ) ) ) goto L3183; if ( FALSE( PAIR_CAR( s2575 ) ) ) goto L3196; X9 = FALSEVALUE; goto L3197; L3196: X9 = TRUEVALUE; L3197: if ( FALSE( X9 ) ) goto L3204; if ( TRUE( scrt1_equal_3f( PAIR_CAR( X3 ), s2576 ) ) ) goto L3183; L3204: X9 = scrt4_c_2dtscp_2dref( X1, scdebug_procnamex_v ); X8 = sc_schemepointer( X9 ); if ( TRUE( X8 ) ) goto L3210; X9 = scrt4_c_2dtscp_2dref( X1, scdebug_procnamex_v ); if ( EQ( _S2CUINT( X9 ), _S2CUINT( EMPTYLIST ) ) ) goto L3210; X9 = scrt4_c_2ds2cuint_2dref( X1, scdebug_procnamex_v ); X7 = sc_c_2dstring_2d_3estring( X9 ); goto L3213; L3210: X7 = scrt4_c_2dtscp_2dref( X1, scdebug_procnamex_v ); L3213: SETGEN( PAIR_CAR( X3 ), X7 ); if ( FALSE( PAIR_CAR( s2575 ) ) ) goto L3214; if ( FALSE( scrt1_equal_3f( PAIR_CAR( s2575 ), PAIR_CAR( X3 ) ) ) ) goto L3219; X7 = FALSEVALUE; SETGEN( PAIR_CAR( s2575 ), X7 ); goto L3219; L3214: if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( X3 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( X3 ) ), STRINGTAG ) ) ) ) goto L3218; X7 = scrt1_member( PAIR_CAR( X3 ), c2640 ); if ( TRUE( X7 ) ) goto L3219; if ( FALSE( p2578 ) ) goto L3224; scrt6_display( c2644, CONS( p2578, EMPTYLIST ) ); scrt6_display( PAIR_CAR( X3 ), CONS( p2578, EMPTYLIST ) ); scrt6_display( c2645, CONS( p2578, EMPTYLIST ) ); scrt6_newline( CONS( p2578, EMPTYLIST ) ); L3224: X9 = PAIR_CAR( l2577 ); if ( BITAND( BITOR( _S2CINT( X9 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3228; X8 = _TSCP( IDIFFERENCE( _S2CINT( X9 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3229; L3228: X8 = scrt2__2d_2dtwo( X9, _TSCP( 4 ) ); L3229: SETGEN( PAIR_CAR( l2577 ), X8 ); goto L3219; L3218: if ( FALSE( p2578 ) ) goto L3231; X7 = scrt4_c_2dtscp_2dref( X1, scdebug_expx_v ); scrt6_write( X7, CONS( X6, EMPTYLIST ) ); X7 = scrt6_get_2doutput_2dstring( X6 ); if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), STRINGTAG ) ) ) goto L3236; scdebug_error( c2666, c2667, CONS( X7, EMPTYLIST ) ); L3236: X8 = C_FIXED( STRING_LENGTH( X7 ) ); if ( BITAND( BITOR( _S2CINT( X8 ), _S2CINT( _TSCP( 260 ) ) ), 3 ) ) goto L3240; if ( GT( _S2CINT( X8 ), _S2CINT( _TSCP( 260 ) ) ) ) goto L3244; goto L3245; L3240: if ( FALSE( scrt2__3e_2dtwo( X8, _TSCP( 260 ) ) ) ) goto L3245; L3244: X9 = CONS( c2669, EMPTYLIST ); X8 = scrt3_string_2dappend( CONS( scrt3_substring( X7, _TSCP( 0 ), _TSCP( 260 ) ), X9 ) ); scrt6_display( X8, CONS( p2578, EMPTYLIST ) ); goto L3248; L3245: scrt6_display( X7, CONS( p2578, EMPTYLIST ) ); L3248: scrt6_display( c2670, CONS( p2578, EMPTYLIST ) ); X8 = PAIR_CAR( X5 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3250; scrt1__24__car_2derror( X8 ); L3250: X7 = PAIR_CAR( X8 ); scrt6_display( X7, CONS( p2578, EMPTYLIST ) ); scrt6_newline( CONS( p2578, EMPTYLIST ) ); L3231: if ( FALSE( X2 ) ) goto L3252; X10 = PAIR_CAR( X5 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3255; scrt1__24__car_2derror( X10 ); L3255: X9 = PAIR_CAR( X10 ); X8 = sc_cons( X9, PAIR_CAR( X3 ) ); X7 = sc_cons( X8, PAIR_CAR( X4 ) ); SETGEN( PAIR_CAR( X4 ), X7 ); goto L3253; L3252: X7 = sc_cons( PAIR_CAR( X3 ), PAIR_CAR( X4 ) ); SETGEN( PAIR_CAR( X4 ), X7 ); L3253: X8 = PAIR_CAR( X5 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3258; scrt1__24__cdr_2derror( X8 ); L3258: X7 = PAIR_CDR( X8 ); SETGEN( PAIR_CAR( X5 ), X7 ); X8 = PAIR_CAR( l2577 ); if ( BITAND( BITOR( _S2CINT( X8 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3261; X7 = _TSCP( IDIFFERENCE( _S2CINT( X8 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3262; L3261: X7 = scrt2__2d_2dtwo( X8, _TSCP( 4 ) ); L3262: SETGEN( PAIR_CAR( l2577 ), X7 ); L3219: X7 = scrt4_c_2ds2cuint_2dref( X1, _TSCP( 0 ) ); X5 = PAIR_CAR( X5 ); X4 = PAIR_CAR( X4 ); X3 = PAIR_CAR( X3 ); X1 = X7; GOBACK( L3176 ); L3183: if ( FALSE( PAIR_CAR( X4 ) ) ) goto L3263; if ( FALSE( X2 ) ) goto L3265; X8 = scrt1_assq( c2693, PAIR_CAR( X4 ) ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3268; scrt1__24__cdr_2derror( X8 ); L3268: X7 = PAIR_CDR( X8 ); POPSTACKTRACE( scrt1_append_2dtwo( X7, PAIR_CAR( X4 ) ) ); L3265: POPSTACKTRACE( scrt1_reverse( PAIR_CAR( X4 ) ) ); L3263: POPSTACKTRACE( PAIR_CAR( X4 ) ); } DEFTSCP( scdebug_on_2dinterrupt_v ); DEFCSTRING( t3270, "SCDEBUG_ON-INTERRUPT" ); EXTERNTSCP( screp__2areading_2dstdin_2a_v ); EXTERNTSCP( screp_reset_v ); TSCP scdebug_on_2dinterrupt( s2704 ) TSCP s2704; { TSCP X2, X1; PUSHSTACKTRACE( t3270 ); if ( FALSE( screp__2areading_2dstdin_2a_v ) ) goto L3272; X1 = screp_reset_v; X1 = UNKNOWNCALL( X1, 0 ); VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ); L3272: X1 = scrt6_le_2dtasks_e4d983f4( FALSEVALUE ); scrt6_format( scrt5_debug_2doutput_2dport_v, CONS( c2708, EMPTYLIST ) ); scdebug_dobacktrace( c2710, c2445, _TSCP( 80 ), scrt5_debug_2doutput_2dport_v ); X2 = CONS( scdebug_dobacktrace( c2710, c2445, _TSCP( 80 ), FALSEVALUE ), EMPTYLIST ); X2 = CONS( c2444, X2 ); X2 = CONS( c2709, X2 ); X2 = CONS( c2443, X2 ); X2 = CONS( FALSEVALUE, X2 ); screp_read_2deval_2dprint( CONS( c2441, X2 ) ); POPSTACKTRACE( scrt6_le_2dtasks_e4d983f4( X1 ) ); } DEFTSCP( scdebug_error_v ); DEFCSTRING( t3275, "ERROR" ); EXTERNTSCP( scdebug__2aerror_2dhandler_2a_v ); EXTERNTSCPP( sc_abort, XAL0( ) ); EXTERNTSCP( sc_abort_v ); EXTERNTSCPP( sc_error_2ddisplay, XAL1( TSCP ) ); EXTERNTSCP( sc_error_2ddisplay_v ); EXTERNTSCPP( sc_osexit, XAL1( TSCP ) ); EXTERNTSCP( sc_osexit_v ); TSCP scdebug_error( s2712, f2713, a2714 ) TSCP s2712, f2713, a2714; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3275 ); if ( NOT( AND( EQ( TSCPTAG( scdebug__2aerror_2dhandler_2a_v ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( scdebug__2aerror_2dhandler_2a_v ), PROCEDURETAG ) ) ) ) goto L3277; X1 = scdebug__2aerror_2dhandler_2a_v; scdebug__2aerror_2dhandler_2a_v = TRUEVALUE; X3 = sc_cons( f2713, a2714 ); X2 = sc_cons( s2712, X3 ); POPSTACKTRACE( sc_apply_2dtwo( X1, X2 ) ); L3277: X1 = sc_scheme_2dmode( ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2464 ) ) ) goto L3280; if ( FALSE( scdebug__2aerror_2dhandler_2a_v ) ) goto L3282; scdebug__2aerror_2dhandler_2a_v = FALSEVALUE; scrt6_write( c2721, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scrt6_newline( CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); X1 = CONS( _TSCP( 8 ), EMPTYLIST ); POPSTACKTRACE( screp_jump_2dto_2dscheme2c( CONS( screp__2ascheme2c_2dresult_2a_v, X1 ) ) ); L3282: POPSTACKTRACE( sc_abort( ) ); L3280: if ( FALSE( scdebug__2aerror_2dhandler_2a_v ) ) goto L3285; scdebug__2aerror_2dhandler_2a_v = FALSEVALUE; sc_error_2ddisplay( c2724 ); X2 = sc_cons( f2713, a2714 ); X1 = sc_cons( s2712, X2 ); L3289: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3290; sc_error_2ddisplay( _TSCP( 2578 ) ); POPSTACKTRACE( sc_osexit( _TSCP( 4 ) ) ); L3290: sc_error_2ddisplay( _TSCP( 8210 ) ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3295; scrt1__24__car_2derror( X1 ); L3295: X2 = PAIR_CAR( X1 ); sc_error_2ddisplay( X2 ); X1 = PAIR_CDR( X1 ); GOBACK( L3289 ); L3285: sc_error_2ddisplay( c2721 ); sc_error_2ddisplay( _TSCP( 2578 ) ); POPSTACKTRACE( sc_osexit( _TSCP( 4 ) ) ); } DEFTSCP( scdebug__2dhandler_f046c4d9_v ); DEFCSTRING( t3299, "SCDEBUG_EMBEDDED-ERROR-HANDLER" ); EXTERNTSCP( scdebug__2aerror_2denv_2a_v ); EXTERNTSCPP( scdebug__2dhandler_f046c4d9, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug__2dhandler_f046c4d9_v ); TSCP scdebug__2dhandler_f046c4d9( i2749, f2750, a2751 ) TSCP i2749, f2750, a2751; { TSCP X2, X1; PUSHSTACKTRACE( t3299 ); X1 = scrt6_format( c2752, CONS( i2749, EMPTYLIST ) ); scrt6_display( X1, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); X2 = sc_cons( f2750, a2751 ); X1 = sc_apply_2dtwo( scrt6_format_v, X2 ); scrt6_display( X1, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scrt6_newline( CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); if ( NEQ( _S2CUINT( scdebug__2aerror_2denv_2a_v ), _S2CUINT( FALSEVALUE ) ) ) goto L3301; scdebug__2aerror_2denv_2a_v = scdebug_dobacktrace( c2757, c2424, _TSCP( 80 ), scrt5_stderr_2dport_v ); L3301: scdebug__2aerror_2dhandler_2a_v = scdebug__2dhandler_f046c4d9_v; X1 = CONS( _TSCP( 4 ), EMPTYLIST ); POPSTACKTRACE( screp_jump_2dto_2dscheme2c( CONS( screp__2ascheme2c_2dresult_2a_v, X1 ) ) ); } DEFTSCP( scdebug_reset_2derror_v ); DEFCSTRING( t3303, "RESET-ERROR" ); TSCP scdebug_reset_2derror( ) { PUSHSTACKTRACE( t3303 ); POPSTACKTRACE( SET( scdebug__2aerror_2denv_2a_v, FALSEVALUE ) ); } DEFTSCP( scdebug__2aerror_2denv_2a_v ); DEFCSTRING( t3305, "*ERROR-ENV*" ); DEFTSCP( scdebug__2dhandler_eddc0242_v ); DEFCSTRING( t3306, "SCDEBUG_STAND-ALONE-ERROR-HANDLER" ); TSCP scdebug__2dhandler_eddc0242( i2762, f2763, a2764 ) TSCP i2762, f2763, a2764; { TSCP X2, X1; PUSHSTACKTRACE( t3306 ); X1 = scrt6_format( c2752, CONS( i2762, EMPTYLIST ) ); scrt6_display( X1, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); X2 = sc_cons( f2763, a2764 ); X1 = sc_apply_2dtwo( scrt6_format_v, X2 ); scrt6_display( X1, CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scrt6_newline( CONS( scrt5_stderr_2dport_v, EMPTYLIST ) ); scdebug_dobacktrace( c2757, c2765, _TSCP( 80 ), scrt5_stderr_2dport_v ); POPSTACKTRACE( sc_osexit( _TSCP( 4 ) ) ); } DEFTSCP( scdebug__2aerror_2dhandler_2a_v ); DEFCSTRING( t3308, "*ERROR-HANDLER*" ); DEFTSCP( scdebug_2derror_2a_ca4047fd_v ); DEFCSTRING( t3311, "*DEBUG-ON-ERROR*" ); DEFTSCP( scdebug__2dhandler_7d8722d5_v ); DEFCSTRING( t3312, "SCDEBUG_BACKTRACE-ERROR-HANDLER" ); EXTERNTSCPP( scdebug__2dhandler_7d8722d5, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug__2dhandler_7d8722d5_v ); EXTERNTSCPP( scrt6_char_2dready_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_char_2dready_3f_v ); EXTERNTSCP( scrt5_stdin_2dport_v ); EXTERNTSCPP( scrt6_eof_2dobject_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_eof_2dobject_3f_v ); EXTERNTSCPP( scrt6_read_2dchar, XAL1( TSCP ) ); EXTERNTSCP( scrt6_read_2dchar_v ); TSCP scdebug__2dhandler_7d8722d5( i2773, f2774, a2775 ) TSCP i2773, f2774, a2775; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3312 ); X1 = scrt6_format( c2752, CONS( i2773, EMPTYLIST ) ); scrt6_display( X1, CONS( scrt5_debug_2doutput_2dport_v, EMPTYLIST ) ); X2 = sc_cons( f2774, a2775 ); X1 = sc_apply_2dtwo( scrt6_format_v, X2 ); scrt6_display( X1, CONS( scrt5_debug_2doutput_2dport_v, EMPTYLIST ) ); scrt6_newline( CONS( scrt5_debug_2doutput_2dport_v, EMPTYLIST ) ); scdebug__2aerror_2dhandler_2a_v = scdebug__2dhandler_7d8722d5_v; if ( FALSE( scdebug_2derror_2a_ca4047fd_v ) ) goto L3314; X1 = scrt6_le_2dtasks_e4d983f4( FALSEVALUE ); X2 = scdebug_dobacktrace( c2757, c2445, _TSCP( 80 ), scrt5_debug_2doutput_2dport_v ); scdebug_2derror_2a_ca4047fd_v = FALSEVALUE; L3317: if ( FALSE( scrt6_char_2dready_3f( CONS( scrt5_stdin_2dport_v, EMPTYLIST ) ) ) ) goto L3321; X3 = scrt6_read_2dchar( CONS( scrt5_stdin_2dport_v, EMPTYLIST ) ); if ( FALSE( scrt6_eof_2dobject_3f( X3 ) ) ) GOBACK( L3317 ); L3321: X3 = CONS( X2, EMPTYLIST ); X3 = CONS( c2444, X3 ); X3 = CONS( FALSEVALUE, X3 ); X3 = CONS( c2441, X3 ); X3 = CONS( c2709, X3 ); screp_read_2deval_2dprint( CONS( c2443, X3 ) ); scrt6_le_2dtasks_e4d983f4( X1 ); scdebug_2derror_2a_ca4047fd_v = TRUEVALUE; L3314: X1 = screp_reset_v; X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scdebug_timeout_v ); DEFCSTRING( t3323, "SCDEBUG_TIMEOUT" ); EXTERNTSCP( scdebug_timeout_2ddebug_v ); TSCP scdebug_l2789( c3327 ) TSCP c3327; { TSCP X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2789 [inside TIMEOUT]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3327, 0 ); X3 = DISPLAY( 0 ); X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( TRUEVALUE, PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } TSCP scdebug_l2787( r2788, c3325 ) TSCP r2788, c3325; { TSCP X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( "scdebug_l2787 [inside TIMEOUT]" ); DISPLAY( 0 ) = r2788; scdebug_proceed_v = MAKEPROCEDURE( 0, 0, scdebug_l2789, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); X1 = CONS( _TSCP( 12 ), EMPTYLIST ); SDVAL = screp_jump_2dto_2dscheme2c( CONS( screp__2ascheme2c_2dresult_2a_v, X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } TSCP scdebug_l2794( c3334 ) TSCP c3334; { TSCP X3, X2, X1; PUSHSTACKTRACE( "scdebug_l2794 [inside TIMEOUT]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3334, 0 ); X3 = DISPLAY( 0 ); X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( TRUEVALUE, PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } TSCP scdebug_l2792( c2793, c3332 ) TSCP c2793, c3332; { TSCP X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( "scdebug_l2792 [inside TIMEOUT]" ); DISPLAY( 0 ) = c2793; scdebug_proceed_v = MAKEPROCEDURE( 0, 0, scdebug_l2794, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); X1 = CONS( _TSCP( 16 ), EMPTYLIST ); SDVAL = screp_jump_2dto_2dscheme2c( CONS( screp__2ascheme2c_2dresult_2a_v, X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } TSCP scdebug_timeout( ) { TSCP X3, X2, X1; PUSHSTACKTRACE( t3323 ); scdebug_timeout_2ddebug_v = FALSEVALUE; X2 = MAKEPROCEDURE( 1, 0, scdebug_l2787, EMPTYLIST ); X1 = sc_ntinuation_1af38b9f_v; X1 = UNKNOWNCALL( X1, 1 ); VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); if ( FALSE( scdebug_timeout_2ddebug_v ) ) goto L3329; X1 = scdebug_dobacktrace( c2795, c2424, _TSCP( 80 ), scrt5_stderr_2dport_v ); scdebug__2aargs_2a_v = EMPTYLIST; scdebug__2abpt_2denv_2a_v = X1; X3 = MAKEPROCEDURE( 1, 0, scdebug_l2792, EMPTYLIST ); X2 = sc_ntinuation_1af38b9f_v; X2 = UNKNOWNCALL( X2, 1 ); VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); POPSTACKTRACE( SET( scdebug__2abpt_2denv_2a_v, FALSEVALUE ) ); L3329: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scdebug_proceed_3f_v ); DEFCSTRING( t3336, "PROCEED?" ); TSCP scdebug_proceed_3f( ) { TSCP X1; PUSHSTACKTRACE( t3336 ); scdebug_timeout_2ddebug_v = TRUEVALUE; X1 = scdebug_proceed_v; X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scdebug_timeout_2ddebug_v ); DEFCSTRING( t3338, "SCDEBUG_TIMEOUT-DEBUG" ); void scrt3__init(); void scrt4__init(); void screp__init(); void sceval__init(); void scrt5__init(); void scrt6__init(); void scrt2__init(); void scrt1__init(); void scexpand__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt3__init(); scrt4__init(); screp__init(); sceval__init(); scrt5__init(); scrt6__init(); scrt2__init(); scrt1__init(); scexpand__init(); MAXDISPLAY( 4 ); } void scdebug__init() { TSCP X2, X1; static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scdebug SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2911, ADR( scdebug_trace_2dlevel_v ), _TSCP( 0 ) ); INITIALIZEVAR( t2912, ADR( scdebug_traced_2dprocs_v ), EMPTYLIST ); INITIALIZEVAR( t2913, ADR( scdebug_bpt_2dprocs_v ), EMPTYLIST ); INITIALIZEVAR( t2914, ADR( scdebug__2aargs_2a_v ), EMPTYLIST ); INITIALIZEVAR( t2915, ADR( scdebug__2aresult_2a_v ), EMPTYLIST ); INITIALIZEVAR( t2916, ADR( scdebug__2abpt_2denv_2a_v ), FALSEVALUE ); X1 = MAKEPROCEDURE( 2, 0, scdebug_l2136, EMPTYLIST ); scexpand_install_2dexpander( c2135, X1 ); INITIALIZEVAR( t2924, ADR( scdebug_dotrace_v ), MAKEPROCEDURE( 1, 0, scdebug_dotrace, EMPTYLIST ) ); INITIALIZEVAR( t2936, ADR( scdebug_tracer_v ), MAKEPROCEDURE( 2, 0, scdebug_tracer, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scdebug_l2219, EMPTYLIST ); scexpand_install_2dexpander( c2218, X1 ); INITIALIZEVAR( t2992, ADR( scdebug_dountrace_v ), MAKEPROCEDURE( 1, 0, scdebug_dountrace, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scdebug_l2306, EMPTYLIST ); scexpand_install_2dexpander( c2305, X1 ); INITIALIZEVAR( t3023, ADR( scdebug_dobpt_v ), MAKEPROCEDURE( 1, 1, scdebug_dobpt, EMPTYLIST ) ); INITIALIZEVAR( t3036, ADR( scdebug_reset_2dbpt_v ), MAKEPROCEDURE( 0, 0, scdebug_reset_2dbpt, EMPTYLIST ) ); INITIALIZEVAR( t3038, ADR( scdebug_default_2dproceed_v ), MAKEPROCEDURE( 0, 0, scdebug_default_2dproceed, EMPTYLIST ) ); INITIALIZEVAR( t3040, ADR( scdebug_proceed_v ), scdebug_default_2dproceed_v ); INITIALIZEVAR( t3041, ADR( scdebug_bpter_2dprocname_v ), c2365 ); INITIALIZEVAR( t3042, ADR( scdebug_bpter_v ), MAKEPROCEDURE( 3, 0, scdebug_bpter, EMPTYLIST ) ); INITIALIZEVAR( t3112, ADR( scdebug_backtrace_v ), FALSEVALUE ); INITIALIZEVAR( t3113, ADR( scdebug_dbacktrace_a8071371_v ), MAKEPROCEDURE( 0, 1, scdebug_dbacktrace_a8071371, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scdebug_l2472, EMPTYLIST ); scexpand_install_2dexpander( c2471, X1 ); INITIALIZEVAR( t3149, ADR( scdebug_dounbpt_v ), MAKEPROCEDURE( 1, 0, scdebug_dounbpt, EMPTYLIST ) ); X1 = C_FIXED( SIZEOF( TSCP ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3166; X2 = _TSCP( ITIMES( FIXED_C( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3167; L3166: X2 = scrt2__2a_2dtwo( X1, _TSCP( 4 ) ); L3167: INITIALIZEVAR( t3164, ADR( scdebug_procnamex_v ), X2 ); X1 = C_FIXED( SIZEOF( TSCP ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L3170; X2 = _TSCP( ITIMES( FIXED_C( X1 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L3171; L3170: X2 = scrt2__2a_2dtwo( X1, _TSCP( 8 ) ); L3171: INITIALIZEVAR( t3168, ADR( scdebug_expx_v ), X2 ); INITIALIZEVAR( t3172, ADR( scdebug_dobacktrace_v ), MAKEPROCEDURE( 4, 0, scdebug_dobacktrace, EMPTYLIST ) ); INITIALIZEVAR( t3270, ADR( scdebug_on_2dinterrupt_v ), MAKEPROCEDURE( 1, 0, scdebug_on_2dinterrupt, EMPTYLIST ) ); INITIALIZEVAR( t3275, ADR( scdebug_error_v ), MAKEPROCEDURE( 2, 1, scdebug_error, EMPTYLIST ) ); INITIALIZEVAR( t3299, ADR( scdebug__2dhandler_f046c4d9_v ), MAKEPROCEDURE( 2, 1, scdebug__2dhandler_f046c4d9, EMPTYLIST ) ); INITIALIZEVAR( t3303, ADR( scdebug_reset_2derror_v ), MAKEPROCEDURE( 0, 0, scdebug_reset_2derror, EMPTYLIST ) ); INITIALIZEVAR( t3305, ADR( scdebug__2aerror_2denv_2a_v ), FALSEVALUE ); INITIALIZEVAR( t3306, ADR( scdebug__2dhandler_eddc0242_v ), MAKEPROCEDURE( 2, 1, scdebug__2dhandler_eddc0242, EMPTYLIST ) ); X2 = sc_scheme_2dmode( ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2464 ) ) ) goto L3309; X1 = scdebug__2dhandler_f046c4d9_v; goto L3310; L3309: X1 = scdebug__2dhandler_eddc0242_v; L3310: INITIALIZEVAR( t3308, ADR( scdebug__2aerror_2dhandler_2a_v ), X1 ); INITIALIZEVAR( t3311, ADR( scdebug_2derror_2a_ca4047fd_v ), FALSEVALUE ); INITIALIZEVAR( t3312, ADR( scdebug__2dhandler_7d8722d5_v ), MAKEPROCEDURE( 2, 1, scdebug__2dhandler_7d8722d5, EMPTYLIST ) ); INITIALIZEVAR( t3323, ADR( scdebug_timeout_v ), MAKEPROCEDURE( 0, 0, scdebug_timeout, EMPTYLIST ) ); INITIALIZEVAR( t3336, ADR( scdebug_proceed_3f_v ), MAKEPROCEDURE( 0, 0, scdebug_proceed_3f, EMPTYLIST ) ); INITIALIZEVAR( t3338, ADR( scdebug_timeout_2ddebug_v ), TRUEVALUE ); return; } scheme2c-2012.10.14/scrt/scdebug.sc000066400000000000000000000364371203736146400165340ustar00rootroot00000000000000;;; This module contains code for tracing and breakpointing functions using ;;; the SCHEME->C interpreter. It also contains the code for an error ;;; handler which back traces the control stack. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scdebug (top-level TRACED-PROCS BPT-PROCS *ARGS* *BPT-ENV* *RESULT* RESET-BPT PROCEED DOTRACE TRACER DOUNTRACE DOBPT DOUNBPT BACKTRACE ERROR RESET-ERROR *ERROR-HANDLER* *ERROR-ENV* PROCEED? *DEBUG-ON-ERROR*)) (include "repdef.sc") ;;; Top level variables used by debugger. (define TRACE-LEVEL 0) ;;; Nesting level for trace and breakpoints. (define TRACED-PROCS '()) ;;; A-list of traced procedures with elements: ;;; (symbol original-proc debugged-proc) (define BPT-PROCS '()) ;;; A-list of bpted proceduress with elements: ;;; (symbol original-proc debugged-proc) ;;; Arguments at the time of a breakpoint are in *ARGS*, and the result is in ;;; *RESULT* after the procedure is called. A new result may be returned by ;;; continuing from the breakpoint with (PROCEED new-value). (define *ARGS* '()) (define *RESULT* '()) (define *BPT-ENV* #f) ;;; List of environments associated with the ;;; breakpoint in an embedded interpreter. ;;; Procedure tracing. (install-expander 'TRACE (lambda (x e) (if (cdr x) `(map (lambda (f) (dotrace f)) (quote ,(cdr x))) '(map (lambda (x) (car x)) traced-procs)))) (define (DOTRACE name) (if (assoc name traced-procs) (dountrace name)) (if (assoc name bpt-procs) (dounbpt name)) (let ((proc (top-level-value name)) (trace-proc #f)) (if (not (procedure? proc)) (error 'TRACE "Argument is not a PROCEDURE name")) (if (assoc name traced-procs) (error 'TRACE "~s is already traced" name)) (set! trace-proc (tracer name proc)) (set! traced-procs (cons (list name proc trace-proc) traced-procs)) (set-top-level-value! name trace-proc)) name) (define (TRACER name proc) (lambda x (format trace-output-port "~a~s~%" (make-string (* 2 (min trace-level 15)) #\space) (cons name x)) (set! trace-level (+ trace-level 1)) (let ((result (apply proc x))) (set! trace-level (- trace-level 1)) (format trace-output-port "~a~a~s~%" (make-string (* 2 (min trace-level 15)) #\space) "==> " result) result))) (install-expander 'UNTRACE (lambda (x e) (if (null? (cdr x)) (set! x (map (lambda (x) (car x)) traced-procs)) (set! x (cdr x))) `(map (lambda (f) (dountrace f)) (quote ,x)))) (define (DOUNTRACE name) (let ((name-proc-trace (assoc name traced-procs))) (if (not name-proc-trace) (error 'UNTRACE "~s is not traced" name)) (if (eq? (top-level-value name) (caddr name-proc-trace)) (set-top-level-value! name (cadr name-proc-trace))) (set! traced-procs (remove name-proc-trace traced-procs))) name) ;;; Procedure breakpoints. (install-expander 'BPT (lambda (x e) (case (length x) ((1) '(map (lambda (x) (car x)) bpt-procs)) ((2) `(apply dobpt (quote ,(cdr x)))) ((3) (let ((func (e (caddr x) e))) `(apply dobpt (list (quote ,(cadr x)) (quote ,func))))) (else (error 'BPT "Illegal arguments"))))) (define (DOBPT name . condition) (if (assoc name bpt-procs) (dounbpt name)) (let ((proc (top-level-value name)) (bpt-proc #f)) (if (not (procedure? proc)) (error 'BPT "Argument is not a PROCEDURE name")) (set! bpt-proc (bpter name proc (if condition (eval (car condition))))) (set! bpt-procs (cons (list name proc bpt-proc) bpt-procs)) (set-top-level-value! name bpt-proc)) name) (define (RESET-BPT) (set! trace-level 0) (set! proceed default-proceed) (set! *bpt-env* #f)) (define (DEFAULT-PROCEED) (error 'PROCEED "Not at a breakpoint")) (define PROCEED default-proceed) (define BPTER-PROCNAME "INTERACTIVE [inside BPTER]") ;;; Name of interactive breakpoint procedure. (define (BPTER name proc condition) (define (EMBEDDED . x) (if (and (not *bpt-env*) (or (not condition) (apply condition x))) (let* ((trace-port (open-output-string)) (envs (dobacktrace "EMBEDDED [inside BPTER]" "SCHEME2C" 20 trace-port))) (set! *args* x) (set! *bpt-env* envs) (set! backtrace (let ((btrace (get-output-string trace-port))) (lambda () (display btrace stderr-port) 'backtrace:))) (write trace-level stderr-port) (display " -calls - " stderr-port) (write (cons name x) stderr-port) (newline stderr-port) (call-with-current-continuation (lambda (continue) (set! proceed (lambda () (continue #t))) (jump-to-scheme2c *scheme2c-result* 4))) (set! *bpt-env* #f) (set! trace-level (+ 1 trace-level)) (set! *result* (apply proc *args*)) (set! trace-level (- 1 trace-level)) (set! *args* x) (set! *bpt-env* envs) (write trace-level stderr-port) (display " -returns- " stderr-port) (write *result* stderr-port) (newline stderr-port) (call-with-current-continuation (lambda (continue) (set! proceed (lambda x (if (not (eq? x '())) (set! *result* (car x))) (continue #t))) (jump-to-scheme2c *scheme2c-result* 5))) (set! *bpt-env* #f) *result*) (apply proc x))) (define (XEQ . args) (let ((ftok (enable-system-file-tasks #f))) (let ((result (apply read-eval-print args))) (enable-system-file-tasks ftok) result))) (define (INTERACTIVE . x) (if (or (not condition) (apply condition x)) (let ((prompt (format "~s- " trace-level))) (set! backtrace interactive-backtrace) (set! *args* x) (xeq 'header (format "~%~s -calls - ~s" trace-level (cons name x)) 'prompt prompt 'env (dobacktrace bpter-procname "READ-EVAL-PRINT" 20 #f)) (set! trace-level (+ trace-level 1)) (set! *result* (apply proc *args*)) (set! trace-level (- trace-level 1)) (xeq 'header (format "~s -returns- ~s" trace-level *result*) 'prompt prompt 'result *result* 'env (dobacktrace bpter-procname "READ-EVAL-PRINT" 20 #f))) (apply proc x))) (if (eq? (scheme-mode) 'embedded) embedded interactive)) ;;; A backtrace at a breakpoint is done by the following procedure. When ;;; the system is interactive, it takes an optional count. (define BACKTRACE #f) (define (INTERACTIVE-BACKTRACE . count) (dobacktrace bpter-procname "READ-EVAL-PRINT" (if count (car count) 20) debug-output-port) #f) (install-expander 'UNBPT (lambda (x e) (if (null? (cdr x)) (set! x (map (lambda (x) (car x)) bpt-procs)) (set! x (cdr x))) `(map (lambda (f) (dounbpt f)) (quote ,x)))) (define (DOUNBPT name) (let ((name-proc-bpt (assoc name bpt-procs))) (if (not name-proc-bpt) (error 'UNBPT "~s is not breakpointed" name)) (if (eq? (top-level-value name) (caddr name-proc-bpt)) (set-top-level-value! name (cadr name-proc-bpt))) (set! bpt-procs (remove name-proc-bpt bpt-procs)) (if (null? bpt-procs) (reset-bpt))) name) ;;; Indices for taking apart stack trace records. (define PROCNAMEX (* ((lap () (C_FIXED (SIZEOF TSCP)))) 1)) (define EXPX (* ((lap () (C_FIXED (SIZEOF TSCP)))) 2)) ;;; Backtracing is done by the following procedure. It accepts a starting ;;; procedure (or #F), a termination procedure (or #F), a line count, and an ;;; output port. It returns an a-list of environments for use with eval, where ;;; each item is of the form (ENV-n . environment) when the system is ;;; interactive, or a list of environments when the system is not interactive, ;;; where list element 'n' is environment 'n'. (define (DOBACKTRACE start stop lines port) (do ((stp (stacktrace) (c-s2cuint-ref stp 0)) (interactive (eq? (scheme-mode) 'interactive)) (procname "") (envlist '()) (envid '(env-0 env-1 env-2 env-3 env-4 env-5 env-6 env-7 env-8 env-9 env-10 env-11 env-12 env-13 env-14 env-15 env-16 env-17 env-18 env-19 env-20 env-21 env-22 env-23 env-24 env-25)) (string-out (let ((port (open-output-string))) (set-write-circle! #t port) (set-write-level! 10 port) (set-write-length! 20 port) port))) ((or (= stp 0) (= lines 0) (null? envid) (and (not start) (equal? procname stop))) (if envlist (if interactive (append (cdr (assq 'env-0 envlist)) envlist) (reverse envlist)) envlist)) (set! procname (if (or (valid-scheme-pointer? (c-tscp-ref stp procnamex)) (eq? (c-tscp-ref stp procnamex) '())) (c-tscp-ref stp procnamex) (c-string->string (c-s2cuint-ref stp procnamex)))) (cond (start (if (equal? start procname) (set! start #f))) ((not (string? procname)) (when port (write (c-tscp-ref stp expx) string-out) (let ((expr (get-output-string string-out))) (if (> (string-length expr) 65) (display (string-append (substring expr 0 65) " ...") port) (display expr port))) (display " in " port) (display (car envid) port) (newline port)) (if interactive (set! envlist (cons (cons (car envid) procname) envlist)) (set! envlist (cons procname envlist))) (set! envid (cdr envid)) (set! lines (- lines 1))) ((member procname '("SCEVAL_INTERPRETED-PROC" "LOOP [inside EXEC]"))) (else (when port (display "(" port) (display procname port) (display " ...)" port) (newline port)) (set! lines (- lines 1)))))) ;;; Keyboard interrupt signals are handled by the following function. If ;;; the interpreter is currently reading stdin, then this results in a reset. ;;; Otherwise, a stack trace is printed and the debugger is entered. A normal ;;; exit from the debugger results in the Scheme computation continuing. (define (ON-INTERRUPT sig) (if *reading-stdin* (reset)) (let ((ftok (enable-system-file-tasks #f)) (start "SCRT4_CALLSIGNALHANDLER")) (format debug-output-port "~%***** INTERRUPT *****~%") (dobacktrace start "READ-EVAL-PRINT" 20 debug-output-port) (read-eval-print 'header #f 'prompt ">> " 'env (dobacktrace start "READ-EVAL-PRINT" 20 #f)) (enable-system-file-tasks ftok))) ;;; Errors are handled by the following procedure. (define (ERROR symbol format-string . args) (cond ((procedure? *error-handler*) (let ((proc *error-handler*)) (set! *error-handler* #t) (apply proc (cons symbol (cons format-string args))))) ((eq? (scheme-mode) 'embedded) (if *error-handler* (begin (set! *error-handler* #f) (write "***** ERROR error handler failed!" stderr-port) (newline stderr-port) (jump-to-scheme2c *scheme2c-result* 2)) (abort))) (*error-handler* (set! *error-handler* #f) (error-display '*****\ \i\n\s\i\d\e\ ERROR) (do ((arg (cons symbol (cons format-string args)) (cdr arg))) ((null? arg) (error-display #\newline) (osexit 1)) (error-display #\space) (error-display (car arg)))) (else (error-display "***** ERROR error handler failed!") (error-display #\newline) (osexit 1)))) ;;; The EMBEDDED-ERROR-HANDLER writes the message on stderr-port. If no error ;;; message is latched, it saves the environments in *ERROR-ENV* and writes ;;; the stack trace on stderr-port as well. (define (EMBEDDED-ERROR-HANDLER id format-string . args) (display (format "***** ~a " id) stderr-port) (display (apply format (cons format-string args)) stderr-port) (newline stderr-port) (if (eq? *error-env* #f) (set! *error-env* (dobacktrace "ERROR" "SCHEME2C" 20 stderr-port))) (set! *error-handler* embedded-error-handler) (jump-to-scheme2c *scheme2c-result* 1)) (define (RESET-ERROR) (set! *error-env* #f)) (define *ERROR-ENV* #f) ;;; The STAND-ALONE-ERROR-HANDLER outputs the message, dumps a stack trace, ;;; and then terminates the program. (define (STAND-ALONE-ERROR-HANDLER id format-string . args) (display (format "***** ~a " id) stderr-port) (display (apply format (cons format-string args)) stderr-port) (newline stderr-port) (dobacktrace "ERROR" "main" 20 stderr-port) (osexit 1)) ;;; Initialize *ERROR-HANDLER* to the right one. (define *ERROR-HANDLER* (case (scheme-mode) ((embedded) embedded-error-handler) (else stand-alone-error-handler))) ;;; The default error handler is replaced by the following function when ;;; backtracing on error is desired. It prints the backtrace, and then ;;; enters a read-eval-print loop when *DEBUG-ON-ERROR* is set. (define *DEBUG-ON-ERROR* #f) (define (BACKTRACE-ERROR-HANDLER id format-string . args) (display (format "***** ~a " id) debug-output-port) (display (apply format (cons format-string args)) debug-output-port) (newline debug-output-port) (set! *error-handler* backtrace-error-handler) (when *debug-on-error* (let ((env (dobacktrace "ERROR" "READ-EVAL-PRINT" 20 debug-output-port)) (ftok (enable-system-file-tasks #f))) (set! *debug-on-error* #f) (let loop () (when (char-ready? stdin-port) (if (not (eof-object? (read-char stdin-port))) (loop)))) (read-eval-print 'prompt ">> " 'header #f 'env env) (enable-system-file-tasks ftok) (set! *debug-on-error* #t))) (reset)) ;;; When the current computation exceeds the timeslice, the following procedure ;;; is called to package up the computation and return to the user. (define (TIMEOUT) (set! timeout-debug #f) (call-with-current-continuation (lambda (return) (set! proceed (lambda () (return #t))) (jump-to-scheme2c *scheme2c-result* 3))) (if timeout-debug (let ((envs (dobacktrace "SCDEBUG_TIMEOUT" "SCHEME2C" 20 stderr-port))) (set! *args* '()) (set! *bpt-env* envs) (call-with-current-continuation (lambda (continue) (set! proceed (lambda () (continue #t))) (jump-to-scheme2c *scheme2c-result* 4))) (set! *bpt-env* #f)))) ;;; When computation is resumed, the current state of the computation may be ;;; inspected by calling the following procedure. (define (PROCEED?) (set! timeout-debug #t) (proceed)) (define TIMEOUT-DEBUG #t) scheme2c-2012.10.14/scrt/sceval.c000066400000000000000000001602571203736146400162100ustar00rootroot00000000000000 /* SCHEME->C */ #include void sceval__init(); DEFSTATICTSCP( c3316 ); DEFSTATICTSCP( t3506 ); DEFSTATICTSCP( t3507 ); DEFCSTRING( t3508, "Argument value is not a function: ~s" ); DEFSTATICTSCP( c2983 ); DEFSTATICTSCP( c2982 ); DEFCSTRING( t3509, "Too many arguments to function" ); DEFSTATICTSCP( c2970 ); DEFCSTRING( t3510, "Too few arguments to function" ); DEFSTATICTSCP( c2913 ); DEFSTATICTSCP( c2912 ); DEFCSTRING( t3511, "Environment is not an A-LIST: ~s" ); DEFSTATICTSCP( c2696 ); DEFCSTRING( t3512, "noexpand" ); DEFSTATICTSCP( c2670 ); DEFCSTRING( t3513, "Argument contains an item that is not self-evaluating: ~s" ); DEFSTATICTSCP( c2654 ); DEFSTATICTSCP( c2653 ); DEFCSTRING( t3514, "Top-level symbol is undefined" ); DEFSTATICTSCP( c2649 ); DEFCSTRING( t3515, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2592 ); DEFSTATICTSCP( c2591 ); DEFSTATICTSCP( c2509 ); DEFSTATICTSCP( c2356 ); DEFSTATICTSCP( c2348 ); DEFSTATICTSCP( c2335 ); DEFSTATICTSCP( c2331 ); DEFSTATICTSCP( c2327 ); DEFSTATICTSCP( c2323 ); DEFSTATICTSCP( c2314 ); DEFSTATICTSCP( c2313 ); DEFSTATICTSCP( c2312 ); DEFSTATICTSCP( c2217 ); DEFSTATICTSCP( c2189 ); DEFSTATICTSCP( c2188 ); DEFSTATICTSCP( c2187 ); DEFSTATICTSCP( c2186 ); DEFSTATICTSCP( c2185 ); DEFSTATICTSCP( c2184 ); DEFSTATICTSCP( c2183 ); DEFSTATICTSCP( c2182 ); DEFSTATICTSCP( c2181 ); DEFSTATICTSCP( c2180 ); DEFSTATICTSCP( c2179 ); DEFSTATICTSCP( c2178 ); DEFSTATICTSCP( c2177 ); DEFSTATICTSCP( c2176 ); DEFSTATICTSCP( c2175 ); DEFSTATICTSCP( c2174 ); DEFSTATICTSCP( c2173 ); DEFSTATICTSCP( c2172 ); DEFSTATICTSCP( c2171 ); DEFSTATICTSCP( c2170 ); DEFSTATICTSCP( c2169 ); DEFSTATICTSCP( c2168 ); DEFSTATICTSCP( c2167 ); DEFSTATICTSCP( c2166 ); DEFSTATICTSCP( c2165 ); DEFSTATICTSCP( c2164 ); DEFSTATICTSCP( c2163 ); DEFSTATICTSCP( c2161 ); DEFSTATICTSCP( c2159 ); DEFSTATICTSCP( c2157 ); DEFCSTRING( t3516, "Illegal OPTIMIZATION OPTION(S): ~s" ); DEFSTATICTSCP( c2155 ); DEFSTATICTSCP( c2154 ); DEFSTATICTSCP( c2153 ); DEFSTATICTSCP( c2151 ); DEFSTATICTSCP( c2146 ); DEFSTATICTSCP( c2141 ); static void init_constants() { TSCP X1; c3316 = EMPTYLIST; t3506 = STRINGTOSYMBOL( CSTRING_TSCP( "X" ) ); c3316 = CONS( t3506, c3316 ); X1 = EMPTYLIST; X1 = CONS( t3506, X1 ); c3316 = CONS( X1, c3316 ); t3507 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); c3316 = CONS( t3507, c3316 ); CONSTANTEXP( ADR( c3316 ) ); c2983 = CSTRING_TSCP( t3508 ); CONSTANTEXP( ADR( c2983 ) ); c2982 = STRINGTOSYMBOL( CSTRING_TSCP( "EXEC" ) ); CONSTANTEXP( ADR( c2982 ) ); c2970 = CSTRING_TSCP( t3509 ); CONSTANTEXP( ADR( c2970 ) ); c2913 = CSTRING_TSCP( t3510 ); CONSTANTEXP( ADR( c2913 ) ); c2912 = STRINGTOSYMBOL( CSTRING_TSCP( "NEW-ENV" ) ); CONSTANTEXP( ADR( c2912 ) ); c2696 = CSTRING_TSCP( t3511 ); CONSTANTEXP( ADR( c2696 ) ); c2670 = CSTRING_TSCP( t3512 ); CONSTANTEXP( ADR( c2670 ) ); c2654 = CSTRING_TSCP( t3513 ); CONSTANTEXP( ADR( c2654 ) ); c2653 = STRINGTOSYMBOL( CSTRING_TSCP( "EVAL" ) ); CONSTANTEXP( ADR( c2653 ) ); c2649 = CSTRING_TSCP( t3514 ); CONSTANTEXP( ADR( c2649 ) ); c2592 = CSTRING_TSCP( t3515 ); CONSTANTEXP( ADR( c2592 ) ); c2591 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2591 ) ); c2509 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-TOP-LEVEL-VALUE!" ) ); CONSTANTEXP( ADR( c2509 ) ); c2356 = STRINGTOSYMBOL( CSTRING_TSCP( "CALL" ) ); CONSTANTEXP( ADR( c2356 ) ); c2348 = STRINGTOSYMBOL( CSTRING_TSCP( "REWRITE" ) ); CONSTANTEXP( ADR( c2348 ) ); c2335 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2335 ) ); c2331 = STRINGTOSYMBOL( CSTRING_TSCP( "BEGIN" ) ); CONSTANTEXP( ADR( c2331 ) ); c2327 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2327 ) ); c2323 = STRINGTOSYMBOL( CSTRING_TSCP( "IF" ) ); CONSTANTEXP( ADR( c2323 ) ); c2314 = STRINGTOSYMBOL( CSTRING_TSCP( "%TO-EVAL" ) ); CONSTANTEXP( ADR( c2314 ) ); c2313 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2313 ) ); c2312 = STRINGTOSYMBOL( CSTRING_TSCP( "%RECORD-LOOKUP-METHOD" ) ); CONSTANTEXP( ADR( c2312 ) ); c2217 = DOUBLE_TSCP( 0. ); CONSTANTEXP( ADR( c2217 ) ); c2189 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_/-TWO" ) ); CONSTANTEXP( ADR( c2189 ) ); c2188 = STRINGTOSYMBOL( CSTRING_TSCP( "SCEVAL_/1" ) ); CONSTANTEXP( ADR( c2188 ) ); c2187 = STRINGTOSYMBOL( CSTRING_TSCP( "/" ) ); CONSTANTEXP( ADR( c2187 ) ); c2186 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_--TWO" ) ); CONSTANTEXP( ADR( c2186 ) ); c2185 = STRINGTOSYMBOL( CSTRING_TSCP( "SCEVAL_NEGATE" ) ); CONSTANTEXP( ADR( c2185 ) ); c2184 = STRINGTOSYMBOL( CSTRING_TSCP( "-" ) ); CONSTANTEXP( ADR( c2184 ) ); c2183 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_*-TWO" ) ); CONSTANTEXP( ADR( c2183 ) ); c2182 = STRINGTOSYMBOL( CSTRING_TSCP( "*" ) ); CONSTANTEXP( ADR( c2182 ) ); c2181 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_+-TWO" ) ); CONSTANTEXP( ADR( c2181 ) ); c2180 = STRINGTOSYMBOL( CSTRING_TSCP( "+" ) ); CONSTANTEXP( ADR( c2180 ) ); c2179 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_MIN-TWO" ) ); CONSTANTEXP( ADR( c2179 ) ); c2178 = STRINGTOSYMBOL( CSTRING_TSCP( "MIN" ) ); CONSTANTEXP( ADR( c2178 ) ); c2177 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_MAX-TWO" ) ); CONSTANTEXP( ADR( c2177 ) ); c2176 = STRINGTOSYMBOL( CSTRING_TSCP( "MAX" ) ); CONSTANTEXP( ADR( c2176 ) ); c2175 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_>=-TWO" ) ); CONSTANTEXP( ADR( c2175 ) ); c2174 = STRINGTOSYMBOL( CSTRING_TSCP( ">=" ) ); CONSTANTEXP( ADR( c2174 ) ); c2173 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_<=-TWO" ) ); CONSTANTEXP( ADR( c2173 ) ); c2172 = STRINGTOSYMBOL( CSTRING_TSCP( "<=" ) ); CONSTANTEXP( ADR( c2172 ) ); c2171 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_>-TWO" ) ); CONSTANTEXP( ADR( c2171 ) ); c2170 = STRINGTOSYMBOL( CSTRING_TSCP( ">" ) ); CONSTANTEXP( ADR( c2170 ) ); c2169 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_<-TWO" ) ); CONSTANTEXP( ADR( c2169 ) ); c2168 = STRINGTOSYMBOL( CSTRING_TSCP( "<" ) ); CONSTANTEXP( ADR( c2168 ) ); c2167 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT2_=-TWO" ) ); CONSTANTEXP( ADR( c2167 ) ); c2166 = STRINGTOSYMBOL( CSTRING_TSCP( "=" ) ); CONSTANTEXP( ADR( c2166 ) ); c2165 = STRINGTOSYMBOL( CSTRING_TSCP( "SCRT1_APPEND-TWO" ) ); CONSTANTEXP( ADR( c2165 ) ); c2164 = STRINGTOSYMBOL( CSTRING_TSCP( "APPEND" ) ); CONSTANTEXP( ADR( c2164 ) ); c2163 = STRINGTOSYMBOL( CSTRING_TSCP( "SCEVAL_LIST3" ) ); CONSTANTEXP( ADR( c2163 ) ); c2161 = STRINGTOSYMBOL( CSTRING_TSCP( "SCEVAL_LIST2" ) ); CONSTANTEXP( ADR( c2161 ) ); c2159 = STRINGTOSYMBOL( CSTRING_TSCP( "SCEVAL_LIST1" ) ); CONSTANTEXP( ADR( c2159 ) ); c2157 = STRINGTOSYMBOL( CSTRING_TSCP( "LIST" ) ); CONSTANTEXP( ADR( c2157 ) ); c2155 = CSTRING_TSCP( t3516 ); CONSTANTEXP( ADR( c2155 ) ); c2154 = STRINGTOSYMBOL( CSTRING_TSCP( "OPTIMIZE-EVAL" ) ); CONSTANTEXP( ADR( c2154 ) ); c2153 = EMPTYLIST; c2153 = CONS( c2356, c2153 ); c2153 = CONS( c2348, c2153 ); CONSTANTEXP( ADR( c2153 ) ); c2151 = EMPTYLIST; c2151 = CONS( c2348, c2151 ); c2151 = CONS( c2356, c2151 ); CONSTANTEXP( ADR( c2151 ) ); c2146 = EMPTYLIST; c2146 = CONS( c2348, c2146 ); CONSTANTEXP( ADR( c2146 ) ); c2141 = EMPTYLIST; c2141 = CONS( c2356, c2141 ); CONSTANTEXP( ADR( c2141 ) ); } DEFTSCP( sceval_optimize_2doptions_v ); DEFCSTRING( t3517, "SCEVAL_OPTIMIZE-OPTIONS" ); DEFTSCP( sceval_optimize_2deval_v ); DEFCSTRING( t3518, "OPTIMIZE-EVAL" ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP sceval_optimize_2deval( o2133 ) TSCP o2133; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3518 ); X1 = scrt1_equal_3f( o2133, EMPTYLIST ); if ( TRUE( X1 ) ) goto L3524; X2 = scrt1_equal_3f( o2133, c2141 ); if ( TRUE( X2 ) ) goto L3524; X3 = scrt1_equal_3f( o2133, c2146 ); if ( TRUE( X3 ) ) goto L3524; X4 = scrt1_equal_3f( o2133, c2151 ); if ( TRUE( X4 ) ) goto L3524; if ( TRUE( scrt1_equal_3f( o2133, c2153 ) ) ) goto L3524; POPSTACKTRACE( scdebug_error( c2154, c2155, CONS( o2133, EMPTYLIST ) ) ); L3524: POPSTACKTRACE( SET( sceval_optimize_2doptions_v, o2133 ) ); } DEFTSCP( sceval_top_2dlevel_2drewrite_v ); DEFCSTRING( t3542, "SCEVAL_TOP-LEVEL-REWRITE" ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); DEFTSCP( sceval_list1_v ); DEFCSTRING( t3543, "SCEVAL_LIST1" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP sceval_list1( x2192 ) TSCP x2192; { TSCP X1; PUSHSTACKTRACE( t3543 ); X1 = sc_cons( x2192, EMPTYLIST ); POPSTACKTRACE( X1 ); } DEFTSCP( sceval_list2_v ); DEFCSTRING( t3546, "SCEVAL_LIST2" ); TSCP sceval_list2( x2197, y2198 ) TSCP x2197, y2198; { TSCP X2, X1; PUSHSTACKTRACE( t3546 ); X2 = sc_cons( y2198, EMPTYLIST ); X1 = sc_cons( x2197, X2 ); POPSTACKTRACE( X1 ); } DEFTSCP( sceval_list3_v ); DEFCSTRING( t3549, "SCEVAL_LIST3" ); TSCP sceval_list3( x2203, y2204, z2205 ) TSCP x2203, y2204, z2205; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3549 ); X3 = sc_cons( z2205, EMPTYLIST ); X2 = sc_cons( y2204, X3 ); X1 = sc_cons( x2203, X2 ); POPSTACKTRACE( X1 ); } DEFTSCP( sceval_negate_v ); DEFCSTRING( t3552, "SCEVAL_NEGATE" ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); TSCP sceval_negate( x2210 ) TSCP x2210; { PUSHSTACKTRACE( t3552 ); if ( NEQ( TSCPTAG( x2210 ), FIXNUMTAG ) ) goto L3554; POPSTACKTRACE( _TSCP( INEGATE( _S2CINT( x2210 ) ) ) ); L3554: POPSTACKTRACE( scrt2__2d_2dtwo( c2217, x2210 ) ); } DEFTSCP( sceval__2f1_v ); DEFCSTRING( t3556, "SCEVAL_/1" ); EXTERNTSCPP( scrt2__2f_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2f_2dtwo_v ); TSCP sceval__2f1( x2220 ) TSCP x2220; { TSCP X2, X1; PUSHSTACKTRACE( t3556 ); X1 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( x2220 ) ), 3 ) ) ); if ( FALSE( X1 ) ) goto L3568; if ( EQ( _S2CUINT( x2220 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3568; X2 = _TSCP( REMAINDER( _S2CINT( _TSCP( 4 ) ), _S2CINT( x2220 ) ) ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3568; POPSTACKTRACE( C_FIXED( QUOTIENT( _S2CINT( _TSCP( 4 ) ), _S2CINT( x2220 ) ) ) ); L3568: POPSTACKTRACE( scrt2__2f_2dtwo( _TSCP( 4 ), x2220 ) ); } DEFTSCP( sceval_sizeof_2dtscp_v ); DEFCSTRING( t3569, "SCEVAL_SIZEOF-TSCP" ); DEFTSCP( sceval_codex_v ); DEFCSTRING( t3570, "SCEVAL_CODEX" ); DEFTSCP( sceval_closurex_v ); DEFCSTRING( t3571, "SCEVAL_CLOSUREX" ); EXTERNTSCPP( scrt2__2a_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2a_2dtwo_v ); DEFTSCP( sceval_var0x_v ); DEFCSTRING( t3575, "SCEVAL_VAR0X" ); DEFTSCP( sceval_var1x_v ); DEFCSTRING( t3579, "SCEVAL_VAR1X" ); DEFTSCP( sceval_var2x_v ); DEFCSTRING( t3583, "SCEVAL_VAR2X" ); DEFTSCP( sceval_compile_v ); DEFCSTRING( t3587, "SCEVAL_COMPILE" ); EXTERNTSCPP( sceval_compile, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sceval_compile_v ); EXTERNTSCPP( scrt1_cadddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadddr_v ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_assq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assq_v ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( sceval_compile_2dlist, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sceval_compile_2dlist_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt2_top_2dlevel_2dvalue, XAL1( TSCP ) ); EXTERNTSCP( scrt2_top_2dlevel_2dvalue_v ); EXTERNTSCPP( scrt1_assoc, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assoc_v ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( scrt1_boolean_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt1_boolean_3f_v ); EXTERNTSCP( sceval_compile_2derror_v ); EXTERNTSCPP( scrt4_scheme_2dtscp_2dref, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_scheme_2dtscp_2dref_v ); EXTERNTSCP( sceval_interpreted_2dproc_v ); EXTERNTSCPP( scrt2__3c_3d, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_3d_v ); TSCP sceval_compile( e2276, e2277 ) TSCP e2276, e2277; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3587 ); L3588: if ( AND( EQ( TSCPTAG( e2276 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2276 ), SYMBOLTAG ) ) ) goto L3589; if ( NEQ( TSCPTAG( e2276 ), PAIRTAG ) ) goto L3591; X4 = PAIR_CAR( e2276 ); if ( EQ( _S2CUINT( X4 ), _S2CUINT( c2313 ) ) ) goto L3595; if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2323 ) ) ) goto L3597; X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cadddr( e2276 ); X5 = CONS( sceval_compile( X6, e2277 ), X5 ); X6 = scrt1_caddr( e2276 ); X5 = CONS( sceval_compile( X6, e2277 ), X5 ); X7 = PAIR_CDR( e2276 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3601; scrt1__24__car_2derror( X7 ); L3601: X6 = PAIR_CAR( X7 ); POPSTACKTRACE( scrt1_cons_2a( c2323, CONS( sceval_compile( X6, e2277 ), X5 ) ) ); L3597: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2327 ) ) ) goto L3603; X6 = PAIR_CDR( e2276 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3609; scrt1__24__car_2derror( X6 ); L3609: X5 = PAIR_CAR( X6 ); if ( FALSE( scrt1_assq( X5, e2277 ) ) ) goto L3605; X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_caddr( e2276 ); X5 = CONS( sceval_compile( X6, e2277 ), X5 ); X6 = PAIR_CDR( e2276 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3613; scrt1__24__car_2derror( X6 ); L3613: POPSTACKTRACE( scrt1_cons_2a( c2327, CONS( PAIR_CAR( X6 ), X5 ) ) ); L3605: X6 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_caddr( e2276 ), X6 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = PAIR_CDR( e2276 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3617; scrt1__24__car_2derror( X8 ); L3617: X5 = scrt1_cons_2a( c2509, CONS( scrt1_cons_2a( c2313, CONS( PAIR_CAR( X8 ), X7 ) ), X6 ) ); e2276 = X5; GOBACK( L3588 ); L3603: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2331 ) ) ) goto L3619; X5 = scrt1_length( e2276 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( _TSCP( 8 ) ) ) ) goto L3621; X6 = PAIR_CDR( e2276 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3625; scrt1__24__car_2derror( X6 ); L3625: X5 = PAIR_CAR( X6 ); e2276 = X5; GOBACK( L3588 ); L3621: X6 = PAIR_CDR( e2276 ); X5 = sceval_compile_2dlist( X6, e2277 ); X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2331, CONS( scrt1_append_2dtwo( X5, X6 ), EMPTYLIST ) ) ); L3619: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2335 ) ) ) goto L3628; X7 = PAIR_CDR( e2276 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3632; scrt1__24__car_2derror( X7 ); L3632: X6 = PAIR_CAR( X7 ); X7 = e2277; X8 = X6; L3636: if ( NEQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L3637; X5 = X7; goto L3640; L3637: if ( NOT( AND( EQ( TSCPTAG( X8 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X8 ), SYMBOLTAG ) ) ) ) goto L3639; X10 = sc_cons( X8, EMPTYLIST ); X9 = X10; X5 = sc_cons( X9, X7 ); goto L3640; L3639: if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3643; scrt1__24__car_2derror( X8 ); L3643: X12 = PAIR_CAR( X8 ); X11 = sc_cons( X12, EMPTYLIST ); X10 = X11; X9 = sc_cons( X10, X7 ); X8 = PAIR_CDR( X8 ); X7 = X9; GOBACK( L3636 ); L3640: X9 = PAIR_CDR( e2276 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3650; scrt1__24__cdr_2derror( X9 ); L3650: X8 = PAIR_CDR( X9 ); X7 = sceval_compile_2dlist( X8, X5 ); X8 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_append_2dtwo( X7, X8 ), EMPTYLIST ); X7 = PAIR_CDR( e2276 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3654; scrt1__24__car_2derror( X7 ); L3654: POPSTACKTRACE( scrt1_cons_2a( c2335, CONS( PAIR_CAR( X7 ), X6 ) ) ); L3628: X1 = PAIR_CAR( e2276 ); if ( NOT( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), SYMBOLTAG ) ) ) ) goto L3658; if ( FALSE( scrt1_assq( X1, e2277 ) ) ) goto L3660; X3 = FALSEVALUE; goto L3659; L3660: X3 = TRUEVALUE; goto L3659; L3658: X3 = FALSEVALUE; L3659: if ( FALSE( X3 ) ) goto L3663; X2 = scrt2_top_2dlevel_2dvalue( X1 ); goto L3664; L3663: X2 = X3; L3664: if ( FALSE( X3 ) ) goto L3666; X10 = scrt1_length( e2276 ); if ( BITAND( BITOR( _S2CINT( X10 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3669; X9 = _TSCP( IDIFFERENCE( _S2CINT( X10 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3670; L3669: X9 = scrt2__2d_2dtwo( X10, _TSCP( 4 ) ); L3670: X8 = sc_cons( X9, EMPTYLIST ); X7 = sc_cons( X1, X8 ); X6 = X7; X5 = scrt1_assoc( X6, sceval_top_2dlevel_2drewrite_v ); goto L3667; L3666: X5 = X3; L3667: if ( FALSE( X5 ) ) goto L3691; if ( FALSE( scrt1_memq( c2348, sceval_optimize_2doptions_v ) ) ) goto L3691; if ( FALSE( scrt1_memq( c2356, sceval_optimize_2doptions_v ) ) ) goto L3678; X10 = scrt1_length( e2276 ); if ( BITAND( BITOR( _S2CINT( X10 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3681; X9 = _TSCP( IDIFFERENCE( _S2CINT( X10 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3682; L3681: X9 = scrt2__2d_2dtwo( X10, _TSCP( 4 ) ); L3682: X8 = sc_cons( X9, EMPTYLIST ); X7 = X8; goto L3679; L3678: X7 = EMPTYLIST; L3679: if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3685; scrt1__24__cdr_2derror( X5 ); L3685: X10 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3688; scrt1__24__car_2derror( X10 ); L3688: X9 = PAIR_CAR( X10 ); X11 = PAIR_CDR( e2276 ); X10 = sceval_compile_2dlist( X11, e2277 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( X9, CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ) ); X6 = scrt1_append_2dtwo( X7, X8 ); POPSTACKTRACE( scrt1_cons_2a( X6, EMPTYLIST ) ); L3595: POPSTACKTRACE( e2276 ); L3591: if ( EQ( TSCPTAG( e2276 ), FIXNUMTAG ) ) goto L3692; if ( AND( EQ( TSCPTAG( e2276 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2276 ), DOUBLEFLOATTAG ) ) ) goto L3694; if ( AND( EQ( TSCPTAG( e2276 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2276 ), STRINGTAG ) ) ) goto L3696; if ( EQ( TSCPIMMEDIATETAG( e2276 ), CHARACTERTAG ) ) goto L3698; if ( TRUE( scrt1_boolean_3f( e2276 ) ) ) goto L3700; if ( NOT( AND( EQ( TSCPTAG( e2276 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2276 ), RECORDTAG ) ) ) ) goto L3702; X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_cons_2a( c2313, CONS( c2314, X7 ) ), X6 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X5 = scrt1_cons_2a( c2312, CONS( scrt1_cons_2a( c2313, CONS( e2276, X7 ) ), X6 ) ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X4 = scrt1_cons_2a( X5, CONS( scrt1_cons_2a( c2313, CONS( e2276, X7 ) ), X6 ) ); e2276 = X4; GOBACK( L3588 ); L3702: sceval_compile_2derror_v = e2276; POPSTACKTRACE( TRUEVALUE ); L3700: POPSTACKTRACE( e2276 ); L3698: POPSTACKTRACE( e2276 ); L3696: POPSTACKTRACE( e2276 ); L3694: POPSTACKTRACE( e2276 ); L3692: POPSTACKTRACE( e2276 ); L3589: POPSTACKTRACE( e2276 ); L3691: if ( FALSE( X3 ) ) goto L3727; X4 = scrt1_memq( c2356, sceval_optimize_2doptions_v ); if ( FALSE( X4 ) ) goto L3727; if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), PROCEDURETAG ) ) ) ) goto L3727; X5 = scrt4_scheme_2dtscp_2dref( X2, sceval_codex_v ); X6 = scrt4_scheme_2dtscp_2dref( sceval_interpreted_2dproc_v, sceval_codex_v ); if ( EQ( _S2CUINT( X5 ), _S2CUINT( X6 ) ) ) goto L3727; X5 = scrt1_length( e2276 ); if ( FALSE( scrt2__3c_3d( _TSCP( 8 ), X5, CONS( _TSCP( 16 ), EMPTYLIST ) ) ) ) goto L3727; X6 = scrt1_length( e2276 ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3721; X5 = _TSCP( IDIFFERENCE( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3722; L3721: X5 = scrt2__2d_2dtwo( X6, _TSCP( 4 ) ); L3722: X8 = PAIR_CDR( e2276 ); X7 = sceval_compile_2dlist( X8, e2277 ); X8 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_append_2dtwo( X7, X8 ), EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( X5, CONS( X1, X6 ) ) ); L3727: POPSTACKTRACE( sceval_compile_2dlist( e2276, e2277 ) ); } DEFTSCP( sceval_compile_2derror_v ); DEFCSTRING( t3728, "SCEVAL_COMPILE-ERROR" ); DEFTSCP( sceval_compile_2dlist_v ); DEFCSTRING( t3729, "SCEVAL_COMPILE-LIST" ); TSCP sceval_compile_2dlist( e2555, e2556 ) TSCP e2555, e2556; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3729 ); X1 = e2555; X2 = EMPTYLIST; X3 = EMPTYLIST; L3732: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3733; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3736; scrt1__24__car_2derror( X1 ); L3736: X6 = PAIR_CAR( X1 ); X5 = sceval_compile( X6, e2556 ); X4 = sc_cons( X5, EMPTYLIST ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3739; X5 = PAIR_CDR( X1 ); X3 = X4; X2 = X4; X1 = X5; GOBACK( L3732 ); L3739: X5 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3744; scdebug_error( c2591, c2592, CONS( X3, EMPTYLIST ) ); L3744: X3 = SETGEN( PAIR_CDR( X3 ), X4 ); X1 = X5; GOBACK( L3732 ); L3733: POPSTACKTRACE( X2 ); } DEFTSCP( sceval_eval_v ); DEFCSTRING( t3746, "EVAL" ); EXTERNTSCPP( scrt1_list_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt1_list_3f_v ); EXTERNTSCPP( scexpand_expand, XAL1( TSCP ) ); EXTERNTSCP( scexpand_expand_v ); EXTERNTSCPP( sceval_exec, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sceval_exec_v ); EXTERNTSCP( sc_undefined ); TSCP sceval_eval( f2604, e2605 ) TSCP f2604, e2605; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3746 ); sceval_compile_2derror_v = FALSEVALUE; if ( NEQ( TSCPTAG( e2605 ), PAIRTAG ) ) goto L3748; X2 = PAIR_CAR( e2605 ); X3 = X2; L3752: X4 = BOOLEAN( EQ( TSCPTAG( X3 ), PAIRTAG ) ); if ( FALSE( X4 ) ) goto L3759; X5 = PAIR_CAR( X3 ); if ( NEQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3759; X3 = PAIR_CDR( X3 ); GOBACK( L3752 ); L3759: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3761; X1 = PAIR_CAR( e2605 ); goto L3749; L3761: X1 = scdebug_error( c2653, c2696, CONS( PAIR_CAR( e2605 ), EMPTYLIST ) ); goto L3749; L3748: X1 = EMPTYLIST; L3749: X4 = scrt1_list_3f( f2604 ); if ( FALSE( X4 ) ) goto L3774; if ( EQ( _S2CUINT( f2604 ), _S2CUINT( EMPTYLIST ) ) ) goto L3774; X5 = PAIR_CAR( f2604 ); if ( FALSE( scrt1_equal_3f( X5, c2670 ) ) ) goto L3774; X3 = PAIR_CAR( PAIR_CDR( f2604 ) ); goto L3775; L3774: X3 = scexpand_expand( f2604 ); L3775: X2 = sceval_compile( X3, X1 ); if ( NEQ( _S2CUINT( sceval_compile_2derror_v ), _S2CUINT( FALSEVALUE ) ) ) goto L3777; if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3779; POPSTACKTRACE( sceval_exec( X2, X1 ) ); L3779: if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3781; X3 = X1; L3784: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3785; X4 = SYMBOL_VALUE( X2 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( sc_undefined ) ) ) goto L3788; POPSTACKTRACE( scdebug_error( X2, c2649, EMPTYLIST ) ); L3788: POPSTACKTRACE( X4 ); L3785: X5 = PAIR_CAR( X3 ); X4 = PAIR_CAR( X5 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X4 ) ) ) goto L3790; X4 = PAIR_CAR( X3 ); POPSTACKTRACE( PAIR_CDR( X4 ) ); L3790: X3 = PAIR_CDR( X3 ); GOBACK( L3784 ); L3781: POPSTACKTRACE( X2 ); L3777: POPSTACKTRACE( scdebug_error( c2653, c2654, CONS( sceval_compile_2derror_v, EMPTYLIST ) ) ); } DEFTSCP( sceval_exec_v ); DEFCSTRING( t3792, "SCEVAL_EXEC" ); EXTERNTSCPP( sceval_exec_2dlambda, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sceval_exec_2dlambda_v ); EXTERNTSCPP( sceval_l2921, XAL2( TSCP, TSCP ) ); TSCP sceval_l2921( e2923, e2924 ) TSCP e2923, e2924; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside EXEC]" ); if ( NEQ( TSCPTAG( e2923 ), PAIRTAG ) ) goto L3921; X2 = PAIR_CAR( e2923 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3924; X1 = sceval_exec( X2, e2924 ); goto L3927; L3924: if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3926; X3 = e2924; L3929: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3930; X4 = SYMBOL_VALUE( X2 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( sc_undefined ) ) ) goto L3933; X1 = scdebug_error( X2, c2649, EMPTYLIST ); goto L3927; L3933: X1 = X4; goto L3927; L3930: X5 = PAIR_CAR( X3 ); X4 = PAIR_CAR( X5 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X4 ) ) ) goto L3935; X4 = PAIR_CAR( X3 ); X1 = PAIR_CDR( X4 ); goto L3927; L3935: X3 = PAIR_CDR( X3 ); GOBACK( L3929 ); L3926: X1 = X2; L3927: X3 = PAIR_CDR( e2923 ); X2 = sceval_l2921( X3, e2924 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L3921: POPSTACKTRACE( EMPTYLIST ); } EXTERNTSCPP( sc_apply_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_apply_2dtwo_v ); EXTERNTSCPP( sceval_l2746, XAL2( TSCP, TSCP ) ); TSCP sceval_l2746( e2748, e2749 ) TSCP e2748, e2749; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside EXEC]" ); if ( NEQ( TSCPTAG( e2748 ), PAIRTAG ) ) goto L3970; X2 = PAIR_CAR( e2748 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3973; X1 = sceval_exec( X2, e2749 ); goto L3976; L3973: if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3975; X3 = e2749; L3978: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3979; X4 = SYMBOL_VALUE( X2 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( sc_undefined ) ) ) goto L3982; X1 = scdebug_error( X2, c2649, EMPTYLIST ); goto L3976; L3982: X1 = X4; goto L3976; L3979: X5 = PAIR_CAR( X3 ); X4 = PAIR_CAR( X5 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X4 ) ) ) goto L3984; X4 = PAIR_CAR( X3 ); X1 = PAIR_CDR( X4 ); goto L3976; L3984: X3 = PAIR_CDR( X3 ); GOBACK( L3978 ); L3975: X1 = X2; L3976: X3 = PAIR_CDR( e2748 ); X2 = sceval_l2746( X3, e2749 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L3970: POPSTACKTRACE( EMPTYLIST ); } TSCP sceval_exec( e2707, e2708 ) TSCP e2707, e2708; { TSCP X20, X19, X18, X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3792 ); L3793: LOOPSTACKTRACE( e2707, e2708 ); X1 = PAIR_CAR( e2707 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2323 ) ) ) goto L3795; X2 = PAIR_CAR( PAIR_CDR( e2707 ) ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3799; if ( TRUE( sceval_exec( X2, e2708 ) ) ) goto L3803; goto L3804; L3799: if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3806; X3 = e2708; L3811: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3812; X5 = SYMBOL_VALUE( X2 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( sc_undefined ) ) ) goto L3815; X4 = scdebug_error( X2, c2649, EMPTYLIST ); goto L3818; L3815: X4 = X5; goto L3818; L3812: X6 = PAIR_CAR( X3 ); X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X5 ) ) ) goto L3817; X5 = PAIR_CAR( X3 ); X4 = PAIR_CDR( X5 ); goto L3818; L3817: X3 = PAIR_CDR( X3 ); GOBACK( L3811 ); L3818: if ( TRUE( X4 ) ) goto L3803; goto L3804; L3806: if ( TRUE( X2 ) ) goto L3803; goto L3804; L3795: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2327 ) ) ) goto L3823; X3 = PAIR_CAR( PAIR_CDR( PAIR_CDR( e2707 ) ) ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3826; X2 = sceval_exec( X3, e2708 ); goto L3829; L3826: if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) ) goto L3828; X4 = e2708; L3831: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3832; X5 = SYMBOL_VALUE( X3 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( sc_undefined ) ) ) goto L3835; X2 = scdebug_error( X3, c2649, EMPTYLIST ); goto L3829; L3835: X2 = X5; goto L3829; L3832: X6 = PAIR_CAR( X4 ); X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( X5 ) ) ) goto L3837; X5 = PAIR_CAR( X4 ); X2 = PAIR_CDR( X5 ); goto L3829; L3837: X4 = PAIR_CDR( X4 ); GOBACK( L3831 ); L3828: X2 = X3; L3829: X4 = PAIR_CAR( PAIR_CDR( e2707 ) ); X5 = X4; X6 = e2708; L3841: if ( FALSE( X6 ) ) goto L3842; X7 = PAIR_CAR( X6 ); X8 = PAIR_CAR( X7 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( X8 ) ) ) goto L3845; X3 = X7; goto L3843; L3845: X6 = PAIR_CDR( X6 ); GOBACK( L3841 ); L3842: X3 = FALSEVALUE; L3843: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3848; scdebug_error( c2591, c2592, CONS( X3, EMPTYLIST ) ); L3848: POPSTACKTRACE( SETGEN( PAIR_CDR( X3 ), X2 ) ); L3823: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2313 ) ) ) goto L3850; POPSTACKTRACE( PAIR_CAR( PAIR_CDR( e2707 ) ) ); L3850: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2335 ) ) ) goto L3852; POPSTACKTRACE( sceval_exec_2dlambda( e2707, e2708 ) ); L3852: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2331 ) ) ) goto L3854; X2 = PAIR_CDR( e2707 ); L3857: X3 = PAIR_CDR( X2 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3858; X3 = PAIR_CAR( X2 ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3861; e2707 = X3; GOBACK( L3793 ); L3861: if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) ) goto L3863; X4 = e2708; L3866: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3867; X5 = SYMBOL_VALUE( X3 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( sc_undefined ) ) ) goto L3870; POPSTACKTRACE( scdebug_error( X3, c2649, EMPTYLIST ) ); L3870: POPSTACKTRACE( X5 ); L3867: X6 = PAIR_CAR( X4 ); X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( X5 ) ) ) goto L3872; X5 = PAIR_CAR( X4 ); POPSTACKTRACE( PAIR_CDR( X5 ) ); L3872: X4 = PAIR_CDR( X4 ); GOBACK( L3866 ); L3863: POPSTACKTRACE( X3 ); L3858: X3 = PAIR_CAR( X2 ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3876; sceval_exec( X3, e2708 ); goto L3888; L3876: if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) ) goto L3888; X4 = e2708; L3881: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3882; X5 = SYMBOL_VALUE( X3 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( sc_undefined ) ) ) goto L3888; scdebug_error( X3, c2649, EMPTYLIST ); goto L3888; L3882: X6 = PAIR_CAR( X4 ); X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( X5 ) ) ) goto L3887; X5 = PAIR_CAR( X4 ); PAIR_CDR( X5 ); goto L3888; L3887: X4 = PAIR_CDR( X4 ); GOBACK( L3881 ); L3888: X2 = PAIR_CDR( X2 ); GOBACK( L3857 ); L3854: X3 = PAIR_CAR( e2707 ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3890; X2 = sceval_exec( X3, e2708 ); goto L3893; L3890: if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) ) goto L3892; X4 = e2708; L3895: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3896; X5 = SYMBOL_VALUE( X3 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( sc_undefined ) ) ) goto L3899; X2 = scdebug_error( X3, c2649, EMPTYLIST ); goto L3893; L3899: X2 = X5; goto L3893; L3896: X6 = PAIR_CAR( X4 ); X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( X5 ) ) ) goto L3901; X5 = PAIR_CAR( X4 ); X2 = PAIR_CDR( X5 ); goto L3893; L3901: X4 = PAIR_CDR( X4 ); GOBACK( L3895 ); L3892: X2 = X3; L3893: if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), PROCEDURETAG ) ) ) ) goto L3904; X3 = MTSCP( T_U( X2 ), FIXED_C( sceval_codex_v ) ); X4 = MTSCP( T_U( sceval_interpreted_2dproc_v ), FIXED_C( sceval_codex_v ) ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( X4 ) ) ) goto L3906; X3 = MTSCP( T_U( X2 ), FIXED_C( sceval_closurex_v ) ); X4 = MTSCP( T_U( X3 ), FIXED_C( sceval_var0x_v ) ); X6 = MTSCP( T_U( X3 ), FIXED_C( sceval_var1x_v ) ); X7 = PAIR_CDR( e2707 ); X8 = MTSCP( T_U( X3 ), FIXED_C( sceval_var2x_v ) ); X9 = X8; X10 = X7; X11 = X6; L3911: if ( NEQ( _S2CUINT( X9 ), _S2CUINT( EMPTYLIST ) ) ) goto L3912; if ( FALSE( X10 ) ) goto L3915; scdebug_error( c2912, c2970, EMPTYLIST ); L3915: X5 = X11; goto L3938; L3912: if ( NOT( AND( EQ( TSCPTAG( X9 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X9 ), SYMBOLTAG ) ) ) ) goto L3917; X13 = sceval_l2921( X10, e2708 ); X12 = sc_cons( X9, X13 ); X5 = sc_cons( X12, X11 ); goto L3938; L3917: if ( NEQ( _S2CUINT( X10 ), _S2CUINT( EMPTYLIST ) ) ) goto L3937; X5 = scdebug_error( c2912, c2913, EMPTYLIST ); goto L3938; L3937: X12 = PAIR_CDR( X9 ); X13 = PAIR_CDR( X10 ); X15 = PAIR_CAR( X9 ); X17 = PAIR_CAR( X10 ); if ( NEQ( TSCPTAG( X17 ), PAIRTAG ) ) goto L3940; X16 = sceval_exec( X17, e2708 ); goto L3943; L3940: if ( NOT( AND( EQ( TSCPTAG( X17 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X17 ), SYMBOLTAG ) ) ) ) goto L3942; X18 = e2708; L3945: if ( NEQ( _S2CUINT( X18 ), _S2CUINT( EMPTYLIST ) ) ) goto L3946; X19 = SYMBOL_VALUE( X17 ); if ( NEQ( _S2CUINT( X19 ), _S2CUINT( sc_undefined ) ) ) goto L3949; X16 = scdebug_error( X17, c2649, EMPTYLIST ); goto L3943; L3949: X16 = X19; goto L3943; L3946: X20 = PAIR_CAR( X18 ); X19 = PAIR_CAR( X20 ); if ( NEQ( _S2CUINT( X17 ), _S2CUINT( X19 ) ) ) goto L3951; X19 = PAIR_CAR( X18 ); X16 = PAIR_CDR( X19 ); goto L3943; L3951: X18 = PAIR_CDR( X18 ); GOBACK( L3945 ); L3942: X16 = X17; L3943: X14 = sc_cons( X15, X16 ); X11 = sc_cons( X14, X11 ); X10 = X13; X9 = X12; GOBACK( L3911 ); L3938: if ( NEQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3954; e2708 = X5; e2707 = X4; GOBACK( L3793 ); L3954: if ( NOT( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), SYMBOLTAG ) ) ) ) goto L3956; X6 = X5; L3959: if ( NEQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L3960; X7 = SYMBOL_VALUE( X4 ); if ( NEQ( _S2CUINT( X7 ), _S2CUINT( sc_undefined ) ) ) goto L3963; POPSTACKTRACE( scdebug_error( X4, c2649, EMPTYLIST ) ); L3963: POPSTACKTRACE( X7 ); L3960: X8 = PAIR_CAR( X6 ); X7 = PAIR_CAR( X8 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( X7 ) ) ) goto L3965; X7 = PAIR_CAR( X6 ); POPSTACKTRACE( PAIR_CDR( X7 ) ); L3965: X6 = PAIR_CDR( X6 ); GOBACK( L3959 ); L3956: POPSTACKTRACE( X4 ); L3906: X4 = PAIR_CDR( e2707 ); X3 = sceval_l2746( X4, e2708 ); POPSTACKTRACE( sc_apply_2dtwo( X2, X3 ) ); L3904: POPSTACKTRACE( scdebug_error( c2982, c2983, CONS( PAIR_CAR( e2707 ), EMPTYLIST ) ) ); L3803: X1 = PAIR_CAR( PAIR_CDR( PAIR_CDR( e2707 ) ) ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3987; e2707 = X1; GOBACK( L3793 ); L3987: if ( NOT( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), SYMBOLTAG ) ) ) ) goto L3989; X2 = e2708; L3992: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3993; X3 = SYMBOL_VALUE( X1 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( sc_undefined ) ) ) goto L3996; POPSTACKTRACE( scdebug_error( X1, c2649, EMPTYLIST ) ); L3996: POPSTACKTRACE( X3 ); L3993: X4 = PAIR_CAR( X2 ); X3 = PAIR_CAR( X4 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( X3 ) ) ) goto L3998; X3 = PAIR_CAR( X2 ); POPSTACKTRACE( PAIR_CDR( X3 ) ); L3998: X2 = PAIR_CDR( X2 ); GOBACK( L3992 ); L3989: POPSTACKTRACE( X1 ); L3804: X1 = PAIR_CAR( PAIR_CDR( PAIR_CDR( PAIR_CDR( e2707 ) ) ) ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4001; e2707 = X1; GOBACK( L3793 ); L4001: if ( NOT( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), SYMBOLTAG ) ) ) ) goto L4003; X2 = e2708; L4006: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4007; X3 = SYMBOL_VALUE( X1 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( sc_undefined ) ) ) goto L4010; POPSTACKTRACE( scdebug_error( X1, c2649, EMPTYLIST ) ); L4010: POPSTACKTRACE( X3 ); L4007: X4 = PAIR_CAR( X2 ); X3 = PAIR_CAR( X4 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( X3 ) ) ) goto L4012; X3 = PAIR_CAR( X2 ); POPSTACKTRACE( PAIR_CDR( X3 ) ); L4012: X2 = PAIR_CDR( X2 ); GOBACK( L4006 ); L4003: POPSTACKTRACE( X1 ); } DEFTSCP( sceval_interpreted_2dproc_v ); DEFCSTRING( t4014, "SCEVAL_INTERPRETED-PROC" ); DEFTSCP( sceval_exec_2dlambda_v ); DEFCSTRING( t4015, "SCEVAL_EXEC-LAMBDA" ); EXTERNTSCPP( sceval_l3372, XAL3( TSCP, TSCP, TSCP ) ); TSCP sceval_l3372( i3374, v3375, e3376 ) TSCP i3374, v3375, e3376; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside EXEC-LAMBDA]" ); if ( NEQ( _S2CUINT( i3374 ), _S2CUINT( EMPTYLIST ) ) ) goto L4023; if ( FALSE( v3375 ) ) goto L4026; scdebug_error( c2912, c2970, EMPTYLIST ); L4026: POPSTACKTRACE( e3376 ); L4023: if ( NOT( AND( EQ( TSCPTAG( i3374 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( i3374 ), SYMBOLTAG ) ) ) ) goto L4028; X1 = sc_cons( i3374, v3375 ); POPSTACKTRACE( sc_cons( X1, e3376 ) ); L4028: if ( NEQ( _S2CUINT( v3375 ), _S2CUINT( EMPTYLIST ) ) ) goto L4030; POPSTACKTRACE( scdebug_error( c2912, c2913, EMPTYLIST ) ); L4030: X2 = PAIR_CAR( i3374 ); X3 = PAIR_CAR( v3375 ); X1 = sc_cons( X2, X3 ); X3 = PAIR_CDR( i3374 ); X4 = PAIR_CDR( v3375 ); X2 = sceval_l3372( X3, X4, e3376 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); } TSCP sceval_l3323( v3324, c4018 ) TSCP v3324, c4018; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "sceval_l3323 [inside EXEC-LAMBDA]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c4018, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c4018, 1 ); X3 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c4018, 2 ); X6 = DISPLAY( 2 ); X7 = DISPLAY( 0 ); X5 = sceval_l3372( X6, v3324, X7 ); X6 = DISPLAY( 1 ); if ( NEQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4033; X4 = sceval_exec( X6, X5 ); goto L4036; L4033: if ( NOT( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), SYMBOLTAG ) ) ) ) goto L4035; X7 = X5; L4038: if ( NEQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L4039; X8 = SYMBOL_VALUE( X6 ); if ( NEQ( _S2CUINT( X8 ), _S2CUINT( sc_undefined ) ) ) goto L4042; X4 = scdebug_error( X6, c2649, EMPTYLIST ); goto L4036; L4042: X4 = X8; goto L4036; L4039: X9 = PAIR_CAR( X7 ); X8 = PAIR_CAR( X9 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( X8 ) ) ) goto L4044; X8 = PAIR_CAR( X7 ); X4 = PAIR_CDR( X8 ); goto L4036; L4044: X7 = PAIR_CDR( X7 ); GOBACK( L4038 ); L4035: X4 = X6; L4036: DISPLAY( 1 ) = X1; DISPLAY( 0 ) = X2; DISPLAY( 2 ) = X3; POPSTACKTRACE( X4 ); } TSCP sceval_exec_2dlambda( e3318, e3319 ) TSCP e3318, e3319; { TSCP X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( t4015 ); DISPLAY( 0 ) = e3319; X2 = PAIR_CDR( e3318 ); X1 = PAIR_CDR( X2 ); DISPLAY( 1 ) = sc_cons( c2331, X1 ); DISPLAY( 2 ) = PAIR_CAR( PAIR_CDR( e3318 ) ); SDVAL = MAKEPROCEDURE( 0, 1, sceval_l3323, MAKECLOSURE( EMPTYLIST, 3, DISPLAY( 1 ), DISPLAY( 0 ), DISPLAY( 2 ) ) ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } void scexpand__init(); void scrt4__init(); void scrt2__init(); void scdebug__init(); void scrt1__init(); void scexpand__init(); void scexpnd1__init(); void scexpnd2__init(); void scrt1__init(); void scrt2__init(); void scrt3__init(); void scrt4__init(); void scrt5__init(); void scrt6__init(); void scrt7__init(); void scrtuser__init(); static void init_modules( compiler_version ) char *compiler_version; { scexpand__init(); scrt4__init(); scrt2__init(); scdebug__init(); scrt1__init(); scexpand__init(); scexpnd1__init(); scexpnd2__init(); scrt1__init(); scrt2__init(); scrt3__init(); scrt4__init(); scrt5__init(); scrt6__init(); scrt7__init(); scrtuser__init(); MAXDISPLAY( 3 ); } void sceval__init() { TSCP X4, X3, X2, X1; static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(sceval SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3517, ADR( sceval_optimize_2doptions_v ), EMPTYLIST ); INITIALIZEVAR( t3518, ADR( sceval_optimize_2deval_v ), MAKEPROCEDURE( 0, 1, sceval_optimize_2deval, EMPTYLIST ) ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = scrt1_cons_2a( c2157, CONS( _TSCP( 4 ), X3 ) ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X1 = scrt1_cons_2a( X2, CONS( c2159, X3 ) ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2187, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2189, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2187, CONS( _TSCP( 4 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2188, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2184, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2186, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2184, CONS( _TSCP( 4 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2185, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2182, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2183, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2180, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2181, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2178, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2179, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2176, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2177, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2174, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2175, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2172, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2173, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2170, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2171, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2168, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2169, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2166, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2167, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2164, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2165, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2157, CONS( _TSCP( 12 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( X3, CONS( c2163, X4 ) ), X2 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2157, CONS( _TSCP( 8 ), X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); INITIALIZEVAR( t3542, ADR( sceval_top_2dlevel_2drewrite_v ), scrt1_cons_2a( X1, CONS( scrt1_cons_2a( X3, CONS( c2161, X4 ) ), X2 ) ) ); INITIALIZEVAR( t3543, ADR( sceval_list1_v ), MAKEPROCEDURE( 1, 0, sceval_list1, EMPTYLIST ) ); INITIALIZEVAR( t3546, ADR( sceval_list2_v ), MAKEPROCEDURE( 2, 0, sceval_list2, EMPTYLIST ) ); INITIALIZEVAR( t3549, ADR( sceval_list3_v ), MAKEPROCEDURE( 3, 0, sceval_list3, EMPTYLIST ) ); INITIALIZEVAR( t3552, ADR( sceval_negate_v ), MAKEPROCEDURE( 1, 0, sceval_negate, EMPTYLIST ) ); INITIALIZEVAR( t3556, ADR( sceval__2f1_v ), MAKEPROCEDURE( 1, 0, sceval__2f1, EMPTYLIST ) ); INITIALIZEVAR( t3569, ADR( sceval_sizeof_2dtscp_v ), C_FIXED( SIZEOF( TSCP ) ) ); INITIALIZEVAR( t3570, ADR( sceval_codex_v ), sceval_sizeof_2dtscp_v ); X1 = sceval_sizeof_2dtscp_v; if ( BITAND( BITOR( _S2CINT( _TSCP( 8 ) ), _S2CINT( X1 ) ), 3 ) ) goto L3573; X2 = _TSCP( ITIMES( FIXED_C( _TSCP( 8 ) ), _S2CINT( X1 ) ) ); goto L3574; L3573: X2 = scrt2__2a_2dtwo( _TSCP( 8 ), X1 ); L3574: INITIALIZEVAR( t3571, ADR( sceval_closurex_v ), X2 ); X1 = sceval_sizeof_2dtscp_v; if ( BITAND( BITOR( _S2CINT( _TSCP( 8 ) ), _S2CINT( X1 ) ), 3 ) ) goto L3577; X2 = _TSCP( ITIMES( FIXED_C( _TSCP( 8 ) ), _S2CINT( X1 ) ) ); goto L3578; L3577: X2 = scrt2__2a_2dtwo( _TSCP( 8 ), X1 ); L3578: INITIALIZEVAR( t3575, ADR( sceval_var0x_v ), X2 ); X1 = sceval_sizeof_2dtscp_v; if ( BITAND( BITOR( _S2CINT( _TSCP( 12 ) ), _S2CINT( X1 ) ), 3 ) ) goto L3581; X2 = _TSCP( ITIMES( FIXED_C( _TSCP( 12 ) ), _S2CINT( X1 ) ) ); goto L3582; L3581: X2 = scrt2__2a_2dtwo( _TSCP( 12 ), X1 ); L3582: INITIALIZEVAR( t3579, ADR( sceval_var1x_v ), X2 ); X1 = sceval_sizeof_2dtscp_v; if ( BITAND( BITOR( _S2CINT( _TSCP( 16 ) ), _S2CINT( X1 ) ), 3 ) ) goto L3585; X2 = _TSCP( ITIMES( FIXED_C( _TSCP( 16 ) ), _S2CINT( X1 ) ) ); goto L3586; L3585: X2 = scrt2__2a_2dtwo( _TSCP( 16 ), X1 ); L3586: INITIALIZEVAR( t3583, ADR( sceval_var2x_v ), X2 ); INITIALIZEVAR( t3587, ADR( sceval_compile_v ), MAKEPROCEDURE( 2, 0, sceval_compile, EMPTYLIST ) ); INITIALIZEVAR( t3728, ADR( sceval_compile_2derror_v ), FALSEVALUE ); INITIALIZEVAR( t3729, ADR( sceval_compile_2dlist_v ), MAKEPROCEDURE( 2, 0, sceval_compile_2dlist, EMPTYLIST ) ); INITIALIZEVAR( t3746, ADR( sceval_eval_v ), MAKEPROCEDURE( 1, 1, sceval_eval, EMPTYLIST ) ); INITIALIZEVAR( t3792, ADR( sceval_exec_v ), MAKEPROCEDURE( 2, 0, sceval_exec, EMPTYLIST ) ); INITIALIZEVAR( t4014, ADR( sceval_interpreted_2dproc_v ), sceval_eval( c3316, EMPTYLIST ) ); INITIALIZEVAR( t4015, ADR( sceval_exec_2dlambda_v ), MAKEPROCEDURE( 2, 0, sceval_exec_2dlambda, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/sceval.sc000066400000000000000000000235431203736146400163670ustar00rootroot00000000000000;;; This module implements a Scheme evaluator. ;;; ;;; Initialization of this module will assure that all modules in the ;;; "standard" library are initialized. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module sceval (top-level EVAL OPTIMIZE-EVAL) (with scexpand scexpnd1 scexpnd2 scrt1 scrt2 scrt3 scrt4 scrt5 scrt6 scrt7 scrtuser)) (include "repdef.sc") ;;; Optimization of eval is controlled by the following procedure. Any of ;;; the following options may be specified: ;;; ;;; CALL: optimize calls to currently defined top-level procedures that ;;; are not interpreted. ;;; ;;; REWRITE: rewrite calls to top-level procedures that take variable ;;; numbers of arguments. This option will cause some breakpoints to be ;;; missed. (define OPTIMIZE-OPTIONS '()) (define (OPTIMIZE-EVAL . options) (if (or (equal? options '()) (equal? options '(call)) (equal? options '(rewrite)) (equal? options '(call rewrite)) (equal? options '(rewrite call))) (set! optimize-options options) (error 'OPTIMIZE-EVAL "Illegal OPTIMIZATION OPTION(S): ~s" options))) ;;; The following a-list is used to turn a procedure call with a given number ;;; of arguments into the actual procedure to be used. (define TOP-LEVEL-REWRITE `(((list 1) sceval_list1) ((list 2) sceval_list2) ((list 3) sceval_list3) ((append 2) scrt1_append-two) ((= 2) scrt2_=-two) ((< 2) scrt2_<-two) ((> 2) scrt2_>-two) ((<= 2) scrt2_<=-two) ((>= 2) scrt2_>=-two) ((max 2) scrt2_max-two) ((min 2) scrt2_min-two) ((+ 2) scrt2_+-two) ((* 2) scrt2_*-two) ((- 1) sceval_negate) ((- 2) scrt2_--two) ((/ 1) sceval_/1) ((/ 2) scrt2_/-two))) (define (LIST1 x) (list x)) (define (LIST2 x y) (list x y)) (define (LIST3 x y z) (list x y z)) (define (NEGATE x) (- x)) (define (/1 x) (/ 1 x)) ;;; Structure offsets for Scheme data structures. (define SIZEOF-TSCP ((lap () (C_FIXED (SIZEOF TSCP))))) (define CODEX sizeof-tscp) (define CLOSUREX (* 2 sizeof-tscp)) (define VAR0X (* 2 sizeof-tscp)) (define VAR1X (* 3 sizeof-tscp)) (define VAR2X (* 4 sizeof-tscp)) ;;; A Scheme expression is compiled into a form for efficient interpretation ;;; by the following procedure. (define (COMPILE exp env) (cond ((symbol? exp) exp) ((pair? exp) (case (car exp) ((quote) exp) ((if) `(if ,(compile (cadr exp) env) ,(compile (caddr exp) env) ,(compile (cadddr exp) env))) ((set!) (let ((var (cadr exp))) (if (assq var env) `(set! ,(cadr exp) ,(compile (caddr exp) env)) (compile `(set-top-level-value! (quote ,(cadr exp)) ,(caddr exp)) env)))) ((begin) (if (eq? (length exp) 2) (compile (cadr exp) env) `(begin ,@(compile-list (cdr exp) env)))) ((lambda) (let ((env (let loop ((env env) (vars (cadr exp))) (cond ((null? vars) env) ((symbol? vars) (cons (list vars) env)) (else (loop (cons (list (car vars)) env) (cdr vars))))))) `(lambda ,(cadr exp) ,@(compile-list (cddr exp) env)))) (else (let* ((proc (car exp)) (global (and (symbol? proc) (not (assq proc env)))) (global-value (and global (top-level-value proc))) (rewrite (and global (assoc (list proc (- (length exp) 1)) top-level-rewrite)))) (cond ((and rewrite (memq 'rewrite optimize-options)) `(,@(if (memq 'call optimize-options) (list (- (length exp) 1)) '()) ,(cadr rewrite) ,@(compile-list (cdr exp) env))) ((and global (memq 'call optimize-options) (procedure? global-value) (not (eq? (scheme-tscp-ref global-value codex) (scheme-tscp-ref interpreted-proc codex))) (<= 2 (length exp) 4)) `(,(- (length exp) 1) ,proc ,@(compile-list (cdr exp) env))) (else (compile-list exp env))))))) ((or (number? exp) (string? exp) (char? exp) (boolean? exp)) exp) ((%record? exp) (compile `((%record-lookup-method ',exp '%to-eval) ',exp) env)) (else (set! compile-error exp) #t))) (define COMPILE-ERROR #f) (define (COMPILE-LIST exp env) (map (lambda (x) (compile x env)) exp)) ;;; The following definitions are inlined and unchecked for use within the ;;; evaluator for interpreted code. (define-in-line (SCHEME-TSCP-REF struct x) ((lap (struct x) (MTSCP (T_U struct) (FIXED_C x))) struct x)) (define-in-line (TOP-LEVEL-VALUE symbol) ((lap (symbol) (SYMBOL_VALUE symbol)) symbol)) (define-in-line (CAR x) ((lap (x) (PAIR_CAR x)) x)) (define-in-line (CDR x) ((lap (x) (PAIR_CDR x)) x)) (define-in-line (CADR x) ((lap (x) (PAIR_CAR (PAIR_CDR x))) x)) (define-in-line (CADDR x) ((lap (x) (PAIR_CAR (PAIR_CDR (PAIR_CDR x)))) x)) (define-in-line (CADDDR x) ((lap (x) (PAIR_CAR (PAIR_CDR (PAIR_CDR (PAIR_CDR x))))) x)) (define-in-line (CADDDDR x) ((lap (x) (PAIR_CAR (PAIR_CDR (PAIR_CDR (PAIR_CDR (PAIR_CDR x)))))) x)) (define-in-line (ASSQ x y) (let loop ((x x) (y y)) (if y (let ((cary (car y))) (if (eq? x (car cary)) cary (loop x (cdr y)))) #f))) ;;; Once the Scheme expression has been compiled, it is interpreted by the ;;; following procedure. (define-in-line (EXEC-ANY exp env) (cond ((pair? exp) (exec exp env)) ((symbol? exp) (let loop ((y env)) (if (null? y) (let ((value (top-level-value exp))) (if (eq? value $_undefined) (error exp "Top-level symbol is undefined") value)) (if (eq? exp (car (car y))) (cdr (car y)) (loop (cdr y)))))) (else exp))) ;;; The Scheme interpreter is invoked by calling the following procedure. (define (EVAL form . env-list) (set! compile-error #f) (let* ((env (if (pair? env-list) (let loop ((x (car env-list))) (cond ((and (pair? x) (pair? (car x))) (loop (cdr x))) ((null? x) (car env-list)) (else (error 'EVAL "Environment is not an A-LIST: ~s" (car env-list))))) '())) (comp-form (compile (if (and (list? form) (not (null? form)) (equal? (car form) "noexpand")) (cadr form) (expand form)) env))) (if (not (eq? compile-error #f)) (error 'EVAL "Argument contains an item that is not self-evaluating: ~s" compile-error) (exec-any comp-form env)))) ;;; Return a list of evaluated objects. (define-in-line (EXEC-LIST exps env) (let loop ((exps exps) (env env)) (if (pair? exps) (cons (exec-any (car exps) env) (loop (cdr exps) env)) '()))) ;;; Bind a list of values and return the new environment. (define-in-line (NEW-ENV idl vals env) (let loop ((idl idl) (vals vals) (env env)) (cond ((null? idl) (if vals (error 'NEW-ENV "Too many arguments to function")) env) ((symbol? idl) (cons (cons idl vals) env)) ((null? vals) (error 'NEW-ENV "Too few arguments to function")) (else (cons (cons (car idl) (car vals)) (loop (cdr idl) (cdr vals) env)))))) ;;; Evaluate a list of items, bind the values and return the new environment. (define-in-line (NEW-ENV-EXEC idl exps old-env env) (let loop ((idl idl) (exps exps) (env env)) (cond ((null? idl) (if exps (error 'NEW-ENV "Too many arguments to function")) env) ((symbol? idl) (cons (cons idl (exec-list exps old-env)) env)) ((null? exps) (error 'NEW-ENV "Too few arguments to function")) (else (loop (cdr idl) (cdr exps) (cons (cons (car idl) (exec-any (car exps) old-env)) env)))))) ;;; Interpret items represented by pairs. (define (EXEC exp env) ((lap (x y) (LOOPSTACKTRACE x y)) exp env) (case (car exp) ((if) (if (exec-any (cadr exp) env) (exec-any (caddr exp) env) (exec-any (cadddr exp) env))) ((set!) (set-cdr! (assq (cadr exp) env) (exec-any (caddr exp) env))) ((quote) (cadr exp)) ((lambda) (exec-lambda exp env)) ((begin) (do ((exps (cdr exp) (cdr exps))) ((null? (cdr exps)) (exec-any (car exps) env)) (exec-any (car exps) env))) (else (let ((function (exec-any (car exp) env))) (cond ((not (procedure? function)) (error 'exec "Argument value is not a function: ~s" (car exp))) ((eq? (scheme-tscp-ref function codex) (scheme-tscp-ref interpreted-proc codex)) (let ((closure (scheme-tscp-ref function closurex))) (exec-any (scheme-tscp-ref closure var0x) (new-env-exec (scheme-tscp-ref closure var2x) (cdr exp) env (scheme-tscp-ref closure var1x))))) (else (apply function (exec-list (cdr exp) env)))))))) (define INTERPRETED-PROC (eval '(lambda (x) x))) (define (EXEC-LAMBDA exp env) (let ((vars (cadr exp)) (body (cons 'begin (cddr exp)))) (lambda vals (exec-any body (new-env vars vals env))))) scheme2c-2012.10.14/scrt/scexpand.c000066400000000000000000000257311203736146400165350ustar00rootroot00000000000000 /* SCHEME->C */ #include void scexpand__init(); DEFSTATICTSCP( c2229 ); DEFCSTRING( t2300, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2214 ); DEFSTATICTSCP( c2213 ); static void init_constants() { c2229 = STRINGTOSYMBOL( CSTRING_TSCP( "*EXPANDER*" ) ); CONSTANTEXP( ADR( c2229 ) ); c2214 = CSTRING_TSCP( t2300 ); CONSTANTEXP( ADR( c2214 ) ); c2213 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2213 ) ); } DEFTSCP( scexpand_expand_v ); DEFCSTRING( t2301, "EXPAND" ); EXTERNTSCPP( scexpand_initial_2dexpander, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scexpand_initial_2dexpander_v ); TSCP scexpand_expand( x2131 ) TSCP x2131; { PUSHSTACKTRACE( t2301 ); POPSTACKTRACE( scexpand_initial_2dexpander( x2131, scexpand_initial_2dexpander_v ) ); } DEFTSCP( scexpand_initial_2dexpander_v ); DEFCSTRING( t2303, "INITIAL-EXPANDER" ); EXTERNTSCPP( scexpand_xpander_2a_1344b3ce, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scexpand_xpander_2a_1344b3ce_v ); EXTERNTSCPP( scexpand_expander_3f, XAL1( TSCP ) ); EXTERNTSCP( scexpand_expander_3f_v ); EXTERNTSCPP( scexpand_expander, XAL1( TSCP ) ); EXTERNTSCP( scexpand_expander_v ); EXTERNTSCPP( scexpand_xpander_2a_c7c0f66b, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scexpand_xpander_2a_c7c0f66b_v ); TSCP scexpand_l2155( x2156, e2157, c2313 ) TSCP x2156, e2157, c2313; { PUSHSTACKTRACE( "scexpand_l2155 [inside INITIAL-EXPANDER]" ); POPSTACKTRACE( x2156 ); } TSCP scexpand_initial_2dexpander( x2134, e2135 ) TSCP x2134, e2135; { TSCP X3, X2, X1; PUSHSTACKTRACE( t2303 ); if ( NOT( AND( EQ( TSCPTAG( x2134 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2134 ), SYMBOLTAG ) ) ) ) goto L2305; X1 = scexpand_xpander_2a_1344b3ce_v; goto L2308; L2305: if ( NEQ( TSCPTAG( x2134 ), PAIRTAG ) ) goto L2307; X3 = PAIR_CAR( x2134 ); X2 = scexpand_expander_3f( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), PROCEDURETAG ) ) ) ) goto L2309; X2 = PAIR_CAR( x2134 ); X1 = scexpand_expander( X2 ); goto L2308; L2309: X1 = scexpand_xpander_2a_c7c0f66b_v; goto L2308; L2307: X1 = MAKEPROCEDURE( 2, 0, scexpand_l2155, EMPTYLIST ); L2308: X2 = X1; X2 = UNKNOWNCALL( X2, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( x2134, e2135, PROCEDURE_CLOSURE( X2 ) ) ); } DEFTSCP( scexpand_expand_2donce_v ); DEFCSTRING( t2316, "EXPAND-ONCE" ); TSCP scexpand_l2162( x2163, e2164, c2318 ) TSCP x2163, e2164, c2318; { PUSHSTACKTRACE( "scexpand_l2162 [inside EXPAND-ONCE]" ); POPSTACKTRACE( x2163 ); } TSCP scexpand_expand_2donce( x2161 ) TSCP x2161; { TSCP X1; PUSHSTACKTRACE( t2316 ); X1 = MAKEPROCEDURE( 2, 0, scexpand_l2162, EMPTYLIST ); POPSTACKTRACE( scexpand_initial_2dexpander( x2161, X1 ) ); } DEFTSCP( scexpand_xpander_2a_1344b3ce_v ); DEFCSTRING( t2320, "*IDENTIFIER-EXPANDER*" ); TSCP scexpand_xpander_2a_1344b3ce( x2166, e2167 ) TSCP x2166, e2167; { TSCP X1; PUSHSTACKTRACE( t2320 ); X1 = scexpand_expander( x2166 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L2323; POPSTACKTRACE( PAIR_CAR( X1 ) ); L2323: POPSTACKTRACE( x2166 ); } DEFTSCP( scexpand_xpander_2a_c7c0f66b_v ); DEFCSTRING( t2326, "*APPLICATION-EXPANDER*" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP scexpand_xpander_2a_c7c0f66b( x2177, e2178 ) TSCP x2177, e2178; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2326 ); X1 = x2177; X2 = EMPTYLIST; X3 = EMPTYLIST; L2329: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L2330; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L2333; scrt1__24__car_2derror( X1 ); L2333: X7 = PAIR_CAR( X1 ); X6 = e2178; X6 = UNKNOWNCALL( X6, 2 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( X7, e2178, PROCEDURE_CLOSURE( X6 ) ); X4 = sc_cons( X5, EMPTYLIST ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L2336; X5 = PAIR_CDR( X1 ); X3 = X4; X2 = X4; X1 = X5; GOBACK( L2329 ); L2336: X5 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2341; scdebug_error( c2213, c2214, CONS( X3, EMPTYLIST ) ); L2341: X3 = SETGEN( PAIR_CDR( X3 ), X4 ); X1 = X5; GOBACK( L2329 ); L2330: POPSTACKTRACE( X2 ); } DEFTSCP( scexpand_install_2dexpander_v ); DEFCSTRING( t2343, "INSTALL-EXPANDER" ); EXTERNTSCPP( scrt2_putprop, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt2_putprop_v ); TSCP scexpand_install_2dexpander( k2227, f2228 ) TSCP k2227, f2228; { PUSHSTACKTRACE( t2343 ); scrt2_putprop( k2227, c2229, f2228 ); POPSTACKTRACE( k2227 ); } DEFTSCP( scexpand_expander_3f_v ); DEFCSTRING( t2345, "EXPANDER?" ); EXTERNTSCPP( scrt2_getprop, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_getprop_v ); TSCP scexpand_expander_3f( x2231 ) TSCP x2231; { PUSHSTACKTRACE( t2345 ); if ( NOT( AND( EQ( TSCPTAG( x2231 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2231 ), SYMBOLTAG ) ) ) ) goto L2347; POPSTACKTRACE( scrt2_getprop( x2231, c2229 ) ); L2347: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scexpand_expander_v ); DEFCSTRING( t2349, "EXPANDER" ); TSCP scexpand_expander( x2239 ) TSCP x2239; { PUSHSTACKTRACE( t2349 ); POPSTACKTRACE( scrt2_getprop( x2239, c2229 ) ); } DEFTSCP( scexpand_islist_v ); DEFCSTRING( t2351, "ISLIST" ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( scrt2__3e_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_3d_2dtwo_v ); EXTERNTSCPP( scrt2__3c_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_3d_2dtwo_v ); TSCP scexpand_islist( l2241, m2242, m2243 ) TSCP l2241, m2242, m2243; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t2351 ); X1 = _TSCP( 0 ); X2 = l2241; L2354: if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2355; if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2357; X3 = _TSCP( IPLUS( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2358; L2357: X3 = scrt2__2b_2dtwo( X1, _TSCP( 4 ) ); L2358: X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L2354 ); L2355: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L2360; if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( m2242 ) ), 3 ) ) goto L2362; X3 = BOOLEAN( GTE( _S2CINT( X1 ), _S2CINT( m2242 ) ) ); goto L2363; L2362: X3 = scrt2__3e_3d_2dtwo( X1, m2242 ); L2363: if ( FALSE( X3 ) ) goto L2365; if ( EQ( _S2CUINT( m2243 ), _S2CUINT( EMPTYLIST ) ) ) goto L2367; if ( EQ( TSCPTAG( m2243 ), PAIRTAG ) ) goto L2370; scrt1__24__car_2derror( m2243 ); L2370: X4 = PAIR_CAR( m2243 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X4 ) ), 3 ) ) goto L2373; POPSTACKTRACE( BOOLEAN( LTE( _S2CINT( X1 ), _S2CINT( X4 ) ) ) ); L2373: POPSTACKTRACE( scrt2__3c_3d_2dtwo( X1, X4 ) ); L2367: POPSTACKTRACE( TRUEVALUE ); L2365: POPSTACKTRACE( X3 ); L2360: POPSTACKTRACE( FALSEVALUE ); } void scrt2__init(); void scdebug__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt2__init(); scdebug__init(); scrt1__init(); MAXDISPLAY( 0 ); } void scexpand__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scexpand SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2301, ADR( scexpand_expand_v ), MAKEPROCEDURE( 1, 0, scexpand_expand, EMPTYLIST ) ); INITIALIZEVAR( t2303, ADR( scexpand_initial_2dexpander_v ), MAKEPROCEDURE( 2, 0, scexpand_initial_2dexpander, EMPTYLIST ) ); INITIALIZEVAR( t2316, ADR( scexpand_expand_2donce_v ), MAKEPROCEDURE( 1, 0, scexpand_expand_2donce, EMPTYLIST ) ); INITIALIZEVAR( t2320, ADR( scexpand_xpander_2a_1344b3ce_v ), MAKEPROCEDURE( 2, 0, scexpand_xpander_2a_1344b3ce, EMPTYLIST ) ); INITIALIZEVAR( t2326, ADR( scexpand_xpander_2a_c7c0f66b_v ), MAKEPROCEDURE( 2, 0, scexpand_xpander_2a_c7c0f66b, EMPTYLIST ) ); INITIALIZEVAR( t2343, ADR( scexpand_install_2dexpander_v ), MAKEPROCEDURE( 2, 0, scexpand_install_2dexpander, EMPTYLIST ) ); INITIALIZEVAR( t2345, ADR( scexpand_expander_3f_v ), MAKEPROCEDURE( 1, 0, scexpand_expander_3f, EMPTYLIST ) ); INITIALIZEVAR( t2349, ADR( scexpand_expander_v ), MAKEPROCEDURE( 1, 0, scexpand_expander, EMPTYLIST ) ); INITIALIZEVAR( t2351, ADR( scexpand_islist_v ), MAKEPROCEDURE( 2, 1, scexpand_islist, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/scexpand.sc000066400000000000000000000047031203736146400167140ustar00rootroot00000000000000;;; Macro expansion is done by this module. It is based upon the ideas in ;;; "Expansion-Passing Style: Beyond Conventional Macros", 1986 ACM Conference ;;; on Lisp and Functional Programming. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scexpand) (include "repdef.sc") (define (EXPAND x) (initial-expander x initial-expander)) (define (INITIAL-EXPANDER x e) (let ((e1 (cond ((symbol? x) *identifier-expander*) ((not (pair? x)) (lambda (x e) x)) ((procedure? (expander? (car x))) (expander (car x))) (else *application-expander*)))) (e1 x e))) (define (EXPAND-ONCE x) (initial-expander x (lambda (x e) x))) (define (*IDENTIFIER-EXPANDER* x e) (let ((constant (expander x))) (if (pair? constant) (car constant) x))) (define (*APPLICATION-EXPANDER* x e) (map (lambda (x) (e x e)) x)) (define (INSTALL-EXPANDER keyword function) (putprop keyword '*expander* function) keyword) (define (EXPANDER? x) (and (symbol? x) (getprop x '*expander*))) (define (EXPANDER x) (getprop x '*expander*)) ;;; The following function tests an expression to verify that it is a list ;;; of a certain minimum length. Optionally a maximum length will also be ;;; checked. (define (ISLIST l min . max) (do ((len 0 (+ len 1)) (l l (cdr l))) ((not (pair? l)) (and (null? l) (>= len min) (or (null? max) (<= len (car max))))))) scheme2c-2012.10.14/scrt/scexpnd1.c000066400000000000000000001732041203736146400164540ustar00rootroot00000000000000 /* SCHEME->C */ #include void scexpnd1__init(); DEFSTATICTSCP( c3057 ); DEFSTATICTSCP( c3056 ); DEFSTATICTSCP( c3029 ); DEFSTATICTSCP( c2942 ); DEFSTATICTSCP( c2941 ); DEFCSTRING( t3156, "key" ); DEFSTATICTSCP( c2890 ); DEFSTATICTSCP( c2851 ); DEFCSTRING( t3157, "Illegal form:" ); DEFSTATICTSCP( c2819 ); DEFSTATICTSCP( c2818 ); DEFCSTRING( t3158, "Illegal form ~s:" ); DEFSTATICTSCP( c2791 ); DEFSTATICTSCP( c2790 ); DEFSTATICTSCP( c2785 ); DEFSTATICTSCP( c2784 ); DEFSTATICTSCP( c2783 ); DEFSTATICTSCP( c2778 ); DEFSTATICTSCP( c2777 ); DEFSTATICTSCP( c2772 ); DEFSTATICTSCP( c2763 ); DEFSTATICTSCP( c2745 ); DEFSTATICTSCP( c2719 ); DEFSTATICTSCP( c2525 ); DEFSTATICTSCP( c2516 ); DEFCSTRING( t3159, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2458 ); DEFSTATICTSCP( c2457 ); DEFSTATICTSCP( c2396 ); DEFSTATICTSCP( c2385 ); DEFSTATICTSCP( c2366 ); DEFSTATICTSCP( c2360 ); DEFSTATICTSCP( c2354 ); DEFSTATICTSCP( c2311 ); DEFSTATICTSCP( c2270 ); DEFSTATICTSCP( c2259 ); DEFSTATICTSCP( c2258 ); DEFSTATICTSCP( c2257 ); DEFSTATICTSCP( c2256 ); DEFSTATICTSCP( c2226 ); DEFSTATICTSCP( c2205 ); DEFSTATICTSCP( c2162 ); DEFCSTRING( t3160, "***** ~s is redefined~%" ); DEFSTATICTSCP( c2161 ); DEFSTATICTSCP( c2148 ); DEFSTATICTSCP( c2137 ); DEFSTATICTSCP( c2136 ); DEFCSTRING( t3161, "Illegal form: ~s" ); DEFSTATICTSCP( c2135 ); DEFSTATICTSCP( c2130 ); static void init_constants() { c3057 = STRINGTOSYMBOL( CSTRING_TSCP( "NOT" ) ); CONSTANTEXP( ADR( c3057 ) ); c3056 = STRINGTOSYMBOL( CSTRING_TSCP( "UNLESS" ) ); CONSTANTEXP( ADR( c3056 ) ); c3029 = STRINGTOSYMBOL( CSTRING_TSCP( "WHEN" ) ); CONSTANTEXP( ADR( c3029 ) ); c2942 = STRINGTOSYMBOL( CSTRING_TSCP( "AND" ) ); CONSTANTEXP( ADR( c2942 ) ); c2941 = STRINGTOSYMBOL( CSTRING_TSCP( "THUNK" ) ); CONSTANTEXP( ADR( c2941 ) ); c2890 = CSTRING_TSCP( t3156 ); CONSTANTEXP( ADR( c2890 ) ); c2851 = STRINGTOSYMBOL( CSTRING_TSCP( "MEMV" ) ); CONSTANTEXP( ADR( c2851 ) ); c2819 = CSTRING_TSCP( t3157 ); CONSTANTEXP( ADR( c2819 ) ); c2818 = STRINGTOSYMBOL( CSTRING_TSCP( "CASE" ) ); CONSTANTEXP( ADR( c2818 ) ); c2791 = CSTRING_TSCP( t3158 ); CONSTANTEXP( ADR( c2791 ) ); c2790 = STRINGTOSYMBOL( CSTRING_TSCP( "COND-CLAUSE" ) ); CONSTANTEXP( ADR( c2790 ) ); c2785 = STRINGTOSYMBOL( CSTRING_TSCP( "OR" ) ); CONSTANTEXP( ADR( c2785 ) ); c2784 = STRINGTOSYMBOL( CSTRING_TSCP( "THUNK3" ) ); CONSTANTEXP( ADR( c2784 ) ); c2783 = STRINGTOSYMBOL( CSTRING_TSCP( "THUNK2" ) ); CONSTANTEXP( ADR( c2783 ) ); c2778 = STRINGTOSYMBOL( CSTRING_TSCP( "TEST-RESULT" ) ); CONSTANTEXP( ADR( c2778 ) ); c2777 = STRINGTOSYMBOL( CSTRING_TSCP( "LET" ) ); CONSTANTEXP( ADR( c2777 ) ); c2772 = STRINGTOSYMBOL( CSTRING_TSCP( "COND" ) ); CONSTANTEXP( ADR( c2772 ) ); c2763 = STRINGTOSYMBOL( CSTRING_TSCP( "ELSE" ) ); CONSTANTEXP( ADR( c2763 ) ); c2745 = STRINGTOSYMBOL( CSTRING_TSCP( "=>" ) ); CONSTANTEXP( ADR( c2745 ) ); c2719 = EMPTYLIST; c2719 = CONS( c2763, c2719 ); CONSTANTEXP( ADR( c2719 ) ); c2525 = STRINGTOSYMBOL( CSTRING_TSCP( "IF" ) ); CONSTANTEXP( ADR( c2525 ) ); c2516 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2516 ) ); c2458 = CSTRING_TSCP( t3159 ); CONSTANTEXP( ADR( c2458 ) ); c2457 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2457 ) ); c2396 = STRINGTOSYMBOL( CSTRING_TSCP( "BEGIN" ) ); CONSTANTEXP( ADR( c2396 ) ); c2385 = STRINGTOSYMBOL( CSTRING_TSCP( "EVAL" ) ); CONSTANTEXP( ADR( c2385 ) ); c2366 = STRINGTOSYMBOL( CSTRING_TSCP( "EVAL-WHEN" ) ); CONSTANTEXP( ADR( c2366 ) ); c2360 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-C-EXTERNAL" ) ); CONSTANTEXP( ADR( c2360 ) ); c2354 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-EXTERNAL" ) ); CONSTANTEXP( ADR( c2354 ) ); c2311 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-CONSTANT" ) ); CONSTANTEXP( ADR( c2311 ) ); c2270 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-MACRO" ) ); CONSTANTEXP( ADR( c2270 ) ); c2259 = STRINGTOSYMBOL( CSTRING_TSCP( "CDR" ) ); CONSTANTEXP( ADR( c2259 ) ); c2258 = STRINGTOSYMBOL( CSTRING_TSCP( "CONS" ) ); CONSTANTEXP( ADR( c2258 ) ); c2257 = STRINGTOSYMBOL( CSTRING_TSCP( "E" ) ); CONSTANTEXP( ADR( c2257 ) ); c2256 = STRINGTOSYMBOL( CSTRING_TSCP( "X" ) ); CONSTANTEXP( ADR( c2256 ) ); c2226 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-IN-LINE" ) ); CONSTANTEXP( ADR( c2226 ) ); c2205 = STRINGTOSYMBOL( CSTRING_TSCP( "DO-DEFINE" ) ); CONSTANTEXP( ADR( c2205 ) ); c2162 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE" ) ); CONSTANTEXP( ADR( c2162 ) ); c2161 = CSTRING_TSCP( t3160 ); CONSTANTEXP( ADR( c2161 ) ); c2148 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2148 ) ); c2137 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2137 ) ); c2136 = STRINGTOSYMBOL( CSTRING_TSCP( "MAKE-PROMISE" ) ); CONSTANTEXP( ADR( c2136 ) ); c2135 = CSTRING_TSCP( t3161 ); CONSTANTEXP( ADR( c2135 ) ); c2130 = STRINGTOSYMBOL( CSTRING_TSCP( "DELAY" ) ); CONSTANTEXP( ADR( c2130 ) ); } EXTERNTSCPP( scexpand_install_2dexpander, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scexpand_install_2dexpander_v ); EXTERNTSCPP( scexpand_islist, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scexpand_islist_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP scexpnd1_l2131( x2132, e2133 ) TSCP x2132, e2133; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2131 [inside TOP-LEVEL]" ); if ( FALSE( scexpand_islist( x2132, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L3163; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( x2132 ), PAIRTAG ) ) goto L3166; scrt1__24__cdr_2derror( x2132 ); L3166: X5 = PAIR_CDR( x2132 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3169; scrt1__24__car_2derror( X5 ); L3169: X4 = CONS( PAIR_CAR( X5 ), X4 ); X2 = scrt1_cons_2a( c2136, CONS( scrt1_cons_2a( c2137, CONS( EMPTYLIST, X4 ) ), X3 ) ); X1 = e2133; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2133, PROCEDURE_CLOSURE( X1 ) ) ); L3163: POPSTACKTRACE( scdebug_error( c2130, c2135, CONS( x2132, EMPTYLIST ) ) ); } TSCP scexpnd1_l2149( x2150, e2151 ) TSCP x2150, e2151; { PUSHSTACKTRACE( "scexpnd1_l2149 [inside TOP-LEVEL]" ); if ( TRUE( scexpand_islist( x2150, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L3172; POPSTACKTRACE( scdebug_error( c2148, c2135, CONS( x2150, EMPTYLIST ) ) ); L3172: POPSTACKTRACE( x2150 ); } DEFTSCP( scexpnd1_do_2ddefine_v ); DEFCSTRING( t3174, "DO-DEFINE" ); EXTERNTSCPP( scrt2_top_2dlevel_2dvalue, XAL1( TSCP ) ); EXTERNTSCP( scrt2_top_2dlevel_2dvalue_v ); EXTERNTSCPP( scrt2_2dvalue_21_c9d2a496, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_2dvalue_21_c9d2a496_v ); EXTERNTSCP( sc_undefined ); EXTERNTSCPP( scrt6_display, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_display_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); TSCP scexpnd1_do_2ddefine( s2154, v2155 ) TSCP s2154, v2155; { TSCP X2, X1; PUSHSTACKTRACE( t3174 ); X1 = scrt2_top_2dlevel_2dvalue( s2154 ); scrt2_2dvalue_21_c9d2a496( s2154, v2155 ); if ( EQ( _S2CUINT( X1 ), _S2CUINT( sc_undefined ) ) ) goto L3177; X2 = scrt6_format( c2161, CONS( s2154, EMPTYLIST ) ); scrt6_display( X2, EMPTYLIST ); L3177: POPSTACKTRACE( s2154 ); } EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( scrt1_caadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caadr_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_cdadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdadr_v ); TSCP scexpnd1_l2163( x2164, e2165 ) TSCP x2164, e2165; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2163 [inside TOP-LEVEL]" ); X1 = scexpand_islist( x2164, _TSCP( 12 ), CONS( _TSCP( 12 ), EMPTYLIST ) ); if ( FALSE( X1 ) ) goto L3196; if ( EQ( TSCPTAG( x2164 ), PAIRTAG ) ) goto L3187; scrt1__24__cdr_2derror( x2164 ); L3187: X3 = PAIR_CDR( x2164 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3190; scrt1__24__car_2derror( X3 ); L3190: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3196; X2 = CONS( EMPTYLIST, EMPTYLIST ); X4 = scrt1_caddr( x2164 ); X3 = e2165; X3 = UNKNOWNCALL( X3, 2 ); X2 = CONS( VIA( PROCEDURE_CODE( X3 ) )( X4, e2165, PROCEDURE_CLOSURE( X3 ) ), X2 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = PAIR_CDR( x2164 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3194; scrt1__24__car_2derror( X4 ); L3194: POPSTACKTRACE( scrt1_cons_2a( c2205, CONS( scrt1_cons_2a( c2148, CONS( PAIR_CAR( X4 ), X3 ) ), X2 ) ) ); L3196: X1 = scexpand_islist( x2164, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X1 ) ) goto L3217; if ( EQ( TSCPTAG( x2164 ), PAIRTAG ) ) goto L3205; scrt1__24__cdr_2derror( x2164 ); L3205: X3 = PAIR_CDR( x2164 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3208; scrt1__24__car_2derror( X3 ); L3208: X2 = PAIR_CAR( X3 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3217; X2 = scrt1_caadr( x2164 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3217; X2 = CONS( EMPTYLIST, EMPTYLIST ); X7 = PAIR_CDR( x2164 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3214; scrt1__24__cdr_2derror( X7 ); L3214: X6 = PAIR_CDR( X7 ); X7 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_append_2dtwo( X6, X7 ), EMPTYLIST ); X4 = scrt1_cons_2a( c2137, CONS( scrt1_cdadr( x2164 ), X5 ) ); X3 = e2165; X3 = UNKNOWNCALL( X3, 2 ); X2 = CONS( VIA( PROCEDURE_CODE( X3 ) )( X4, e2165, PROCEDURE_CLOSURE( X3 ) ), X2 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2205, CONS( scrt1_cons_2a( c2148, CONS( scrt1_caadr( x2164 ), X3 ) ), X2 ) ) ); L3217: POPSTACKTRACE( scdebug_error( c2162, c2135, CONS( x2164, EMPTYLIST ) ) ); } EXTERNTSCPP( sceval_eval, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sceval_eval_v ); TSCP scexpnd1_l2227( x2228, e2229 ) TSCP x2228, e2229; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2227 [inside TOP-LEVEL]" ); X1 = scexpand_islist( x2228, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X1 ) ) goto L3240; if ( EQ( TSCPTAG( x2228 ), PAIRTAG ) ) goto L3227; scrt1__24__cdr_2derror( x2228 ); L3227: X3 = PAIR_CDR( x2228 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3230; scrt1__24__car_2derror( X3 ); L3230: X2 = PAIR_CAR( X3 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3240; X2 = scrt1_caadr( x2228 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3240; X2 = scrt1_caadr( x2228 ); X3 = scrt1_cdadr( x2228 ); X5 = PAIR_CDR( x2228 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3236; scrt1__24__cdr_2derror( X5 ); L3236: X4 = PAIR_CDR( X5 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( c2257, X8 ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_cons_2a( c2259, CONS( c2256, X10 ) ), X9 ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X11 = CONS( scrt1_append_2dtwo( X4, X12 ), EMPTYLIST ); X7 = CONS( scrt1_cons_2a( c2257, CONS( scrt1_cons_2a( c2258, CONS( scrt1_cons_2a( c2148, CONS( scrt1_cons_2a( c2137, CONS( X3, X11 ) ), X10 ) ), X9 ) ), X8 ) ), X7 ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2137, CONS( scrt1_cons_2a( c2256, CONS( c2257, X8 ) ), X7 ) ); X5 = sceval_eval( X6, EMPTYLIST ); scexpand_install_2dexpander( X2, X5 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2148, CONS( X2, X5 ) ) ); L3240: POPSTACKTRACE( scdebug_error( c2226, c2135, CONS( x2228, EMPTYLIST ) ) ); } TSCP scexpnd1_l2271( x2272, e2273 ) TSCP x2272, e2273; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2271 [inside TOP-LEVEL]" ); X1 = scexpand_islist( x2272, _TSCP( 12 ), CONS( _TSCP( 12 ), EMPTYLIST ) ); if ( FALSE( X1 ) ) goto L3263; if ( EQ( TSCPTAG( x2272 ), PAIRTAG ) ) goto L3249; scrt1__24__cdr_2derror( x2272 ); L3249: X3 = PAIR_CDR( x2272 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3252; scrt1__24__car_2derror( X3 ); L3252: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3263; X3 = PAIR_CDR( x2272 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3257; scrt1__24__car_2derror( X3 ); L3257: X2 = PAIR_CAR( X3 ); X4 = scrt1_caddr( x2272 ); X3 = sceval_eval( X4, EMPTYLIST ); scexpand_install_2dexpander( X2, X3 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = PAIR_CDR( x2272 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3261; scrt1__24__car_2derror( X3 ); L3261: POPSTACKTRACE( scrt1_cons_2a( c2148, CONS( PAIR_CAR( X3 ), X2 ) ) ); L3263: POPSTACKTRACE( scdebug_error( c2270, c2135, CONS( x2272, EMPTYLIST ) ) ); } EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP scexpnd1_l2312( x2313, e2314 ) TSCP x2313, e2314; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2312 [inside TOP-LEVEL]" ); X1 = scexpand_islist( x2313, _TSCP( 12 ), CONS( _TSCP( 12 ), EMPTYLIST ) ); if ( FALSE( X1 ) ) goto L3287; if ( EQ( TSCPTAG( x2313 ), PAIRTAG ) ) goto L3272; scrt1__24__cdr_2derror( x2313 ); L3272: X3 = PAIR_CDR( x2313 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3275; scrt1__24__car_2derror( X3 ); L3275: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3287; X3 = PAIR_CDR( x2313 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3280; scrt1__24__car_2derror( X3 ); L3280: X2 = PAIR_CAR( X3 ); X6 = scrt1_caddr( x2313 ); X5 = sceval_eval( X6, EMPTYLIST ); X4 = sc_cons( X5, EMPTYLIST ); X3 = X4; scexpand_install_2dexpander( X2, X3 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = PAIR_CDR( x2313 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3285; scrt1__24__car_2derror( X3 ); L3285: POPSTACKTRACE( scrt1_cons_2a( c2148, CONS( PAIR_CAR( X3 ), X2 ) ) ); L3287: POPSTACKTRACE( scdebug_error( c2311, c2135, CONS( x2313, EMPTYLIST ) ) ); } TSCP scexpnd1_l2355( x2356, e2357 ) TSCP x2356, e2357; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2355 [inside TOP-LEVEL]" ); X4 = sc_cons( x2356, EMPTYLIST ); X3 = sc_cons( c2148, X4 ); X2 = X3; X1 = e2357; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2357, PROCEDURE_CLOSURE( X1 ) ) ); } TSCP scexpnd1_l2361( x2362, e2363 ) TSCP x2362, e2363; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2361 [inside TOP-LEVEL]" ); X4 = sc_cons( x2362, EMPTYLIST ); X3 = sc_cons( c2148, X4 ); X2 = X3; X1 = e2363; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2363, PROCEDURE_CLOSURE( X1 ) ) ); } EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); TSCP scexpnd1_l2367( x2368, e2369 ) TSCP x2368, e2369; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2367 [inside TOP-LEVEL]" ); X1 = scexpand_islist( x2368, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X1 ) ) goto L3315; if ( EQ( TSCPTAG( x2368 ), PAIRTAG ) ) goto L3300; scrt1__24__cdr_2derror( x2368 ); L3300: X3 = PAIR_CDR( x2368 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3303; scrt1__24__car_2derror( X3 ); L3303: X2 = PAIR_CAR( X3 ); if ( FALSE( scexpand_islist( X2, _TSCP( 4 ), EMPTYLIST ) ) ) goto L3315; X3 = PAIR_CDR( x2368 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3309; scrt1__24__car_2derror( X3 ); L3309: X2 = PAIR_CAR( X3 ); if ( FALSE( scrt1_memq( c2385, X2 ) ) ) goto L3305; X5 = PAIR_CDR( x2368 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3313; scrt1__24__cdr_2derror( X5 ); L3313: X4 = PAIR_CDR( X5 ); X5 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2396, CONS( scrt1_append_2dtwo( X4, X5 ), EMPTYLIST ) ); X2 = e2369; X2 = UNKNOWNCALL( X2, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( X3, e2369, PROCEDURE_CLOSURE( X2 ) ) ); L3305: POPSTACKTRACE( FALSEVALUE ); L3315: POPSTACKTRACE( scdebug_error( c2366, c2135, CONS( x2368, EMPTYLIST ) ) ); } EXTERNTSCPP( scexpnd1_2dexpander_afd5ebf4, XAL1( TSCP ) ); EXTERNTSCP( scexpnd1_2dexpander_afd5ebf4_v ); EXTERNTSCPP( scexpnd1_lambda_2ddefines, XAL1( TSCP ) ); EXTERNTSCP( scexpnd1_lambda_2ddefines_v ); TSCP scexpnd1_l2407( x2408, e2409 ) TSCP x2408, e2409; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2407 [inside TOP-LEVEL]" ); X1 = scexpnd1_2dexpander_afd5ebf4( e2409 ); if ( FALSE( scexpand_islist( x2408, _TSCP( 12 ), EMPTYLIST ) ) ) goto L3318; if ( EQ( TSCPTAG( x2408 ), PAIRTAG ) ) goto L3321; scrt1__24__cdr_2derror( x2408 ); L3321: X6 = PAIR_CDR( x2408 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3324; scrt1__24__cdr_2derror( X6 ); L3324: X5 = PAIR_CDR( X6 ); X6 = X5; X7 = EMPTYLIST; X8 = EMPTYLIST; L3328: if ( NEQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L3329; X4 = X7; goto L3336; L3329: if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3332; scrt1__24__car_2derror( X6 ); L3332: X12 = PAIR_CAR( X6 ); X11 = X1; X11 = UNKNOWNCALL( X11, 2 ); X10 = VIA( PROCEDURE_CODE( X11 ) )( X12, X1, PROCEDURE_CLOSURE( X11 ) ); X9 = sc_cons( X10, EMPTYLIST ); if ( NEQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L3335; X10 = PAIR_CDR( X6 ); X8 = X9; X7 = X9; X6 = X10; GOBACK( L3328 ); L3335: X10 = PAIR_CDR( X6 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3340; scdebug_error( c2457, c2458, CONS( X8, EMPTYLIST ) ); L3340: X8 = SETGEN( PAIR_CDR( X8 ), X9 ); X6 = X10; GOBACK( L3328 ); L3336: X3 = scexpnd1_lambda_2ddefines( X4 ); X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_append_2dtwo( X3, X4 ), EMPTYLIST ); X3 = PAIR_CDR( x2408 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3344; scrt1__24__car_2derror( X3 ); L3344: POPSTACKTRACE( scrt1_cons_2a( c2137, CONS( PAIR_CAR( X3 ), X2 ) ) ); L3318: POPSTACKTRACE( scdebug_error( c2137, c2135, CONS( x2408, EMPTYLIST ) ) ); } DEFTSCP( scexpnd1_lambda_2ddefines_v ); DEFCSTRING( t3346, "SCEXPND1_LAMBDA-DEFINES" ); EXTERNTSCPP( scrt1_cadadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadadr_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); EXTERNTSCPP( scrt4_vector_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt4_vector_2d_3elist_v ); EXTERNTSCPP( sc_make_2dvector, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dvector_v ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); TSCP scexpnd1_lambda_2ddefines( b2482 ) TSCP b2482; { TSCP X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3346 ); X1 = b2482; X2 = EMPTYLIST; X3 = EMPTYLIST; X4 = EMPTYLIST; L3349: if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3350; X5 = PAIR_CAR( X1 ); X6 = BOOLEAN( NEQ( TSCPTAG( X5 ), PAIRTAG ) ); if ( TRUE( X6 ) ) goto L3358; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3362; scrt1__24__car_2derror( X5 ); L3362: X7 = PAIR_CAR( X5 ); if ( NEQ( _S2CUINT( X7 ), _S2CUINT( c2205 ) ) ) goto L3358; X7 = PAIR_CDR( X1 ); X9 = scrt1_cadadr( X5 ); X8 = sc_cons( X9, X3 ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( scrt1_caddr( X5 ), X10 ); X9 = scrt1_cons_2a( c2516, CONS( scrt1_cadadr( X5 ), X10 ) ); X4 = sc_cons( X9, X4 ); X3 = X8; X1 = X7; GOBACK( L3349 ); L3350: if ( FALSE( X3 ) ) goto L3365; X9 = scrt1_reverse( X4 ); X12 = scrt1_reverse( X2 ); X13 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X11 = scrt1_append_2dtwo( X12, X13 ); X10 = scrt1_cons_2a( X11, EMPTYLIST ); X8 = CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ); X7 = scrt1_cons_2a( c2137, CONS( X3, X8 ) ); X10 = scrt1_length( X3 ); X9 = sc_make_2dvector( X10, CONS( _TSCP( 0 ), EMPTYLIST ) ); X8 = scrt4_vector_2d_3elist( X9 ); X9 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( X7, CONS( scrt1_append_2dtwo( X8, X9 ), EMPTYLIST ) ); POPSTACKTRACE( scrt1_cons_2a( X6, CONS( EMPTYLIST, EMPTYLIST ) ) ); L3365: POPSTACKTRACE( b2482 ); L3358: X6 = PAIR_CDR( X1 ); X7 = sc_cons( X5, X2 ); X2 = X7; X1 = X6; GOBACK( L3349 ); } EXTERNTSCPP( scrt1_cadddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadddr_v ); TSCP scexpnd1_l2526( x2527, e2528 ) TSCP x2527, e2528; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2526 [inside TOP-LEVEL]" ); if ( FALSE( scexpand_islist( x2527, _TSCP( 12 ), CONS( _TSCP( 12 ), EMPTYLIST ) ) ) ) goto L3369; if ( EQ( TSCPTAG( x2527 ), PAIRTAG ) ) goto L3372; scrt1__24__cdr_2derror( x2527 ); L3372: X6 = PAIR_CDR( x2527 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3375; scrt1__24__car_2derror( X6 ); L3375: X5 = PAIR_CAR( X6 ); X4 = e2528; X4 = UNKNOWNCALL( X4, 2 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( X5, e2528, PROCEDURE_CLOSURE( X4 ) ); X7 = scrt1_caddr( x2527 ); X6 = e2528; X6 = UNKNOWNCALL( X6, 2 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( X7, e2528, PROCEDURE_CLOSURE( X6 ) ); X6 = sc_cons( FALSEVALUE, EMPTYLIST ); X4 = sc_cons( X5, X6 ); X2 = sc_cons( X3, X4 ); X1 = sc_cons( c2525, X2 ); POPSTACKTRACE( X1 ); L3369: if ( FALSE( scexpand_islist( x2527, _TSCP( 16 ), CONS( _TSCP( 16 ), EMPTYLIST ) ) ) ) goto L3378; if ( EQ( TSCPTAG( x2527 ), PAIRTAG ) ) goto L3381; scrt1__24__cdr_2derror( x2527 ); L3381: X6 = PAIR_CDR( x2527 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3384; scrt1__24__car_2derror( X6 ); L3384: X5 = PAIR_CAR( X6 ); X4 = e2528; X4 = UNKNOWNCALL( X4, 2 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( X5, e2528, PROCEDURE_CLOSURE( X4 ) ); X7 = scrt1_caddr( x2527 ); X6 = e2528; X6 = UNKNOWNCALL( X6, 2 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( X7, e2528, PROCEDURE_CLOSURE( X6 ) ); X9 = scrt1_cadddr( x2527 ); X8 = e2528; X8 = UNKNOWNCALL( X8, 2 ); X7 = VIA( PROCEDURE_CODE( X8 ) )( X9, e2528, PROCEDURE_CLOSURE( X8 ) ); X6 = sc_cons( X7, EMPTYLIST ); X4 = sc_cons( X5, X6 ); X2 = sc_cons( X3, X4 ); X1 = sc_cons( c2525, X2 ); POPSTACKTRACE( X1 ); L3378: POPSTACKTRACE( scdebug_error( c2525, c2135, CONS( x2527, EMPTYLIST ) ) ); } TSCP scexpnd1_l2554( x2555, e2556 ) TSCP x2555, e2556; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2554 [inside TOP-LEVEL]" ); X1 = scexpand_islist( x2555, _TSCP( 12 ), CONS( _TSCP( 12 ), EMPTYLIST ) ); if ( FALSE( X1 ) ) goto L3404; if ( EQ( TSCPTAG( x2555 ), PAIRTAG ) ) goto L3395; scrt1__24__cdr_2derror( x2555 ); L3395: X3 = PAIR_CDR( x2555 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3398; scrt1__24__car_2derror( X3 ); L3398: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3404; X2 = CONS( EMPTYLIST, EMPTYLIST ); X4 = scrt1_caddr( x2555 ); X3 = e2556; X3 = UNKNOWNCALL( X3, 2 ); X2 = CONS( VIA( PROCEDURE_CODE( X3 ) )( X4, e2556, PROCEDURE_CLOSURE( X3 ) ), X2 ); X3 = PAIR_CDR( x2555 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3402; scrt1__24__car_2derror( X3 ); L3402: POPSTACKTRACE( scrt1_cons_2a( c2516, CONS( PAIR_CAR( X3 ), X2 ) ) ); L3404: POPSTACKTRACE( scdebug_error( c2516, c2135, CONS( x2555, EMPTYLIST ) ) ); } TSCP scexpnd1_l2583( x2584, e2585 ) TSCP x2584, e2585; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2583 [inside TOP-LEVEL]" ); if ( TRUE( scexpand_islist( x2584, _TSCP( 4 ), CONS( _TSCP( 4 ), EMPTYLIST ) ) ) ) goto L3406; if ( FALSE( scexpand_islist( x2584, _TSCP( 8 ), EMPTYLIST ) ) ) goto L3408; if ( EQ( TSCPTAG( x2584 ), PAIRTAG ) ) goto L3411; scrt1__24__cdr_2derror( x2584 ); L3411: X2 = PAIR_CDR( x2584 ); X3 = X2; X4 = EMPTYLIST; X5 = EMPTYLIST; L3415: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3416; X1 = X4; goto L3423; L3416: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3419; scrt1__24__car_2derror( X3 ); L3419: X9 = PAIR_CAR( X3 ); X8 = e2585; X8 = UNKNOWNCALL( X8, 2 ); X7 = VIA( PROCEDURE_CODE( X8 ) )( X9, e2585, PROCEDURE_CLOSURE( X8 ) ); X6 = sc_cons( X7, EMPTYLIST ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3422; X7 = PAIR_CDR( X3 ); X5 = X6; X4 = X6; X3 = X7; GOBACK( L3415 ); L3422: X7 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3427; scdebug_error( c2457, c2458, CONS( X5, EMPTYLIST ) ); L3427: X5 = SETGEN( PAIR_CDR( X5 ), X6 ); X3 = X7; GOBACK( L3415 ); L3423: X2 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2396, CONS( scrt1_append_2dtwo( X1, X2 ), EMPTYLIST ) ) ); L3408: POPSTACKTRACE( scdebug_error( c2396, c2135, CONS( x2584, EMPTYLIST ) ) ); L3406: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scexpnd1_2dexpander_afd5ebf4_v ); DEFCSTRING( t3429, "SCEXPND1_INTERNAL-BEGIN-EXPANDER" ); TSCP scexpnd1_l2636( e2637, e2638, c3431 ) TSCP e2637, e2638, c3431; { TSCP X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scexpnd1_l2636 [inside INTERNAL-BEGIN-EXPANDER]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3431, 0 ); X3 = BOOLEAN( EQ( TSCPTAG( e2637 ), PAIRTAG ) ); if ( FALSE( X3 ) ) goto L3461; if ( EQ( TSCPTAG( e2637 ), PAIRTAG ) ) goto L3440; scrt1__24__car_2derror( e2637 ); L3440: X4 = PAIR_CAR( e2637 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2396 ) ) ) goto L3461; if ( FALSE( scexpand_islist( e2637, _TSCP( 8 ), EMPTYLIST ) ) ) goto L3442; X6 = PAIR_CDR( e2637 ); X7 = X6; X8 = EMPTYLIST; X9 = EMPTYLIST; L3447: if ( NEQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L3448; X5 = X8; goto L3455; L3448: if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3451; scrt1__24__car_2derror( X7 ); L3451: X13 = PAIR_CAR( X7 ); X12 = e2638; X12 = UNKNOWNCALL( X12, 2 ); X11 = VIA( PROCEDURE_CODE( X12 ) )( X13, e2638, PROCEDURE_CLOSURE( X12 ) ); X10 = sc_cons( X11, EMPTYLIST ); if ( NEQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L3454; X11 = PAIR_CDR( X7 ); X9 = X10; X8 = X10; X7 = X11; GOBACK( L3447 ); L3454: X11 = PAIR_CDR( X7 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3459; scdebug_error( c2457, c2458, CONS( X9, EMPTYLIST ) ); L3459: X9 = SETGEN( PAIR_CDR( X9 ), X10 ); X7 = X11; GOBACK( L3447 ); L3455: X4 = scexpnd1_lambda_2ddefines( X5 ); X5 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X2 = scrt1_cons_2a( c2396, CONS( scrt1_append_2dtwo( X4, X5 ), EMPTYLIST ) ); goto L3462; L3442: X2 = scdebug_error( c2396, c2135, CONS( e2637, EMPTYLIST ) ); goto L3462; L3461: X3 = DISPLAY( 0 ); X3 = UNKNOWNCALL( X3, 2 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( e2637, e2638, PROCEDURE_CLOSURE( X3 ) ); L3462: DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } TSCP scexpnd1_2dexpander_afd5ebf4( o2635 ) TSCP o2635; { TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t3429 ); DISPLAY( 0 ) = o2635; SDVAL = MAKEPROCEDURE( 2, 0, scexpnd1_l2636, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } DEFTSCP( scexpnd1_cond_2dmacro_v ); DEFCSTRING( t3463, "SCEXPND1_COND-MACRO" ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); TSCP scexpnd1_cond_2dmacro( e2701 ) TSCP e2701; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3463 ); if ( EQ( TSCPTAG( e2701 ), PAIRTAG ) ) goto L3466; scrt1__24__cdr_2derror( e2701 ); L3466: X3 = PAIR_CDR( e2701 ); if ( FALSE( X3 ) ) goto L3469; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3472; scrt1__24__car_2derror( X3 ); L3472: X2 = PAIR_CAR( X3 ); goto L3470; L3469: X2 = X3; L3470: if ( FALSE( X2 ) ) goto L3475; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3478; scrt1__24__cdr_2derror( X3 ); L3478: X1 = PAIR_CDR( X3 ); goto L3476; L3475: X1 = X2; L3476: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3481; X4 = BOOLEAN( NEQ( TSCPTAG( X2 ), PAIRTAG ) ); if ( TRUE( X4 ) ) goto L3487; if ( TRUE( scrt1_equal_3f( X2, c2719 ) ) ) goto L3487; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3493; scrt1__24__cdr_2derror( X2 ); L3493: X5 = PAIR_CDR( X2 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L3490; X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_cons_2a( c2772, CONS( scrt1_append_2dtwo( X1, X6 ), EMPTYLIST ) ), X5 ); POPSTACKTRACE( scrt1_cons_2a( c2785, CONS( PAIR_CAR( X2 ), X5 ) ) ); L3490: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3497; scrt1__24__cdr_2derror( X2 ); L3497: X7 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3500; scrt1__24__car_2derror( X7 ); L3500: X6 = PAIR_CAR( X7 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2745 ) ) ); if ( FALSE( X5 ) ) goto L3516; X6 = scrt1_length( X2 ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 12 ) ) ), 3 ) ) goto L3508; if ( EQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 12 ) ) ) ) goto L3512; goto L3516; L3508: if ( TRUE( scrt2__3d_2dtwo( X6, _TSCP( 12 ) ) ) ) goto L3512; goto L3516; L3481: POPSTACKTRACE( FALSEVALUE ); L3487: POPSTACKTRACE( scdebug_error( c2790, c2791, CONS( e2701, EMPTYLIST ) ) ); L3512: X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( scrt1_cons_2a( c2784, CONS( EMPTYLIST, EMPTYLIST ) ), X4 ); X5 = scrt1_cons_2a( c2783, CONS( EMPTYLIST, EMPTYLIST ) ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( scrt1_cons_2a( X5, CONS( c2778, X6 ) ), X4 ); X3 = CONS( scrt1_cons_2a( c2525, CONS( c2778, X4 ) ), X3 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X4 = scrt1_cons_2a( c2778, CONS( PAIR_CAR( X2 ), X5 ) ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X7 = CONS( scrt1_cons_2a( c2772, CONS( scrt1_append_2dtwo( X1, X8 ), EMPTYLIST ) ), X7 ); X5 = CONS( scrt1_cons_2a( c2784, CONS( scrt1_cons_2a( c2137, CONS( EMPTYLIST, X7 ) ), X6 ) ), X5 ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( scrt1_caddr( X2 ), X7 ); POPSTACKTRACE( scrt1_cons_2a( c2777, CONS( scrt1_cons_2a( X4, CONS( scrt1_cons_2a( c2783, CONS( scrt1_cons_2a( c2137, CONS( EMPTYLIST, X7 ) ), X6 ) ), X5 ) ), X3 ) ) ); L3516: X3 = PAIR_CAR( X2 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2763 ) ) ) goto L3518; X3 = PAIR_CDR( X2 ); X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2396, CONS( scrt1_append_2dtwo( X3, X4 ), EMPTYLIST ) ) ); L3518: X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c2772, CONS( scrt1_append_2dtwo( X1, X4 ), EMPTYLIST ) ), X3 ); X4 = PAIR_CDR( X2 ); X5 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c2396, CONS( scrt1_append_2dtwo( X4, X5 ), EMPTYLIST ) ), X3 ); POPSTACKTRACE( scrt1_cons_2a( c2525, CONS( PAIR_CAR( X2 ), X3 ) ) ); } TSCP scexpnd1_l2812( x2813, e2814 ) TSCP x2813, e2814; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd1_l2812 [inside TOP-LEVEL]" ); X2 = scexpnd1_cond_2dmacro( x2813 ); X1 = e2814; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2814, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scexpnd1_case_2dmacro_v ); DEFCSTRING( t3525, "SCEXPND1_CASE-MACRO" ); EXTERNTSCPP( sc_d_2dsymbol_ab4b4447, XAL1( TSCP ) ); EXTERNTSCP( sc_d_2dsymbol_ab4b4447_v ); TSCP scexpnd1_case_2dmacro( e2817 ) TSCP e2817; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3525 ); if ( FALSE( scexpand_islist( e2817, _TSCP( 12 ), EMPTYLIST ) ) ) goto L3527; if ( EQ( TSCPTAG( e2817 ), PAIRTAG ) ) goto L3531; scrt1__24__cdr_2derror( e2817 ); L3531: X5 = PAIR_CDR( e2817 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3534; scrt1__24__car_2derror( X5 ); L3534: X2 = PAIR_CAR( X5 ); X3 = sc_d_2dsymbol_ab4b4447( c2890 ); X5 = PAIR_CDR( e2817 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3538; scrt1__24__cdr_2derror( X5 ); L3538: X4 = PAIR_CDR( X5 ); X1 = EMPTYLIST; L3540: X1 = CONS( X1, EMPTYLIST ); X5 = BOOLEAN( NEQ( TSCPTAG( X4 ), PAIRTAG ) ); if ( TRUE( X5 ) ) goto L3545; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3549; scrt1__24__car_2derror( X4 ); L3549: X6 = PAIR_CAR( X4 ); if ( FALSE( scexpand_islist( X6, _TSCP( 8 ), EMPTYLIST ) ) ) goto L3545; X7 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3556; scrt1__24__car_2derror( X7 ); L3556: X6 = PAIR_CAR( X7 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( c2763 ) ) ) goto L3552; X7 = PAIR_CAR( X4 ); X6 = sc_cons( X7, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X6 ); goto L3553; L3552: X9 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X11 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L3561; scrt1__24__car_2derror( X11 ); L3561: X9 = CONS( scrt1_cons_2a( c2148, CONS( PAIR_CAR( X11 ), X10 ) ), X9 ); X8 = scrt1_cons_2a( c2851, CONS( X3, X9 ) ); X10 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3565; scrt1__24__cdr_2derror( X10 ); L3565: X9 = PAIR_CDR( X10 ); X10 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X7 = scrt1_cons_2a( X8, CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ) ); X6 = sc_cons( X7, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X6 ); L3553: X6 = PAIR_CDR( X4 ); X1 = PAIR_CAR( X1 ); X4 = X6; GOBACK( L3540 ); L3527: POPSTACKTRACE( scdebug_error( c2818, c2819, CONS( e2817, EMPTYLIST ) ) ); L3545: if ( FALSE( X4 ) ) goto L3568; POPSTACKTRACE( scdebug_error( c2818, c2135, CONS( e2817, EMPTYLIST ) ) ); L3568: X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_reverse( PAIR_CAR( X1 ) ); X7 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_cons_2a( c2772, CONS( scrt1_append_2dtwo( X6, X7 ), EMPTYLIST ) ), X5 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( X3, CONS( X2, X7 ) ); POPSTACKTRACE( scrt1_cons_2a( c2777, CONS( scrt1_cons_2a( X6, CONS( EMPTYLIST, EMPTYLIST ) ), X5 ) ) ); } TSCP scexpnd1_l2901( x2902, e2903 ) TSCP x2902, e2903; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd1_l2901 [inside TOP-LEVEL]" ); X2 = scexpnd1_case_2dmacro( x2902 ); X1 = e2903; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2903, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scexpnd1_and_2dmacro_v ); DEFCSTRING( t3571, "SCEXPND1_AND-MACRO" ); TSCP scexpnd1_and_2dmacro( e2906 ) TSCP e2906; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3571 ); if ( EQ( TSCPTAG( e2906 ), PAIRTAG ) ) goto L3576; scrt1__24__cdr_2derror( e2906 ); L3576: X1 = PAIR_CDR( e2906 ); if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3573; X2 = PAIR_CDR( e2906 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3582; scrt1__24__cdr_2derror( X2 ); L3582: X1 = PAIR_CDR( X2 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3578; X1 = PAIR_CDR( e2906 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3586; scrt1__24__car_2derror( X1 ); L3586: POPSTACKTRACE( PAIR_CAR( X1 ) ); L3578: X1 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( c2256, X2 ); X2 = CONS( scrt1_cons_2a( c2941, CONS( EMPTYLIST, EMPTYLIST ) ), X2 ); X1 = CONS( scrt1_cons_2a( c2525, CONS( c2256, X2 ) ), X1 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = PAIR_CDR( e2906 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3590; scrt1__24__car_2derror( X4 ); L3590: X2 = scrt1_cons_2a( c2256, CONS( PAIR_CAR( X4 ), X3 ) ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X7 = PAIR_CDR( e2906 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3594; scrt1__24__cdr_2derror( X7 ); L3594: X6 = PAIR_CDR( X7 ); X7 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_cons_2a( c2942, CONS( scrt1_append_2dtwo( X6, X7 ), EMPTYLIST ) ), X5 ); POPSTACKTRACE( scrt1_cons_2a( c2777, CONS( scrt1_cons_2a( X2, CONS( scrt1_cons_2a( c2941, CONS( scrt1_cons_2a( c2137, CONS( EMPTYLIST, X5 ) ), X4 ) ), X3 ) ), X1 ) ) ); L3573: POPSTACKTRACE( TRUEVALUE ); } TSCP scexpnd1_l2963( x2964, e2965 ) TSCP x2964, e2965; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd1_l2963 [inside TOP-LEVEL]" ); X2 = scexpnd1_and_2dmacro( x2964 ); X1 = e2965; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2965, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scexpnd1_or_2dmacro_v ); DEFCSTRING( t3597, "SCEXPND1_OR-MACRO" ); TSCP scexpnd1_or_2dmacro( e2968 ) TSCP e2968; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3597 ); if ( EQ( TSCPTAG( e2968 ), PAIRTAG ) ) goto L3602; scrt1__24__cdr_2derror( e2968 ); L3602: X1 = PAIR_CDR( e2968 ); if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3599; X2 = PAIR_CDR( e2968 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3608; scrt1__24__cdr_2derror( X2 ); L3608: X1 = PAIR_CDR( X2 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3604; X1 = PAIR_CDR( e2968 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3612; scrt1__24__car_2derror( X1 ); L3612: POPSTACKTRACE( PAIR_CAR( X1 ) ); L3604: X1 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( c2941, CONS( EMPTYLIST, EMPTYLIST ) ), X2 ); X2 = CONS( c2256, X2 ); X1 = CONS( scrt1_cons_2a( c2525, CONS( c2256, X2 ) ), X1 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = PAIR_CDR( e2968 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3616; scrt1__24__car_2derror( X4 ); L3616: X2 = scrt1_cons_2a( c2256, CONS( PAIR_CAR( X4 ), X3 ) ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X7 = PAIR_CDR( e2968 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3620; scrt1__24__cdr_2derror( X7 ); L3620: X6 = PAIR_CDR( X7 ); X7 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_cons_2a( c2785, CONS( scrt1_append_2dtwo( X6, X7 ), EMPTYLIST ) ), X5 ); POPSTACKTRACE( scrt1_cons_2a( c2777, CONS( scrt1_cons_2a( X2, CONS( scrt1_cons_2a( c2941, CONS( scrt1_cons_2a( c2137, CONS( EMPTYLIST, X5 ) ), X4 ) ), X3 ) ), X1 ) ) ); L3599: POPSTACKTRACE( FALSEVALUE ); } TSCP scexpnd1_l3023( x3024, e3025 ) TSCP x3024, e3025; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd1_l3023 [inside TOP-LEVEL]" ); X2 = scexpnd1_or_2dmacro( x3024 ); X1 = e3025; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e3025, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scexpnd1_when_2dmacro_v ); DEFCSTRING( t3623, "SCEXPND1_WHEN-MACRO" ); TSCP scexpnd1_when_2dmacro( e3028 ) TSCP e3028; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3623 ); if ( FALSE( scexpand_islist( e3028, _TSCP( 12 ), EMPTYLIST ) ) ) goto L3625; X1 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( e3028 ), PAIRTAG ) ) goto L3628; scrt1__24__cdr_2derror( e3028 ); L3628: X3 = PAIR_CDR( e3028 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3631; scrt1__24__cdr_2derror( X3 ); L3631: X2 = PAIR_CDR( X3 ); X3 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X1 = CONS( scrt1_cons_2a( c2396, CONS( scrt1_append_2dtwo( X2, X3 ), EMPTYLIST ) ), X1 ); X2 = PAIR_CDR( e3028 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3635; scrt1__24__car_2derror( X2 ); L3635: POPSTACKTRACE( scrt1_cons_2a( c2525, CONS( PAIR_CAR( X2 ), X1 ) ) ); L3625: POPSTACKTRACE( scdebug_error( c3029, c2135, CONS( e3028, EMPTYLIST ) ) ); } TSCP scexpnd1_l3050( x3051, e3052 ) TSCP x3051, e3052; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd1_l3050 [inside TOP-LEVEL]" ); X2 = scexpnd1_when_2dmacro( x3051 ); X1 = e3052; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e3052, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scexpnd1_unless_2dmacro_v ); DEFCSTRING( t3638, "SCEXPND1_UNLESS-MACRO" ); TSCP scexpnd1_unless_2dmacro( e3055 ) TSCP e3055; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3638 ); if ( FALSE( scexpand_islist( e3055, _TSCP( 12 ), EMPTYLIST ) ) ) goto L3640; X1 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( e3055 ), PAIRTAG ) ) goto L3643; scrt1__24__cdr_2derror( e3055 ); L3643: X3 = PAIR_CDR( e3055 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3646; scrt1__24__cdr_2derror( X3 ); L3646: X2 = PAIR_CDR( X3 ); X3 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X1 = CONS( scrt1_cons_2a( c2396, CONS( scrt1_append_2dtwo( X2, X3 ), EMPTYLIST ) ), X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = PAIR_CDR( e3055 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3650; scrt1__24__car_2derror( X3 ); L3650: POPSTACKTRACE( scrt1_cons_2a( c2525, CONS( scrt1_cons_2a( c3057, CONS( PAIR_CAR( X3 ), X2 ) ), X1 ) ) ); L3640: POPSTACKTRACE( scdebug_error( c3056, c2135, CONS( e3055, EMPTYLIST ) ) ); } TSCP scexpnd1_l3078( x3079, e3080 ) TSCP x3079, e3080; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd1_l3078 [inside TOP-LEVEL]" ); X2 = scexpnd1_unless_2dmacro( x3079 ); X1 = e3080; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e3080, PROCEDURE_CLOSURE( X1 ) ) ); } void scrt4__init(); void sceval__init(); void scrt6__init(); void scrt2__init(); void scdebug__init(); void scrt1__init(); void scexpand__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt4__init(); sceval__init(); scrt6__init(); scrt2__init(); scdebug__init(); scrt1__init(); scexpand__init(); MAXDISPLAY( 1 ); } void scexpnd1__init() { TSCP X1; static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scexpnd1 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2131, EMPTYLIST ); scexpand_install_2dexpander( c2130, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2149, EMPTYLIST ); scexpand_install_2dexpander( c2148, X1 ); INITIALIZEVAR( t3174, ADR( scexpnd1_do_2ddefine_v ), MAKEPROCEDURE( 2, 0, scexpnd1_do_2ddefine, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2163, EMPTYLIST ); scexpand_install_2dexpander( c2162, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2227, EMPTYLIST ); scexpand_install_2dexpander( c2226, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2271, EMPTYLIST ); scexpand_install_2dexpander( c2270, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2312, EMPTYLIST ); scexpand_install_2dexpander( c2311, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2355, EMPTYLIST ); scexpand_install_2dexpander( c2354, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2361, EMPTYLIST ); scexpand_install_2dexpander( c2360, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2367, EMPTYLIST ); scexpand_install_2dexpander( c2366, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2407, EMPTYLIST ); scexpand_install_2dexpander( c2137, X1 ); INITIALIZEVAR( t3346, ADR( scexpnd1_lambda_2ddefines_v ), MAKEPROCEDURE( 1, 0, scexpnd1_lambda_2ddefines, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2526, EMPTYLIST ); scexpand_install_2dexpander( c2525, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2554, EMPTYLIST ); scexpand_install_2dexpander( c2516, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2583, EMPTYLIST ); scexpand_install_2dexpander( c2396, X1 ); INITIALIZEVAR( t3429, ADR( scexpnd1_2dexpander_afd5ebf4_v ), MAKEPROCEDURE( 1, 0, scexpnd1_2dexpander_afd5ebf4, EMPTYLIST ) ); INITIALIZEVAR( t3463, ADR( scexpnd1_cond_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd1_cond_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2812, EMPTYLIST ); scexpand_install_2dexpander( c2772, X1 ); INITIALIZEVAR( t3525, ADR( scexpnd1_case_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd1_case_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2901, EMPTYLIST ); scexpand_install_2dexpander( c2818, X1 ); INITIALIZEVAR( t3571, ADR( scexpnd1_and_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd1_and_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l2963, EMPTYLIST ); scexpand_install_2dexpander( c2942, X1 ); INITIALIZEVAR( t3597, ADR( scexpnd1_or_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd1_or_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l3023, EMPTYLIST ); scexpand_install_2dexpander( c2785, X1 ); INITIALIZEVAR( t3623, ADR( scexpnd1_when_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd1_when_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l3050, EMPTYLIST ); scexpand_install_2dexpander( c3029, X1 ); INITIALIZEVAR( t3638, ADR( scexpnd1_unless_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd1_unless_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd1_l3078, EMPTYLIST ); scexpand_install_2dexpander( c3056, X1 ); return; } scheme2c-2012.10.14/scrt/scexpnd1.sc000066400000000000000000000217501203736146400166350ustar00rootroot00000000000000;;; This module contains the basic macro expanders required by Scheme. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scexpnd1 (top-level DO-DEFINE)) (include "repdef.sc") ;;; (DELAY exp) ==> (make-promise (lambda () exp)) (install-expander 'DELAY (lambda (x e) (if (islist x 2 2) (e `(make-promise (lambda () ,(cadr x))) e) (error 'delay "Illegal form: ~s" x)))) ;;; (QUOTE exp) ==> (quote exp) (install-expander 'QUOTE (lambda (x e) (if (islist x 2 2) x (error 'quote "Illegal form: ~s" x)))) ;;; (DEFINE symbol exp) ==> (do-define 'symbol exp) ;;; (DEFINE (symbol ...) exp ...) ==> (do-define 'symbol (lambda ...)) (define (DO-DEFINE symbol value) (let ((was (top-level-value symbol))) (set-top-level-value! symbol value) (if (not (eq? was $_undefined)) (display (format "***** ~s is redefined~%" symbol))) symbol)) (install-expander 'DEFINE (lambda (x e) (cond ((and (islist x 3 3) (symbol? (cadr x))) `(do-define (quote ,(cadr x)) ,(e (caddr x) e))) ((and (islist x 3) (pair? (cadr x)) (symbol? (caadr x))) `(do-define (quote ,(caadr x)) ,(e `(lambda ,(cdadr x) ,@(cddr x)) e))) (else (error 'define "Illegal form: ~s" x))))) ;;; (DEFINE-IN-LINE (symbol ...) exp ...) ==> 'symbol ;;; ;;; N.B. expanding this form causes the macro to be defined. (install-expander 'DEFINE-IN-LINE (lambda (x e) (cond ((and (islist x 3) (pair? (cadr x)) (symbol? (caadr x))) (let ((func (caadr x)) (args (cdadr x)) (body (cddr x))) (install-expander func (eval `(lambda (x e) (e (cons '(lambda ,args ,@body) (cdr x)) e)))) `(quote ,func))) (else (error 'define-in-line "Illegal form: ~s" x))))) ;;; (DEFINE-MACRO symbol expander) ==> 'symbol ;;; ;;; N.B. expanding this form causes the macro to be defined. (install-expander 'DEFINE-MACRO (lambda (x e) (cond ((and (islist x 3 3) (symbol? (cadr x))) (install-expander (cadr x) (eval (caddr x))) `(quote ,(cadr x))) (else (error 'define-macro "Illegal form: ~s" x))))) ;;; (DEFINE-CONSTANT symbol value) ==> 'symbol ;;; ;;; N.B. expanding this form causes the macro to be defined. (install-expander 'DEFINE-CONSTANT (lambda (x e) (cond ((and (islist x 3 3) (symbol? (cadr x))) (install-expander (cadr x) (list (eval (caddr x)))) `(quote ,(cadr x))) (else (error 'define-constant "Illegal form: ~s" x))))) ;;; (DEFINE-EXTERNAL ...) ==> '(DEFINE-EXTERNAL ...) (install-expander 'DEFINE-EXTERNAL (lambda (x e) (e (list 'quote x) e))) ;;; (DEFINE-C-EXTERNAL ...) ==> '(DEFINE-C-EXTERNAL ...) (install-expander 'DEFINE-C-EXTERNAL (lambda (x e) (e (list 'quote x) e))) ;;; (EVAL-WHEN situation form) ==> (begin form) ;;; ==> #f (install-expander 'EVAL-WHEN (lambda (x e) (if (and (islist x 3) (islist (cadr x) 1)) (if (memq 'eval (cadr x)) (e `(begin ,@(cddr x)) e) '#f) (error 'eval-when "Illegal form: ~s" x)))) ;;; Trivial macro expanders for the basic forms evaluated by the interpreter ;;; are provided to do syntax checking at this point, rather than during ;;; interpretation. ;;; (LAMBDA args ...) ==> (lambda args ...) (install-expander 'LAMBDA (lambda (x e) (let ((e (internal-begin-expander e))) (if (islist x 3) `(lambda ,(cadr x) ,@(lambda-defines (map (lambda (x) (e x e)) (cddr x)))) (error 'lambda "Illegal form: ~s" x))))) ;;; The following procedure is called to rewrite the body of any lambda ;;; expression which contains DEFINE's to an equivalent lambda form. (define (LAMBDA-DEFINES body) (let loop ((oldforms body) (newforms '()) (vars '()) (sets '())) (if (pair? oldforms) (let ((form (car oldforms))) (cond ((or (not (pair? form)) (not (eq? (car form) 'do-define))) (loop (cdr oldforms) (cons form newforms) vars sets)) (else (loop (cdr oldforms) newforms (cons (cadadr form) vars) (cons `(set! ,(cadadr form) ,(caddr form)) sets))))) (if vars `(((lambda ,vars ,@(reverse sets) ,@(reverse newforms)) ,@(vector->list (make-vector (length vars) 0)))) body)))) ;;; (IF A B C) ==> (if a b c) ;;; (IF A B) ==> (if a b #f) (install-expander 'IF (lambda (x e) (cond ((islist x 3 3) (list 'if (e (cadr x) e) (e (caddr x) e) #f)) ((islist x 4 4) (list 'if (e (cadr x) e) (e (caddr x) e) (e (cadddr x) e))) (else (error 'if "Illegal form: ~s" x))))) ;;; (SET! var value) ==> (set! var value) (install-expander 'SET! (lambda (x e) (if (and (islist x 3 3) (symbol? (cadr x))) `(set! ,(cadr x) ,(e (caddr x) e)) (error 'set! "Illegal form: ~s" x)))) ;;; (BEGIN value ...) ==> (begin value ...) (install-expander 'BEGIN (lambda (x e) (cond ((islist x 1 1) #f) ((islist x 2) `(begin ,@(map (lambda (x) (e x e)) (cdr x)))) (else (error 'begin "Illegal form: ~s" x))))) (define (INTERNAL-BEGIN-EXPANDER old-expander) (lambda (expr expander) (if (and (pair? expr) (eq? (car expr) 'begin)) (if (islist expr 2) `(begin ,@(lambda-defines (map (lambda (x) (expander x expander)) (cdr expr)))) (error 'begin "Illegal form: ~s" expr)) (old-expander expr expander)))) ;;; Derived expression types are expanded in this module using the rules ;;; given in section 7.3 of Revised**3. ;;; Conditional forms are expanded into if sequences. (define (COND-MACRO exp) (let* ((clauses (cdr exp)) (clause1 (and clauses (car clauses))) (clause2+ (and clause1 (cdr clauses)))) (cond ((null? clause1) '#f) ((or (not (pair? clause1)) (equal? clause1 '(else))) (error 'cond-clause "Illegal form ~s:" exp)) ((null? (cdr clause1)) `(or ,(car clause1) (cond ,@clause2+))) ((and (eq? (cadr clause1) '=>) (= (length clause1) 3)) `(let ((test-result ,(car clause1)) (thunk2 (lambda () ,(caddr clause1))) (thunk3 (lambda () (cond ,@clause2+)))) (if test-result ((thunk2) test-result) (thunk3)))) ((eq? (car clause1) 'else) `(begin ,@(cdr clause1))) (else `(if ,(car clause1) (begin ,@(cdr clause1)) (cond ,@clause2+)))))) (install-expander 'COND (lambda (x e) (e (cond-macro x) e))) (define (CASE-MACRO exp) (cond ((islist exp 3) (do ((keyval (cadr exp)) (key (string->uninterned-symbol "key")) (cases (cddr exp) (cdr cases)) (ccs '())) ((or (not (pair? cases)) (not (islist (car cases) 2))) (cond (cases (error 'case "Illegal form: ~s" exp)) (else `(let ((,key ,keyval)) (cond ,@(reverse ccs)))))) (cond ((eq? (caar cases) 'else) (set! ccs (cons (car cases) ccs))) (else (set! ccs (cons `((memv ,key (quote ,(caar cases))) ,@(cdar cases)) ccs)))))) (else (error 'case "Illegal form:" exp)))) (install-expander 'CASE (lambda (x e) (e (case-macro x) e))) (define (AND-MACRO exp) (cond ((null? (cdr exp)) '#t) ((null? (cddr exp)) (cadr exp)) (else `(let ((x ,(cadr exp)) (thunk (lambda () (and ,@(cddr exp))))) (if x (thunk) x))))) (install-expander 'AND (lambda (x e) (e (and-macro x) e))) (define (OR-MACRO exp) (cond ((null? (cdr exp)) '#f) ((null? (cddr exp)) (cadr exp)) (else `(let ((x ,(cadr exp)) (thunk (lambda () (or ,@(cddr exp))))) (if x x (thunk)))))) (install-expander 'OR (lambda (x e) (e (or-macro x) e))) ;;; (WHEN test exp ...) ==> (if test (begin exp ...)) (define (WHEN-MACRO exp) (if (islist exp 3) `(if ,(cadr exp) (begin ,@(cddr exp))) (error 'WHEN "Illegal form: ~s" exp))) (install-expander 'WHEN (lambda (x e) (e (when-macro x) e))) ;;; (UNLESS test exp ...) ==> (if (not test) (begin exp ...)) (define (UNLESS-MACRO exp) (if (islist exp 3) `(if (not ,(cadr exp)) (begin ,@(cddr exp))) (error 'UNLESS "Illegal form: ~s" exp))) (install-expander 'UNLESS (lambda (x e) (e (unless-macro x) e))) scheme2c-2012.10.14/scrt/scexpnd2.c000066400000000000000000001062001203736146400164450ustar00rootroot00000000000000 /* SCHEME->C */ #include void scexpnd2__init(); DEFSTATICTSCP( c2751 ); DEFSTATICTSCP( t2832 ); DEFSTATICTSCP( t2833 ); DEFSTATICTSCP( t2834 ); DEFSTATICTSCP( c2747 ); DEFSTATICTSCP( c2746 ); DEFSTATICTSCP( t2835 ); DEFSTATICTSCP( c2742 ); DEFSTATICTSCP( c2738 ); DEFCSTRING( t2836, "doloop" ); DEFSTATICTSCP( c2735 ); DEFSTATICTSCP( c2724 ); DEFCSTRING( t2837, "Illegal form:" ); DEFSTATICTSCP( c2693 ); DEFSTATICTSCP( c2660 ); DEFSTATICTSCP( c2659 ); DEFCSTRING( t2838, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2614 ); DEFSTATICTSCP( c2613 ); DEFSTATICTSCP( c2568 ); DEFSTATICTSCP( c2559 ); DEFSTATICTSCP( c2359 ); DEFSTATICTSCP( c2242 ); DEFSTATICTSCP( c2231 ); DEFCSTRING( t2839, "$_~s" ); DEFSTATICTSCP( c2213 ); DEFCSTRING( t2840, "Illegal form: ~s" ); DEFSTATICTSCP( c2166 ); DEFSTATICTSCP( c2165 ); static void init_constants() { TSCP X1; c2751 = EMPTYLIST; X1 = EMPTYLIST; t2832 = STRINGTOSYMBOL( CSTRING_TSCP( "*IGNORED*" ) ); X1 = CONS( t2832, X1 ); t2833 = STRINGTOSYMBOL( CSTRING_TSCP( "INCLUDE" ) ); X1 = CONS( t2833, X1 ); c2751 = CONS( X1, c2751 ); t2834 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); c2751 = CONS( t2834, c2751 ); CONSTANTEXP( ADR( c2751 ) ); c2747 = STRINGTOSYMBOL( CSTRING_TSCP( "INCLUDE" ) ); CONSTANTEXP( ADR( c2747 ) ); c2746 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t2832, X1 ); t2835 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); X1 = CONS( t2835, X1 ); c2746 = CONS( X1, c2746 ); c2746 = CONS( t2834, c2746 ); CONSTANTEXP( ADR( c2746 ) ); c2742 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); CONSTANTEXP( ADR( c2742 ) ); c2738 = EMPTYLIST; c2738 = CONS( FALSEVALUE, c2738 ); CONSTANTEXP( ADR( c2738 ) ); c2735 = CSTRING_TSCP( t2836 ); CONSTANTEXP( ADR( c2735 ) ); c2724 = STRINGTOSYMBOL( CSTRING_TSCP( "IF" ) ); CONSTANTEXP( ADR( c2724 ) ); c2693 = CSTRING_TSCP( t2837 ); CONSTANTEXP( ADR( c2693 ) ); c2660 = STRINGTOSYMBOL( CSTRING_TSCP( "EXP" ) ); CONSTANTEXP( ADR( c2660 ) ); c2659 = STRINGTOSYMBOL( CSTRING_TSCP( "DO" ) ); CONSTANTEXP( ADR( c2659 ) ); c2614 = CSTRING_TSCP( t2838 ); CONSTANTEXP( ADR( c2614 ) ); c2613 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2613 ) ); c2568 = STRINGTOSYMBOL( CSTRING_TSCP( "BEGIN" ) ); CONSTANTEXP( ADR( c2568 ) ); c2559 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2559 ) ); c2359 = STRINGTOSYMBOL( CSTRING_TSCP( "LET*" ) ); CONSTANTEXP( ADR( c2359 ) ); c2242 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2242 ) ); c2231 = STRINGTOSYMBOL( CSTRING_TSCP( "LETREC" ) ); CONSTANTEXP( ADR( c2231 ) ); c2213 = CSTRING_TSCP( t2839 ); CONSTANTEXP( ADR( c2213 ) ); c2166 = CSTRING_TSCP( t2840 ); CONSTANTEXP( ADR( c2166 ) ); c2165 = STRINGTOSYMBOL( CSTRING_TSCP( "LET" ) ); CONSTANTEXP( ADR( c2165 ) ); } DEFTSCP( scexpnd2_let_2dmacro_v ); DEFCSTRING( t2841, "SCEXPND2_LET-MACRO" ); EXTERNTSCPP( scexpand_islist, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scexpand_islist_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt1_cadar, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadar_v ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( sc_d_2dsymbol_ab4b4447, XAL1( TSCP ) ); EXTERNTSCP( sc_d_2dsymbol_ab4b4447_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); TSCP scexpnd2_let_2dmacro( e2131 ) TSCP e2131; { TSCP X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2841 ); X8 = scexpand_islist( e2131, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X8 ) ) goto L2892; if ( EQ( TSCPTAG( e2131 ), PAIRTAG ) ) goto L2850; scrt1__24__cdr_2derror( e2131 ); L2850: X10 = PAIR_CDR( e2131 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L2853; scrt1__24__car_2derror( X10 ); L2853: X9 = PAIR_CAR( X10 ); if ( FALSE( scexpand_islist( X9, _TSCP( 0 ), EMPTYLIST ) ) ) goto L2892; X9 = PAIR_CDR( e2131 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L2858; scrt1__24__car_2derror( X9 ); L2858: X7 = PAIR_CAR( X9 ); X6 = EMPTYLIST; X5 = EMPTYLIST; L2860: X5 = CONS( X5, EMPTYLIST ); X6 = CONS( X6, EMPTYLIST ); X9 = BOOLEAN( NEQ( TSCPTAG( X7 ), PAIRTAG ) ); if ( TRUE( X9 ) ) goto L2865; if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L2869; scrt1__24__car_2derror( X7 ); L2869: X11 = PAIR_CAR( X7 ); if ( FALSE( scexpand_islist( X11, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L2866; X10 = FALSEVALUE; goto L2867; L2866: X10 = TRUEVALUE; L2867: if ( TRUE( X10 ) ) goto L2865; if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L2879; scrt1__24__car_2derror( X7 ); L2879: X12 = PAIR_CAR( X7 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L2882; scrt1__24__car_2derror( X12 ); L2882: X11 = PAIR_CAR( X12 ); if ( NOT( AND( EQ( TSCPTAG( X11 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X11 ), SYMBOLTAG ) ) ) ) goto L2865; if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L2886; scrt1__24__car_2derror( X7 ); L2886: X13 = PAIR_CAR( X7 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2889; scrt1__24__car_2derror( X13 ); L2889: X12 = PAIR_CAR( X13 ); X11 = sc_cons( X12, PAIR_CAR( X6 ) ); SETGEN( PAIR_CAR( X6 ), X11 ); X12 = scrt1_cadar( X7 ); X11 = sc_cons( X12, PAIR_CAR( X5 ) ); SETGEN( PAIR_CAR( X5 ), X11 ); X11 = PAIR_CDR( X7 ); X5 = PAIR_CAR( X5 ); X6 = PAIR_CAR( X6 ); X7 = X11; GOBACK( L2860 ); L2892: X8 = scexpand_islist( e2131, _TSCP( 16 ), EMPTYLIST ); if ( FALSE( X8 ) ) goto L2944; if ( EQ( TSCPTAG( e2131 ), PAIRTAG ) ) goto L2900; scrt1__24__cdr_2derror( e2131 ); L2900: X10 = PAIR_CDR( e2131 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L2903; scrt1__24__car_2derror( X10 ); L2903: X9 = PAIR_CAR( X10 ); if ( NOT( AND( EQ( TSCPTAG( X9 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X9 ), SYMBOLTAG ) ) ) ) goto L2944; X4 = scrt1_caddr( e2131 ); X9 = _TSCP( 0 ); X1 = EMPTYLIST; X2 = EMPTYLIST; X3 = EMPTYLIST; L2906: X3 = CONS( X3, EMPTYLIST ); X2 = CONS( X2, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); X10 = BOOLEAN( NEQ( TSCPTAG( X4 ), PAIRTAG ) ); if ( TRUE( X10 ) ) goto L2911; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L2915; scrt1__24__car_2derror( X4 ); L2915: X12 = PAIR_CAR( X4 ); if ( FALSE( scexpand_islist( X12, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L2912; X11 = FALSEVALUE; goto L2913; L2912: X11 = TRUEVALUE; L2913: if ( TRUE( X11 ) ) goto L2911; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L2925; scrt1__24__car_2derror( X4 ); L2925: X13 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2928; scrt1__24__car_2derror( X13 ); L2928: X12 = PAIR_CAR( X13 ); if ( NOT( AND( EQ( TSCPTAG( X12 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X12 ), SYMBOLTAG ) ) ) ) goto L2911; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L2932; scrt1__24__car_2derror( X4 ); L2932: X14 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L2935; scrt1__24__car_2derror( X14 ); L2935: X13 = PAIR_CAR( X14 ); X12 = sc_cons( X13, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X12 ); X14 = scrt6_format( c2213, CONS( X9, EMPTYLIST ) ); X13 = sc_d_2dsymbol_ab4b4447( X14 ); X12 = sc_cons( X13, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X12 ); X16 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L2938; scrt1__24__car_2derror( X16 ); L2938: X15 = PAIR_CAR( X16 ); X17 = scrt1_cadar( X4 ); X16 = sc_cons( X17, EMPTYLIST ); X14 = sc_cons( X15, X16 ); X13 = X14; X12 = sc_cons( X13, PAIR_CAR( X3 ) ); SETGEN( PAIR_CAR( X3 ), X12 ); X12 = PAIR_CDR( X4 ); if ( BITAND( BITOR( _S2CINT( X9 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2942; X13 = _TSCP( IPLUS( _S2CINT( X9 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2943; L2942: X13 = scrt2__2b_2dtwo( X9, _TSCP( 4 ) ); L2943: X3 = PAIR_CAR( X3 ); X2 = PAIR_CAR( X2 ); X1 = PAIR_CAR( X1 ); X9 = X13; X4 = X12; GOBACK( L2906 ); L2944: POPSTACKTRACE( scdebug_error( c2165, c2166, CONS( e2131, EMPTYLIST ) ) ); L2865: if ( FALSE( X7 ) ) goto L2945; POPSTACKTRACE( scdebug_error( c2165, c2166, CONS( e2131, EMPTYLIST ) ) ); L2945: X11 = PAIR_CDR( e2131 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L2949; scrt1__24__cdr_2derror( X11 ); L2949: X10 = PAIR_CDR( X11 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ); X8 = scrt1_cons_2a( c2242, CONS( scrt1_reverse( PAIR_CAR( X6 ) ), X9 ) ); X9 = scrt1_reverse( PAIR_CAR( X5 ) ); X10 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( X8, CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ) ) ); L2911: if ( FALSE( X4 ) ) goto L2951; POPSTACKTRACE( scdebug_error( c2165, c2166, CONS( e2131, EMPTYLIST ) ) ); L2951: X8 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X11 = PAIR_CDR( e2131 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L2955; scrt1__24__car_2derror( X11 ); L2955: X10 = PAIR_CAR( X11 ); X11 = scrt1_reverse( PAIR_CAR( X1 ) ); X12 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_cons_2a( X10, CONS( scrt1_append_2dtwo( X11, X12 ), EMPTYLIST ) ), X9 ); X12 = PAIR_CDR( e2131 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L2959; scrt1__24__car_2derror( X12 ); L2959: X11 = PAIR_CAR( X12 ); X12 = CONS( EMPTYLIST, EMPTYLIST ); X14 = scrt1_cdddr( e2131 ); X15 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X13 = CONS( scrt1_append_2dtwo( X14, X15 ), EMPTYLIST ); X10 = scrt1_cons_2a( X11, CONS( scrt1_cons_2a( c2242, CONS( scrt1_reverse( PAIR_CAR( X2 ) ), X13 ) ), X12 ) ); X8 = CONS( scrt1_cons_2a( c2231, CONS( scrt1_cons_2a( X10, CONS( EMPTYLIST, EMPTYLIST ) ), X9 ) ), X8 ); POPSTACKTRACE( scrt1_cons_2a( c2165, CONS( scrt1_reverse( PAIR_CAR( X3 ) ), X8 ) ) ); } EXTERNTSCPP( scexpand_install_2dexpander, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scexpand_install_2dexpander_v ); TSCP scexpnd2_l2320( x2321, e2322 ) TSCP x2321, e2322; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd2_l2320 [inside TOP-LEVEL]" ); X2 = scexpnd2_let_2dmacro( x2321 ); X1 = e2322; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2322, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scexpnd2_let_2a_2dmacro_v ); DEFCSTRING( t2962, "SCEXPND2_LET*-MACRO" ); EXTERNTSCPP( scexpnd2_let_2a_2dresult, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scexpnd2_let_2a_2dresult_v ); TSCP scexpnd2_let_2a_2dmacro( e2325 ) TSCP e2325; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2962 ); X4 = scexpand_islist( e2325, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X4 ) ) goto L3013; if ( EQ( TSCPTAG( e2325 ), PAIRTAG ) ) goto L2971; scrt1__24__cdr_2derror( e2325 ); L2971: X6 = PAIR_CDR( e2325 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L2974; scrt1__24__car_2derror( X6 ); L2974: X5 = PAIR_CAR( X6 ); if ( FALSE( scexpand_islist( X5, _TSCP( 4 ), EMPTYLIST ) ) ) goto L3013; X5 = PAIR_CDR( e2325 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L2979; scrt1__24__car_2derror( X5 ); L2979: X3 = PAIR_CAR( X5 ); X2 = EMPTYLIST; X1 = EMPTYLIST; L2981: X1 = CONS( X1, EMPTYLIST ); X2 = CONS( X2, EMPTYLIST ); X5 = BOOLEAN( NEQ( TSCPTAG( X3 ), PAIRTAG ) ); if ( TRUE( X5 ) ) goto L2986; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2990; scrt1__24__car_2derror( X3 ); L2990: X7 = PAIR_CAR( X3 ); if ( FALSE( scexpand_islist( X7, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L2987; X6 = FALSEVALUE; goto L2988; L2987: X6 = TRUEVALUE; L2988: if ( TRUE( X6 ) ) goto L2986; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3000; scrt1__24__car_2derror( X3 ); L3000: X8 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3003; scrt1__24__car_2derror( X8 ); L3003: X7 = PAIR_CAR( X8 ); if ( NOT( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), SYMBOLTAG ) ) ) ) goto L2986; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3007; scrt1__24__car_2derror( X3 ); L3007: X9 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3010; scrt1__24__car_2derror( X9 ); L3010: X8 = PAIR_CAR( X9 ); X7 = sc_cons( X8, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X7 ); X8 = scrt1_cadar( X3 ); X7 = sc_cons( X8, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X7 ); X7 = PAIR_CDR( X3 ); X1 = PAIR_CAR( X1 ); X2 = PAIR_CAR( X2 ); X3 = X7; GOBACK( L2981 ); L3013: X4 = scexpand_islist( e2325, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X4 ) ) goto L3030; if ( EQ( TSCPTAG( e2325 ), PAIRTAG ) ) goto L3021; scrt1__24__cdr_2derror( e2325 ); L3021: X6 = PAIR_CDR( e2325 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3024; scrt1__24__car_2derror( X6 ); L3024: X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L3030; X8 = PAIR_CDR( e2325 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3028; scrt1__24__cdr_2derror( X8 ); L3028: X7 = PAIR_CDR( X8 ); X8 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_append_2dtwo( X7, X8 ), EMPTYLIST ); X5 = scrt1_cons_2a( c2242, CONS( EMPTYLIST, X6 ) ); POPSTACKTRACE( scrt1_cons_2a( X5, CONS( EMPTYLIST, EMPTYLIST ) ) ); L3030: POPSTACKTRACE( scdebug_error( c2359, c2166, CONS( e2325, EMPTYLIST ) ) ); L2986: if ( FALSE( X3 ) ) goto L3031; POPSTACKTRACE( scdebug_error( c2359, c2166, CONS( e2325, EMPTYLIST ) ) ); L3031: X6 = PAIR_CDR( e2325 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3035; scrt1__24__cdr_2derror( X6 ); L3035: X5 = PAIR_CDR( X6 ); X4 = scexpnd2_let_2a_2dresult( PAIR_CAR( X2 ), PAIR_CAR( X1 ), X5 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3038; scrt1__24__car_2derror( X4 ); L3038: POPSTACKTRACE( PAIR_CAR( X4 ) ); } TSCP scexpnd2_l2442( x2443, e2444 ) TSCP x2443, e2444; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd2_l2442 [inside TOP-LEVEL]" ); X2 = scexpnd2_let_2a_2dmacro( x2443 ); X1 = e2444; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2444, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scexpnd2_let_2a_2dresult_v ); DEFCSTRING( t3041, "SCEXPND2_LET*-RESULT" ); TSCP scexpnd2_let_2a_2dresult( v2446, i2447, b2448 ) TSCP v2446, i2447, b2448; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3041 ); L3042: if ( EQ( _S2CUINT( v2446 ), _S2CUINT( EMPTYLIST ) ) ) goto L3043; if ( EQ( TSCPTAG( v2446 ), PAIRTAG ) ) goto L3046; scrt1__24__cdr_2derror( v2446 ); L3046: X1 = PAIR_CDR( v2446 ); if ( EQ( TSCPTAG( i2447 ), PAIRTAG ) ) goto L3049; scrt1__24__cdr_2derror( i2447 ); L3049: X2 = PAIR_CDR( i2447 ); X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_append_2dtwo( b2448, X6 ), EMPTYLIST ); X6 = PAIR_CAR( v2446 ); X4 = scrt1_cons_2a( c2242, CONS( scrt1_cons_2a( X6, CONS( EMPTYLIST, EMPTYLIST ) ), X5 ) ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( X4, CONS( PAIR_CAR( i2447 ), X5 ) ); b2448 = scrt1_cons_2a( X3, CONS( EMPTYLIST, EMPTYLIST ) ); i2447 = X2; v2446 = X1; GOBACK( L3042 ); L3043: POPSTACKTRACE( b2448 ); } DEFTSCP( scexpnd2_letrec_2dmacro_v ); DEFCSTRING( t3053, "SCEXPND2_LETREC-MACRO" ); TSCP scexpnd2_letrec_2dmacro( e2472 ) TSCP e2472; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3053 ); X4 = scexpand_islist( e2472, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X4 ) ) goto L3105; if ( EQ( TSCPTAG( e2472 ), PAIRTAG ) ) goto L3062; scrt1__24__cdr_2derror( e2472 ); L3062: X6 = PAIR_CDR( e2472 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3065; scrt1__24__car_2derror( X6 ); L3065: X5 = PAIR_CAR( X6 ); if ( FALSE( scexpand_islist( X5, _TSCP( 4 ), EMPTYLIST ) ) ) goto L3105; X5 = PAIR_CDR( e2472 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3070; scrt1__24__car_2derror( X5 ); L3070: X3 = PAIR_CAR( X5 ); X2 = EMPTYLIST; X1 = EMPTYLIST; L3072: X1 = CONS( X1, EMPTYLIST ); X2 = CONS( X2, EMPTYLIST ); X5 = BOOLEAN( NEQ( TSCPTAG( X3 ), PAIRTAG ) ); if ( TRUE( X5 ) ) goto L3077; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3081; scrt1__24__car_2derror( X3 ); L3081: X7 = PAIR_CAR( X3 ); if ( FALSE( scexpand_islist( X7, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L3078; X6 = FALSEVALUE; goto L3079; L3078: X6 = TRUEVALUE; L3079: if ( TRUE( X6 ) ) goto L3077; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3091; scrt1__24__car_2derror( X3 ); L3091: X8 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3094; scrt1__24__car_2derror( X8 ); L3094: X7 = PAIR_CAR( X8 ); if ( NOT( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), SYMBOLTAG ) ) ) ) goto L3077; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3098; scrt1__24__car_2derror( X3 ); L3098: X9 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3101; scrt1__24__car_2derror( X9 ); L3101: X8 = PAIR_CAR( X9 ); X7 = sc_cons( X8, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X7 ); X9 = PAIR_CAR( X3 ); X10 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( c2559, CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ) ); X7 = sc_cons( X8, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X7 ); X7 = PAIR_CDR( X3 ); X1 = PAIR_CAR( X1 ); X2 = PAIR_CAR( X2 ); X3 = X7; GOBACK( L3072 ); L3105: X4 = scexpand_islist( e2472, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X4 ) ) goto L3122; if ( EQ( TSCPTAG( e2472 ), PAIRTAG ) ) goto L3113; scrt1__24__cdr_2derror( e2472 ); L3113: X6 = PAIR_CDR( e2472 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3116; scrt1__24__car_2derror( X6 ); L3116: X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L3122; X8 = PAIR_CDR( e2472 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3120; scrt1__24__cdr_2derror( X8 ); L3120: X7 = PAIR_CDR( X8 ); X8 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_append_2dtwo( X7, X8 ), EMPTYLIST ); X5 = scrt1_cons_2a( c2242, CONS( EMPTYLIST, X6 ) ); POPSTACKTRACE( scrt1_cons_2a( X5, CONS( EMPTYLIST, EMPTYLIST ) ) ); L3122: POPSTACKTRACE( scdebug_error( c2231, c2166, CONS( e2472, EMPTYLIST ) ) ); L3077: if ( FALSE( X3 ) ) goto L3123; POPSTACKTRACE( scdebug_error( c2231, c2166, CONS( e2472, EMPTYLIST ) ) ); L3123: X6 = scrt1_reverse( PAIR_CAR( X1 ) ); X10 = PAIR_CDR( e2472 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3127; scrt1__24__cdr_2derror( X10 ); L3127: X9 = PAIR_CDR( X10 ); X10 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( c2568, CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ) ); X7 = scrt1_cons_2a( X8, CONS( EMPTYLIST, EMPTYLIST ) ); X5 = CONS( scrt1_append_2dtwo( X6, X7 ), EMPTYLIST ); X4 = scrt1_cons_2a( c2242, CONS( scrt1_reverse( PAIR_CAR( X2 ) ), X5 ) ); X6 = PAIR_CAR( X2 ); X7 = X6; X8 = EMPTYLIST; X9 = EMPTYLIST; L3131: if ( NEQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L3132; X5 = X8; goto L3140; L3132: if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3135; scrt1__24__car_2derror( X7 ); L3135: X12 = PAIR_CAR( X7 ); X11 = _TSCP( 0 ); X10 = sc_cons( X11, EMPTYLIST ); if ( NEQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L3139; X11 = PAIR_CDR( X7 ); X9 = X10; X8 = X10; X7 = X11; GOBACK( L3131 ); L3139: X11 = PAIR_CDR( X7 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3144; scdebug_error( c2613, c2614, CONS( X9, EMPTYLIST ) ); L3144: X9 = SETGEN( PAIR_CDR( X9 ), X10 ); X7 = X11; GOBACK( L3131 ); L3140: X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( X4, CONS( scrt1_append_2dtwo( X5, X6 ), EMPTYLIST ) ) ); } TSCP scexpnd2_l2635( x2636, e2637 ) TSCP x2636, e2637; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd2_l2635 [inside TOP-LEVEL]" ); X2 = scexpnd2_letrec_2dmacro( x2636 ); X1 = e2637; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2637, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scexpnd2_do_2dmacro_v ); DEFCSTRING( t3147, "SCEXPND2_DO-MACRO" ); EXTERNTSCPP( scrt1_caaddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caaddr_v ); EXTERNTSCPP( scrt1_cdaddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdaddr_v ); TSCP scexpnd2_do_2dmacro( e2640 ) TSCP e2640; { TSCP X18, X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3147 ); X1 = scexpand_islist( e2640, _TSCP( 12 ), EMPTYLIST ); if ( FALSE( X1 ) ) goto L3203; if ( EQ( TSCPTAG( e2640 ), PAIRTAG ) ) goto L3154; scrt1__24__cdr_2derror( e2640 ); L3154: X4 = PAIR_CDR( e2640 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3157; scrt1__24__car_2derror( X4 ); L3157: X3 = PAIR_CAR( X4 ); X2 = scexpand_islist( X3, _TSCP( 0 ), EMPTYLIST ); if ( FALSE( X2 ) ) goto L3203; X3 = scrt1_caddr( e2640 ); if ( FALSE( scexpand_islist( X3, _TSCP( 4 ), EMPTYLIST ) ) ) goto L3203; X4 = PAIR_CDR( e2640 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3167; scrt1__24__car_2derror( X4 ); L3167: X3 = PAIR_CAR( X4 ); X4 = EMPTYLIST; X5 = EMPTYLIST; X6 = EMPTYLIST; X7 = sc_d_2dsymbol_ab4b4447( c2735 ); X8 = scrt1_caaddr( e2640 ); X10 = scrt1_cdaddr( e2640 ); if ( FALSE( X10 ) ) goto L3170; X9 = X10; goto L3171; L3170: X9 = c2738; L3171: X10 = scrt1_cdddr( e2640 ); X6 = CONS( X6, EMPTYLIST ); X5 = CONS( X5, EMPTYLIST ); X4 = CONS( X4, EMPTYLIST ); X11 = scrt1_reverse( X3 ); X12 = X11; L3175: if ( EQ( _S2CUINT( X12 ), _S2CUINT( EMPTYLIST ) ) ) goto L3176; if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L3180; scrt1__24__car_2derror( X12 ); L3180: X13 = PAIR_CAR( X12 ); if ( FALSE( scexpand_islist( X13, _TSCP( 8 ), CONS( _TSCP( 12 ), EMPTYLIST ) ) ) ) goto L3183; if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L3186; scrt1__24__car_2derror( X13 ); L3186: X14 = PAIR_CAR( X13 ); X16 = PAIR_CDR( X13 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L3191; scrt1__24__car_2derror( X16 ); L3191: X15 = PAIR_CAR( X16 ); X17 = PAIR_CDR( X13 ); if ( EQ( TSCPTAG( X17 ), PAIRTAG ) ) goto L3196; scrt1__24__cdr_2derror( X17 ); L3196: if ( FALSE( PAIR_CDR( X17 ) ) ) goto L3198; X16 = scrt1_caddr( X13 ); goto L3199; L3198: X16 = X14; L3199: X17 = sc_cons( X14, PAIR_CAR( X4 ) ); SETGEN( PAIR_CAR( X4 ), X17 ); X17 = sc_cons( X16, PAIR_CAR( X6 ) ); SETGEN( PAIR_CAR( X6 ), X17 ); X17 = sc_cons( X15, PAIR_CAR( X5 ) ); SETGEN( PAIR_CAR( X5 ), X17 ); goto L3184; L3183: scdebug_error( c2659, c2693, CONS( X13, EMPTYLIST ) ); L3184: X12 = PAIR_CDR( X12 ); GOBACK( L3175 ); L3176: X11 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X11 = CONS( scrt1_cons_2a( X7, CONS( scrt1_append_2dtwo( PAIR_CAR( X5 ), X12 ), EMPTYLIST ) ), X11 ); X13 = CONS( EMPTYLIST, EMPTYLIST ); X14 = CONS( EMPTYLIST, EMPTYLIST ); X15 = CONS( EMPTYLIST, EMPTYLIST ); X18 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X17 = scrt1_cons_2a( X7, CONS( scrt1_append_2dtwo( PAIR_CAR( X6 ), X18 ), EMPTYLIST ) ); X16 = scrt1_cons_2a( X17, CONS( EMPTYLIST, EMPTYLIST ) ); X15 = CONS( scrt1_cons_2a( c2568, CONS( scrt1_append_2dtwo( X10, X16 ), EMPTYLIST ) ), X15 ); X16 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X15 = CONS( scrt1_cons_2a( c2568, CONS( scrt1_append_2dtwo( X9, X16 ), EMPTYLIST ) ), X15 ); X14 = CONS( scrt1_cons_2a( c2724, CONS( X8, X15 ) ), X14 ); X12 = scrt1_cons_2a( X7, CONS( scrt1_cons_2a( c2242, CONS( PAIR_CAR( X4 ), X14 ) ), X13 ) ); POPSTACKTRACE( scrt1_cons_2a( c2231, CONS( scrt1_cons_2a( X12, CONS( EMPTYLIST, EMPTYLIST ) ), X11 ) ) ); L3203: POPSTACKTRACE( scdebug_error( c2659, c2166, CONS( c2660, EMPTYLIST ) ) ); } TSCP scexpnd2_l2739( x2740, e2741 ) TSCP x2740, e2741; { TSCP X2, X1; PUSHSTACKTRACE( "scexpnd2_l2739 [inside TOP-LEVEL]" ); X2 = scexpnd2_do_2dmacro( x2740 ); X1 = e2741; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2741, PROCEDURE_CLOSURE( X1 ) ) ); } TSCP scexpnd2_l2743( x2744, e2745 ) TSCP x2744, e2745; { TSCP X1; PUSHSTACKTRACE( "scexpnd2_l2743 [inside TOP-LEVEL]" ); X1 = e2745; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2746, e2745, PROCEDURE_CLOSURE( X1 ) ) ); } TSCP scexpnd2_l2748( x2749, e2750 ) TSCP x2749, e2750; { TSCP X1; PUSHSTACKTRACE( "scexpnd2_l2748 [inside TOP-LEVEL]" ); X1 = e2750; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2751, e2750, PROCEDURE_CLOSURE( X1 ) ) ); } void scdebug__init(); void scrt2__init(); void scrt6__init(); void scrt1__init(); void scexpand__init(); static void init_modules( compiler_version ) char *compiler_version; { scdebug__init(); scrt2__init(); scrt6__init(); scrt1__init(); scexpand__init(); MAXDISPLAY( 0 ); } void scexpnd2__init() { TSCP X1; static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scexpnd2 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2841, ADR( scexpnd2_let_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd2_let_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd2_l2320, EMPTYLIST ); scexpand_install_2dexpander( c2165, X1 ); INITIALIZEVAR( t2962, ADR( scexpnd2_let_2a_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd2_let_2a_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd2_l2442, EMPTYLIST ); scexpand_install_2dexpander( c2359, X1 ); INITIALIZEVAR( t3041, ADR( scexpnd2_let_2a_2dresult_v ), MAKEPROCEDURE( 3, 0, scexpnd2_let_2a_2dresult, EMPTYLIST ) ); INITIALIZEVAR( t3053, ADR( scexpnd2_letrec_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd2_letrec_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd2_l2635, EMPTYLIST ); scexpand_install_2dexpander( c2231, X1 ); INITIALIZEVAR( t3147, ADR( scexpnd2_do_2dmacro_v ), MAKEPROCEDURE( 1, 0, scexpnd2_do_2dmacro, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scexpnd2_l2739, EMPTYLIST ); scexpand_install_2dexpander( c2659, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd2_l2743, EMPTYLIST ); scexpand_install_2dexpander( c2742, X1 ); X1 = MAKEPROCEDURE( 2, 0, scexpnd2_l2748, EMPTYLIST ); scexpand_install_2dexpander( c2747, X1 ); return; } scheme2c-2012.10.14/scrt/scexpnd2.sc000066400000000000000000000156301203736146400166360ustar00rootroot00000000000000;;; This module contains the more macro expanders required by Scheme. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scexpnd2 (top-level)) (include "repdef.sc") ;;; (let ((var init)...) body) ==> ((lambda (var...) body) init...) ;;; ;;; (let var ((v init) ...) body) ==> ;;; (let ((gv init) ....) ;;; (letrec ((var (lambda (v ...) body))) ;;; (var init ...))) ;;; ;;; LET is expanded into a lambda expression. While this may make the ;;; resulting expanded code more difficult to read, later analysis is eased ;;; because there are fewer forms. Variable order is retained to make the ;;; resulting tree easier to compare against the original tree. ;;; ;;; A "named let" is expanded into the appropriate letrec expression. That in ;;; turn is expanded into the appropriate lambda expression when the letrec ;;; is expanded. (define (LET-MACRO exp) (cond ((and (islist exp 3) (islist (cadr exp) 0)) (do ((var-inits (cadr exp) (cdr var-inits)) (vars '()) (inits '())) ((or (not (pair? var-inits)) (not (islist (car var-inits) 2 2)) (not (symbol? (caar var-inits)))) (if var-inits (error 'let "Illegal form: ~s" exp) `((lambda ,(reverse vars) ,@(cddr exp)) ,@(reverse inits)))) (set! vars (cons (caar var-inits) vars)) (set! inits (cons (cadar var-inits) inits)))) ((and (islist exp 4) (symbol? (cadr exp))) (do ((var-inits (caddr exp) (cdr var-inits)) (gvx 0 (+ gvx 1)) (gvs '()) (vars '()) (inits '())) ((or (not (pair? var-inits)) (not (islist (car var-inits) 2 2)) (not (symbol? (caar var-inits)))) (if var-inits (error 'let "Illegal form: ~s" exp) `(let ,(reverse inits) (letrec ((,(cadr exp) (lambda ,(reverse vars) ,@(cdddr exp)))) (,(cadr exp) ,@(reverse gvs)))))) (set! vars (cons (caar var-inits) vars)) (set! gvs (cons (string->uninterned-symbol (format "$_~s" gvx)) gvs)) (set! inits (cons (list (car gvs) (cadar var-inits)) inits)))) (else (error 'let "Illegal form: ~s" exp)))) (install-expander 'LET (lambda (x e) (e (let-macro x) e))) ;;; (let* ((var init)...) body) ==> ((lambda (var) ;;; ((lambda (var) body) init)) ;;; init) ;;; ;;; LET* is expanded into a set of nested lambda expressions. While this may ;;; make the resulting code more difficult to read, later analysis is eased ;;; because there fewer types of forms to analyze. (define (LET*-MACRO exp) (cond ((and (islist exp 3) (islist (cadr exp) 1)) (do ((var-inits (cadr exp) (cdr var-inits)) (vars '()) (inits '())) ((or (not (pair? var-inits)) (not (islist (car var-inits) 2 2)) (not (symbol? (caar var-inits)))) (if var-inits (error 'let* "Illegal form: ~s" exp) (car (let*-result vars inits (cddr exp))))) (set! vars (cons (caar var-inits) vars)) (set! inits (cons (cadar var-inits) inits)))) ((and (islist exp 3) (null? (cadr exp))) `((lambda () ,@(cddr exp)))) (else (error 'let* "Illegal form: ~s" exp)))) (install-expander 'LET* (lambda (x e) (e (let*-macro x) e))) (define (LET*-RESULT vars inits body) (cond ((null? vars) body) (else (let*-result (cdr vars) (cdr inits) `(((lambda (,(car vars)) ,@body) ,(car inits))))))) ;;; (letrec ((var init)...) body) ==> ((lambda (var...) ;;; (set! var init) ...) ;;; (begin body ...)) ;;; undefined ...) ;;; ;;; LETREC is expanded into a lambda expression which first binds the vars to ;;; some undefined value and then evalutes the initialization expressions ;;; within the lambda expression. Note that the order of evaluation is ;;; undefined. (define (LETREC-MACRO exp) (cond ((and (islist exp 3) (islist (cadr exp) 1)) (do ((var-inits (cadr exp) (cdr var-inits)) (vars '()) (sets '())) ((or (not (pair? var-inits)) (not (islist (car var-inits) 2 2)) (not (symbol? (caar var-inits)))) (if var-inits (error 'letrec "Illegal form: ~s" exp) `((lambda ,(reverse vars) ,@(reverse sets) (begin ,@(cddr exp))) ,@(map (lambda (v) 0) vars)))) (set! vars (cons (caar var-inits) vars)) (set! sets (cons `(set! ,@(car var-inits)) sets)))) ((and (islist exp 3) (null? (cadr exp))) `((lambda () ,@(cddr exp)))) (else (error 'letrec "Illegal form: ~s" exp)))) (install-expander 'LETREC (lambda (x e) (e (letrec-macro x) e))) ;;; (do ((v1 i1 s1) ...) (test sequence) body ...) ==> (letrec ...) ;;; ;;; Expands a DO form into the corresponding letrec form. (define (DO-MACRO exp) (cond ((and (islist exp 3) (islist (cadr exp) 0) (islist (caddr exp) 1)) (let ((let-bindings (cadr exp)) (vars '()) (inits '()) (steps '()) (loop (string->uninterned-symbol "doloop")) (test (caaddr exp)) (sequence (or (cdaddr exp) '(#f))) (body (cdddr exp))) (for-each (lambda (var-init-step) (if (islist var-init-step 2 3) (let* ((var (car var-init-step)) (init (cadr var-init-step)) (step (if (cddr var-init-step) (caddr var-init-step) var))) (set! vars (cons var vars)) (set! steps (cons step steps)) (set! inits (cons init inits))) (error 'do "Illegal form:" var-init-step))) (reverse let-bindings)) `(letrec ((,loop (lambda ,vars (if ,test (begin ,@sequence) (begin ,@body (,loop ,@steps)))))) (,loop ,@inits)))) (else (error 'do "Illegal form: ~s" 'exp)))) (install-expander 'DO (lambda (x e) (e (do-macro x) e))) ;;; Dummy macro definitions for module and include forms. (install-expander 'MODULE (lambda (x e) (e '(quote (module *ignored*)) e))) (install-expander 'INCLUDE (lambda (x e) (e '(quote (include *ignored*)) e))) scheme2c-2012.10.14/scrt/sci.c000066400000000000000000000025111203736146400154750ustar00rootroot00000000000000 /* SCHEME->C */ #include int main(); static void init_constants() { } DEFTSCP( scint_start_2drep_v ); DEFCSTRING( t2003, "SCINT_START-REP" ); EXTERNTSCPP( sc_apply_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_apply_2dtwo_v ); EXTERNTSCPP( screp_read_2deval_2dprint, XAL1( TSCP ) ); EXTERNTSCP( screp_read_2deval_2dprint_v ); TSCP scint_start_2drep( c2002 ) TSCP c2002; { PUSHSTACKTRACE( t2003 ); POPSTACKTRACE( sc_apply_2dtwo( screp_read_2deval_2dprint_v, c2002 ) ); } void scint__init(){} void screp__init(); static void init_modules( compiler_version ) char *compiler_version; { screp__init(); MAXDISPLAY( 0 ); } int main( int argc, char **argv ) { static int init = 0; if (init) return 1; init = 1; INITHEAP( 0, argc, argv, scint_start_2drep ); init_constants(); init_modules( "(scint SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2003, ADR( scint_start_2drep_v ), MAKEPROCEDURE( 1, 0, scint_start_2drep, EMPTYLIST ) ); scint_start_2drep( CLARGUMENTS( argc, argv ) ); SCHEMEEXIT(); return 0; } scheme2c-2012.10.14/scrt/sci.sc000066400000000000000000000032351203736146400156640ustar00rootroot00000000000000;;; This file is the "main" program for the SCHEME->C interpreter. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scint (main start-rep) (top-level)) ;;; The following function can be invoked by a "main" program to start a ;;; Scheme interpreter. ;;; ;;; The command line flags recognized are: ;;; ;;; -e echo input on the output file ;;; -nh don't print the header ;;; -np don't print the prompt ;;; -q don't print the result ;;; ;;; All other command-line arguments are ignored. (define (START-REP command-line) (apply read-eval-print command-line)) scheme2c-2012.10.14/scrt/scinit.c000066400000000000000000000564471203736146400162310ustar00rootroot00000000000000/* SCHEME->C - initialization and server interface */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module defines some basic global objects and initializes those parts of the SCHEME->C runtime system which are written in C. For compatibility with other modules, the routines and Scheme globals provided by these routines appear as members of the module "sc". */ /* Definitions for objects within sc */ #include /* for strcmp(), strncmp() */ #include "objects.h" #include "scinit.h" #include "heap.h" #include "apply.h" #include "callcc.h" #include "cio.h" #ifndef NULL #define NULL 0 #endif /* Definitions for objects elsewhere in the Scheme system */ extern TSCP scrt1_reverse( XAL1( TSCP ) ); #ifdef __GNUC__ extern TSCP scdebug_error( XAL3( TSCP, TSCP, TSCP ) ) __attribute__((noreturn)); #else extern TSCP scdebug_error( XAL3( TSCP, TSCP, TSCP ) ); #endif extern TSCP screp__init(); extern TSCP screp_scheme2c( XAL1( TSCP ) ); static void init_procs(); /* Global data structure for this module. */ static S2CINT empty[4]; /* Empty string and empty vector are allocated on a 4-byte boundary from here */ static S2CINT expandfailed = 0; /* Expansion failure flag */ static S2CINT module_initialized = 0; S2CINT sc_timeslice = MAXS2CINT, /* Counter for time slicing. */ sc_timesliceinit = 10000, /* Time slice value */ sc_stackbytes = 5000; /* # of bytes of stack */ char *sc_topofstack, /* Top-of-stack limit. */ *sc_savetopofstack; /* Save it here on stack overflow */ /* Command line arguments and environment variables which control the heap are interpreted by the following functions. */ static char *heapfilename = NULL; /* Pointer to heap file name */ static S2CINT scheap, /* Heap size in megabytes */ scmaxheap, /* Heap allowed to grow this big */ sclimit; /* % at which to do total collection */ /* Get value from either the command line or the environment. */ static char* getargval( S2CINT argc, char *argv[], char* cl, char* env ) { S2CINT i; for (i = 1; i < argc-1; i++) { if (strcmp( argv[ i ], cl ) == 0) return( argv[ i+1 ] ); } return( sc_getenv( env ) ); } /* Convert a string to a number, returning -1 on an error */ static S2CINT getinteger( char* cp ) { S2CINT value = 0; if (*cp == 0) value = -1; while (*cp && *cp >= '0' && *cp <= '9') { value = value*10+*cp-'0'; cp = cp+1; } if (*cp == 0) return( value ); else return( -1 ); } /* Decode all Scheme->C specific arguments. */ static void decodearguments( S2CINT argc, char *argv[] ) { char *val; val = getargval( argc, argv, "-sch", "SCHEAP" ); if (val != NULL) { scheap = getinteger( val ); if (scheap < SCMINHEAP) scheap = SCMINHEAP; if (scheap > SCMAXHEAP) scheap = SCMAXHEAP; } else scheap = SCHEAP; val = getargval( argc, argv, "-scmh", "SCMAXHEAP" ); if (val != NULL) { scmaxheap = getinteger( val ); if (scmaxheap < scheap) scmaxheap = scheap; if (scmaxheap > SCMAXHEAP) scmaxheap = SCMAXHEAP; } else scmaxheap = scheap*5; if (scmaxheap > SCMAXHEAP) scmaxheap = SCMAXHEAP; heapfilename = getargval( argc, argv, "-schf", "SCHEAPFILE" ); val = getargval( argc, argv, "-scgc", "SCGCINFO" ); if (val != NULL) { sc_gcinfo = getinteger( val ); if (sc_gcinfo < 0 || sc_gcinfo > 2) sc_gcinfo = 0; } else sc_gcinfo = 0; val = getargval( argc, argv, "-scl", "SCLIMIT" ); if (val != NULL) { sclimit = getinteger( val ); if (sclimit < MINSCLIMIT) sclimit = SCLIMIT; if (sclimit > MAXSCLIMIT) sclimit = SCLIMIT; } else sclimit = SCLIMIT; } /* The command line arguments passed to a program with a Scheme main are formed into a list of strings by the following function. It is accessed as CLARGUMENTS within the compiler. If an argument of the form: -scm is provided, then a list of command line arguments will not be returned, and the function will be invoked as the "main" program with the command line arguments. All flags of the form: -sc... are reserved for use of the Scheme system and will be deleted from the command line. */ TSCP sc_clarguments( int argc, char *argv[] ) { int i; TSCP argl, main; argl = EMPTYLIST; main = FALSEVALUE; i = 0; while (i < argc) { if (strcmp( argv[ i ], "-scm" ) == 0) { main = sc_string_2d_3esymbol( CSTRING_TSCP( argv[ ++i ] ) ); } else if (strncmp( argv[ i ], "-sc", 3 ) == 0) { i++; } else { argl = sc_cons( CSTRING_TSCP( argv[ i ] ), argl ); } i++; } argl = scrt1_reverse( argl ); if (main != FALSEVALUE) { sc_apply_2dtwo( *T_U( main )->symbol.ptrtovalue, sc_cons( argl, EMPTYLIST ) ); SCHEMEEXIT(); } return( argl ); } /* The client program examines and sets the number of Scheme procedure calls per time slice by the following procedures. */ TSCP sc_time_2dslice_v; TSCP sc_set_2dtime_2dslice_21_v; TSCP sc_time_2dslice() { return( C_FIXED( sc_timesliceinit ) ); } TSCP sc_set_2dtime_2dslice_21( TSCP ticks ) { if (TSCPTAG( ticks ) != FIXNUMTAG || FIXED_C( ticks ) <= 0) sc_error( "SET-TIME-SLICE!", "Argument is not a POSITIVE INTEGER", EMPTYLIST ); sc_timesliceinit = FIXED_C( ticks ); sc_timeslice = sc_timesliceinit; return( ticks ); } /* The client program examines and sets the size of the Scheme stack in bytes by the following procedures. */ TSCP sc_stack_2dsize_v; TSCP sc_set_2dstack_2dsize_21_v; TSCP sc_stack_2dsize() { return( C_FIXED( sc_stackbytes ) ); } TSCP sc_set_2dstack_2dsize_21( TSCP bytes ) { char *ts; if (TSCPTAG( bytes ) != FIXNUMTAG || FIXED_C( bytes ) <= (STACKFUDGE*2)) sc_error( "SET-STACK-SIZE!", "Argument is not a POSITIVE INTEGER >= ~s", LIST1( C_FIXED( STACKFUDGE*2 ) ) ); sc_stackbytes = FIXED_C( bytes ); #ifdef STACK_GROWS_POSITIVE ts = ((char*)sc_stackbase)+sc_stackbytes-STACKFUDGE; #else ts = ((char*)sc_stackbase)-sc_stackbytes+STACKFUDGE; #endif sc_topofstack = ts; return( bytes ); } /* Side tables are allocated by calling the following procedure with the first and last heap pages, and pointers to the pagegeneration, type, lock and link tables. An allocation failure will cause the pointers to be returned as NULL. */ static void allocate_sidetables( S2CINT first, /* heap pages */ S2CINT last, /* Ptrs to ptrs to tbls */ unsigned char **pagegen, unsigned char **type, unsigned char **lock, PAGELINK **link ) { typedef unsigned char uchar; if ( (*pagegen = (uchar*)sc_gettable( (last-first+2)*sizeof( unsigned char ), ~module_initialized )) != NULL && (*type = (uchar*)sc_gettable( (last-first+2)*sizeof( unsigned char ), ~module_initialized )) != NULL && (*lock = (uchar* )sc_gettable( (last-first+2)*sizeof( unsigned char ), ~module_initialized )) != NULL && (*link = (PAGELINK*)sc_gettable( (last-first+2) *sizeof( PAGELINK ), ~module_initialized )) != NULL ) { return; } expandfailed = 1; sc_freetable( *pagegen ); sc_freetable( *type ); sc_freetable( *lock ); sc_freetable( *link ); *pagegen = *type = *lock = NULL; *link = NULL; } /* The following function is called to initialize the heap from scratch. */ #ifdef STDERR_ISNT_UNBUFFERED #include #endif void sc_newheap() { S2CINT i, j, page, pagecnt; TSCP unknown; SCP ep; #ifdef STDERR_ISNT_UNBUFFERED /* Older versions of SunOS (before 4.1.x?) may have a line-buffered * stderr. According to "man stdio" on SunOS 4.1.2 and 5.2, stderr * _should_ be unbuffered nowadays. * If stderr isn't unbuffered, then logging messages written * _before_ the heap has been initialized will cause some malloc-ing, * which in turn confuses the heap management. * This is the place to patch stderr if necessary. */ setbuf(stderr, (char*)0); #endif sc_limit = sclimit; sc_heappages = 0; sc_maxheappages = scmaxheap*(ONEMB/PAGEBYTES); sc_allocatedheappages = 0; sc_getheap( scheap*ONEMB, 1 ); sc_firstphypage = sc_heapblocks.minphypage; sc_firstphypagem1 = sc_firstphypage-1; sc_lastphypage = sc_heapblocks.maxphypage; sc_firstpage = 1; sc_lastpage = PHYPAGE_PAGE( sc_lastphypage ); sc_freepage = sc_firstpage; sc_firstheapp = (S2CINT*)PAGE_ADDRESS( sc_firstpage ); sc_lastheapp = (S2CINT*)(((char*)PAGE_ADDRESS( sc_lastpage ))+ PAGEBYTES-1); sc_current_generation = 3; sc_next_generation = 3; sc_genlist = -1; allocate_sidetables( sc_firstphypage, sc_lastphypage, &sc_pagegeneration, &sc_pagetype, &sc_pagelock, &sc_pagelink ); for (i = 0; i < sc_heapblocks.count; i++) { page = ADDRESS_PAGE( sc_heapblocks.block[ i ].address ); pagecnt = (sc_heapblocks.block[ i ].size)/PAGEBYTES; for (j = 0; j < pagecnt; j++) { sc_pagegeneration[ page+j ] = 1; sc_pagelock[ page+j ] = 0; sc_heappages++; } } sc_initiallink = OKTOSET; sc_conscnt = 0; sc_extobjwords = 0; sc_emptylist = EMPTYLIST; ep = (SCP)((((S2CINT)((char*)&empty[0]))+(sizeof(S2CINT)-1)) & ~(((S2CINT)sizeof(S2CINT))-1)); ep->vector.length = 0; ep->vector.tag = VECTORTAG; sc_emptyvector = U_T( ep, EXTENDEDTAG ); ep = (SCP)(((char*)ep)+sizeof(S2CINT)); ep->string.length = 0; ep->string.tag = STRINGTAG; sc_emptystring = U_T( ep, EXTENDEDTAG ); STRING_CHAR( sc_emptystring, 0 ) = 0; sc_falsevalue = FALSEVALUE; sc_truevalue = TRUEVALUE; sc_eofobject = EOFOBJECT; sc_undefined = UNDEFINED; sc_constants = NULL; sc_globals = NULL; sc_whenfreed = EMPTYLIST; sc_freed = EMPTYLIST; sc_globals = addtoSCPTRS( sc_globals, &sc_freed ); sc_clink = EMPTYLIST; sc_globals = addtoSCPTRS( sc_globals, &sc_clink ); sc_stacktrace = NULL; sc_obarray = sc_make_2dvector( C_FIXED( 1023 ), EMPTYLIST ); sc_initializevar( "*OBARRAY*", &sc_obarray, sc_obarray ); sc_setstdio(); init_procs(); unknown = sc_makeprocedure( 0, 0, sc_unknowncall, EMPTYLIST ); TX_U( unknown )->procedure.required = 255; for (i = 0; i <= 3; i++) { sc_unknownproc[ i ] = unknown; sc_globals = addtoSCPTRS( sc_globals, &sc_unknownproc[ i ] ); } sc_arm_mathtraps(); sc_schememode = STANDALONESCHEME; sc_cioinit(); module_initialized = -1; if (sc_gcinfo) { sc_log_string( "***** SCGCINFO = " ); sc_log_dec( sc_gcinfo ); sc_log_string( " SCHEAP = " ); sc_log_dec( scheap ); sc_log_string( " SCMAXHEAP = " ); sc_log_dec( scmaxheap ); sc_log_string( " SCLIMIT = " ); sc_log_dec( sclimit ); sc_log_string( "\n" ); } } /* The storage described in sc_heapblocks is added to the heap by the following procedure. */ static void addrtoheap( ) { S2CINT first_addr, /* First phy page of new space */ last_addr, /* Last phy page of new space */ i, j, page, pagecnt, new_first, /* New first phy page of heap */ new_last, /* New last phy page of heap */ new_lastpage, /* New last logical page */ delta; /* old first phy page - new first phy page */ /* Pointers to newly allocated pages */ unsigned char *new_pagegeneration, *new_pagetype, *new_pagelock; PAGELINK *new_pagelink; if (sc_heapblocks.count == 0) return; first_addr = sc_heapblocks.minphypage; last_addr = sc_heapblocks.maxphypage; if (first_addr >= sc_firstphypage && last_addr <= sc_lastphypage) { /* Block fits in the side table */ for (i = 0; i < sc_heapblocks.count; i++) { page = ADDRESS_PAGE( sc_heapblocks.block[ i ].address ); if ((j = ((S2CINT)sc_heapblocks.block[ i ].address) & (PAGEBYTES-1))) { page = page+1; } pagecnt = (sc_heapblocks.block[ i ].size-j)/PAGEBYTES; if (sc_gcinfo > 1) { sc_log_string( "***** To heap " ); sc_log_hex( PAGE_ADDRESS( page ) ); sc_log_string( " " ); sc_log_hex( PAGE_ADDRESS( page )+pagecnt*PAGEBYTES-1 ); sc_log_string( "\n" ); } for (j = 0; j < pagecnt; j++) { if (sc_pagegeneration[ page+j ]) { sc_log_string( "***** COLLECT Trying to reallocate page "); sc_log_dec( page+j ); sc_log_string( "\n" ); sc_abort(); } sc_pagegeneration[ page+j ] = 1; sc_pagelock[ page+j ] = 0; } sc_heappages = sc_heappages+pagecnt; } return; } /* Didn't fit, so figure out the new span of pages for the existing heap and the new segments. */ new_first = sc_firstphypage; if (first_addr < new_first) new_first = first_addr; new_last = sc_lastphypage; if (last_addr > new_last) new_last = last_addr; delta = sc_firstphypage-new_first; new_lastpage = new_last-new_first+1; /* Try to allocate the new side tables */ allocate_sidetables( new_first, new_last, &new_pagegeneration, &new_pagetype, &new_pagelock, &new_pagelink ); if (new_pagegeneration == NULL) return; /* Initialize new side tables */ for (i = sc_firstpage; i <= new_lastpage; i++) { new_pagegeneration[ i ] = 0; new_pagelock[ i ] = 0; } /* Copy the old side tables */ for (i = sc_firstpage; i <= sc_lastpage; i++) { new_pagegeneration[ i+delta ] = sc_pagegeneration[ i ]; new_pagetype[ i+delta ] = sc_pagetype[ i ]; new_pagelock[ i+delta ] = sc_pagelock[ i ]; new_pagelink[ i+delta ] = sc_pagelink[ i ]+delta; } /* Flip tables and set new bounds on the heap */ sc_freetable( sc_pagegeneration ); sc_pagegeneration = new_pagegeneration; sc_freetable( sc_pagetype ); sc_pagetype = new_pagetype; sc_freetable( sc_pagelock ); sc_pagelock = new_pagelock; sc_freetable( sc_pagelink ); sc_pagelink = new_pagelink; sc_firstphypage = new_first; sc_firstphypagem1 = new_first-1; sc_lastphypage = new_last; sc_lastpage = new_lastpage; sc_firstheapp = (S2CINT*)PAGE_ADDRESS( sc_firstpage ); sc_lastheapp = (S2CINT*)(((char*)PAGE_ADDRESS( sc_lastpage ))+ PAGEBYTES-1); addrtoheap(); } /* The heap is expanded by calling the following procedure. The boolean result is true iff the heap was expanded. The amount added to the heap is the minimum of: the existing heap size, the amount till the maximum, and 25% of the maximum heap size. */ S2CINT sc_expandheap() { S2CINT old_pages = sc_heappages, /* Existing heap size */ add_pages = sc_heappages; /* # of pages to add */ char *msgheader; if ((sc_collecting == 0) || (sc_collecting && sc_gcinfo == 0)) msgheader = "\n***** COLLECT "; else msgheader = " "; if (sc_heappages >= sc_maxheappages || expandfailed != 0) { if (expandfailed == 0) { sc_log_string( msgheader ); sc_log_string( "cannot further expand heap (" ); sc_log_dec(sc_heappages); sc_log_string( " pages)\n" ); expandfailed = 1; } return( 0 ); } if (add_pages > sc_maxheappages-sc_heappages) add_pages = sc_maxheappages-sc_heappages; if (add_pages > (sc_maxheappages*25)/100) add_pages = (sc_maxheappages*25)/100; if (sc_gcinfo) { sc_log_string( msgheader ); sc_log_string( "heap expanded to " ); } sc_getheap( add_pages*PAGEBYTES, 0 ); if (sc_heapblocks.count == 0) { expandfailed = 1; } else { addrtoheap(); } if (sc_gcinfo) { sc_log_dec( (sc_heappages*PAGEBYTES+ONEMB/2)/ONEMB ); sc_log_string( " MB\n" ); } if (expandfailed != 0) { sc_log_string( msgheader ); sc_log_string( "unable to expand the heap\n" ); } return( sc_heappages != old_pages ); } /* Initialization from a compiled Scheme program. */ void sc_restoreheap( S2CINT desiredheap, int argc, char *argv[], void (*mainproc)() ) { if (module_initialized) return; if (desiredheap && desiredheap > scheap) { scheap = desiredheap; } decodearguments( argc, argv ); sc_newheap(); } /* This initialization function is provided to allow automatic initialization from a Modula-2 program. */ void sc__init() { if (module_initialized) return; decodearguments( 0, (char**)NULL ); sc_newheap(); } /* Routines coded in C call the following function to access the Scheme ERROR function. SYMBOL is a string representing the function name. FORMAT is a string which is a format descriptor. ARGS is a list of TSCP arguments. */ void sc_error( char *symbol, char *format, TSCP args ) { sc_timeslice = 1000000; sc_savetopofstack = sc_topofstack; #ifdef STACK_GROWS_POSITIVE sc_topofstack = (char*)MAXS2CINT; #else sc_topofstack = 0; #endif scdebug_error( sc_string_2d_3esymbol( CSTRING_TSCP( symbol ) ), CSTRING_TSCP( format ), args ); } /* The following function returns informations about the implementation. The form of the function follows a recent proposal on rrrs-authors. The result is a list of strings or #F's of the form: ( . ) */ TSCP sc_implementation_v; TSCP sc_implementation() { return( sc_cons( CSTRING_TSCP( "Scheme->C" ), sc_cons( CSTRING_TSCP( "15mar93jfb" ), sc_cons( #ifdef IMPLEMENTATION_MACHINE CSTRING_TSCP( IMPLEMENTATION_MACHINE ), #else FALSEVALUE, #endif sc_cons( #ifdef IMPLEMENTATION_CPU CSTRING_TSCP( IMPLEMENTATION_CPU ), #else FALSEVALUE, #endif sc_cons( #ifdef IMPLEMENTATION_OS CSTRING_TSCP( IMPLEMENTATION_OS ), #else FALSEVALUE, #endif sc_cons( #ifdef IMPLEMENTATION_FS CSTRING_TSCP( IMPLEMENTATION_FS ), #else FALSEVALUE, #endif EMPTYLIST ) ) ) ) ) ) ); } /* The client program evaluates a Scheme expression by calling the procedure * scheme2c with the following arguments: * * input_expression: null terminated ASCII string containing * a Scheme expression. * * status: evaluation status returned here. * * output: stdout-port contents returned here. * * error: stderr-port contents return here. * * See the Scheme implementation in screp.sc for details. */ void scheme2c( char *input_expression, int *status, char **output, char **error ) { TSCP x; S2CINT *sp; if (module_initialized == 0) { sc__init(); sc_schememode = EMBEDDEDSCHEME; screp__init(); } sc_stoptimer( &sc_idletime ); STACKPTR( sp ); if ((S2CUINT)sp > (S2CUINT)sc_stackbase) { /* Stack was cut back, move sc_stackbase */ sc_stackbase = sp; } sc_topofstack = ((char*)sc_stackbase)-sc_stackbytes+STACKFUDGE; sc_clink = EMPTYLIST; sc_stacktrace = NULL; sc_timeslice = sc_timesliceinit; x = screp_scheme2c( CSTRING_TSCP( input_expression ) ); *status = FIXED_C( PAIR_CAR( x ) ); *output = (char*)&STRING_CHAR( PAIR_CAR( PAIR_CDR( x ) ), 0 ); *error = (char*)&STRING_CHAR( PAIR_CAR( PAIR_CDR( PAIR_CDR( x ) ) ), 0 ); sc_stoptimer( &sc_usertime ); } /* The variables holding the values of the functions defined in this module are initialized by the following procedure. */ static void init_procs() { INITIALIZEVAR( "COLLECT", ADR( sc_collect_v ), MAKEPROCEDURE( 0, 0, sc_collect, EMPTYLIST ) ); INITIALIZEVAR( "COLLECT-ALL", ADR( sc_collect_2dall_v ), MAKEPROCEDURE( 0, 0, sc_collect_2dall, EMPTYLIST ) ); INITIALIZEVAR( "CONS", ADR( sc_cons_v ), MAKEPROCEDURE( 2, 0, sc_cons, EMPTYLIST ) ); INITIALIZEVAR( "WEAK-CONS", ADR( sc_weak_2dcons_v ), MAKEPROCEDURE( 2, 0, sc_weak_2dcons, EMPTYLIST ) ); INITIALIZEVAR( "MAKE-STRING", ADR( sc_make_2dstring_v ), MAKEPROCEDURE( 1, 1, sc_make_2dstring, EMPTYLIST ) ); INITIALIZEVAR( "STRING-COPY", ADR( sc_string_2dcopy_v ), MAKEPROCEDURE( 1, 0, sc_string_2dcopy, EMPTYLIST ) ); INITIALIZEVAR( "MAKE-VECTOR", ADR( sc_make_2dvector_v ), MAKEPROCEDURE( 1, 1, sc_make_2dvector, EMPTYLIST ) ); INITIALIZEVAR( "MAKE-%RECORD", ADR( sc_make_2d_25record_v ), MAKEPROCEDURE( 1, 1, sc_make_2d_25record, EMPTYLIST ) ); INITIALIZEVAR( "C-STRING->STRING", ADR( sc_c_2dstring_2d_3estring_v ), MAKEPROCEDURE( 1, 0, sc_c_2dstring_2d_3estring, EMPTYLIST ) ); INITIALIZEVAR( "STRING->SYMBOL", ADR( sc_string_2d_3esymbol_v ), MAKEPROCEDURE( 1, 0, sc_string_2d_3esymbol, EMPTYLIST ) ); INITIALIZEVAR( "STRING->UNINTERNED-SYMBOL", ADR( sc_d_2dsymbol_ab4b4447_v ), MAKEPROCEDURE( 1, 0, sc_d_2dsymbol_ab4b4447, EMPTYLIST ) ); INITIALIZEVAR( "UNINTERNED-SYMBOL?", ADR( sc_uninterned_2dsymbol_3f_v ), MAKEPROCEDURE( 1, 0, sc_uninterned_2dsymbol_3f, EMPTYLIST ) ); INITIALIZEVAR( "CALL-WITH-CURRENT-CONTINUATION", ADR( sc_ntinuation_1af38b9f_v ), MAKEPROCEDURE( 1, 0, sc_callcc, EMPTYLIST ) ); INITIALIZEVAR( "IMPLEMENTATION-INFORMATION", ADR( sc_implementation_v ), MAKEPROCEDURE( 0, 0, sc_implementation, EMPTYLIST ) ); INITIALIZEVAR( "AFTER-COLLECT", ADR( sc_after_2dcollect_v ), FALSEVALUE ); INITIALIZEVAR( "*FROZEN-OBJECTS*", ADR( sc__2afrozen_2dobjects_2a_v ), EMPTYLIST ); INITIALIZEVAR( "TIME-SLICE", ADR( sc_time_2dslice_v ), MAKEPROCEDURE( 0, 0, sc_time_2dslice, EMPTYLIST ) ); INITIALIZEVAR( "SET-TIME-SLICE!", ADR( sc_set_2dtime_2dslice_21_v ), MAKEPROCEDURE( 1, 0, sc_set_2dtime_2dslice_21, EMPTYLIST ) ); INITIALIZEVAR( "STACK-SIZE", ADR( sc_stack_2dsize_v ), MAKEPROCEDURE( 0, 0, sc_stack_2dsize, EMPTYLIST ) ); INITIALIZEVAR( "SET-STACK-SIZE!", ADR( sc_set_2dstack_2dsize_21_v ), MAKEPROCEDURE( 1, 0, sc_set_2dstack_2dsize_21, EMPTYLIST ) ); INITIALIZEVAR( "COLLECT-INFO", ADR( sc_collect_2dinfo_v ), MAKEPROCEDURE( 0, 0, sc_collect_2dinfo, EMPTYLIST ) ); INITIALIZEVAR( "SET-GCINFO!", ADR( sc_set_2dgcinfo_21_v ), MAKEPROCEDURE( 1, 0, sc_set_2dgcinfo_21, EMPTYLIST ) ); INITIALIZEVAR( "SET-GENERATION-LIMIT!", ADR( sc_2dlimit_21_de4d3427_v ), MAKEPROCEDURE( 1, 0, sc_2dlimit_21_de4d3427, EMPTYLIST ) ); INITIALIZEVAR( "SET-MAXIMUM-HEAP!", ADR( sc_set_2dmaximum_2dheap_21_v ), MAKEPROCEDURE( 1, 0, sc_set_2dmaximum_2dheap_21, EMPTYLIST ) ); INITIALIZEVAR( "TIME-OF-DAY", ADR( sc_time_2dof_2dday_v ), MAKEPROCEDURE( 0, 0, sc_time_2dof_2dday, EMPTYLIST ) ); MAXDISPLAY( 0 ); return; } scheme2c-2012.10.14/scrt/scinit.h000066400000000000000000000044711203736146400162240ustar00rootroot00000000000000/* SCHEME->C */ /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. * All Rights Reserved * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. */ /* This module defines some basic global objects and initializes those parts of the SCHEME->C runtime system which are written in C. Included in this initialization is the construction of the heap and the optional loading of the heap from a file. For compatibility with other modules, the routines and Scheme globals provided by these routines appear as members of the module "sc". */ extern S2CINT sc_timeslice, /* Counter for time slicing. */ sc_timesliceinit; extern char *sc_topofstack, /* Top-of-stack limit. */ *sc_savetopofstack; /* Save limit on overflow. */ extern S2CINT sc_stackbytes; /* # of bytes of stack allocated */ /* Procedural interfaces in this module: */ extern S2CINT sc_expandheap(); extern void sc__init(); #ifdef __GNUC__ extern void sc_error( XAL3( char*, char*, TSCP ) ) __attribute__((noreturn)); #else extern void sc_error( XAL3( char*, char*, TSCP ) ); #endif extern TSCP sc_implementation_v; extern TSCP sc_implementation(); extern void scheme2c( XAL4( char *, int *, char **, char ** ) ); #define LIST1( x ) CONS( x, EMPTYLIST ) #define LIST2( x, y ) CONS( x, CONS( y, EMPTYLIST ) ) scheme2c-2012.10.14/scrt/scqquote.c000066400000000000000000000445621203736146400165770ustar00rootroot00000000000000 /* SCHEME->C */ #include void scqquote__init(); DEFSTATICTSCP( c2426 ); DEFSTATICTSCP( t2512 ); DEFSTATICTSCP( t2513 ); DEFSTATICTSCP( c2402 ); DEFSTATICTSCP( c2391 ); DEFSTATICTSCP( c2378 ); DEFSTATICTSCP( c2334 ); DEFSTATICTSCP( c2306 ); DEFSTATICTSCP( t2514 ); DEFSTATICTSCP( c2299 ); DEFSTATICTSCP( c2222 ); DEFSTATICTSCP( t2515 ); DEFSTATICTSCP( c2221 ); DEFSTATICTSCP( c2202 ); DEFSTATICTSCP( c2173 ); DEFCSTRING( t2516, "Illegal form: ~s" ); DEFSTATICTSCP( c2135 ); DEFSTATICTSCP( c2134 ); static void init_constants() { TSCP X1; c2426 = EMPTYLIST; t2512 = STRINGTOSYMBOL( CSTRING_TSCP( "UNQUOTE-SPLICING" ) ); c2426 = CONS( t2512, c2426 ); t2513 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); c2426 = CONS( t2513, c2426 ); CONSTANTEXP( ADR( c2426 ) ); c2402 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( EMPTYLIST, X1 ); X1 = CONS( t2513, X1 ); c2402 = CONS( X1, c2402 ); CONSTANTEXP( ADR( c2402 ) ); c2391 = STRINGTOSYMBOL( CSTRING_TSCP( "APPEND" ) ); CONSTANTEXP( ADR( c2391 ) ); c2378 = STRINGTOSYMBOL( CSTRING_TSCP( "UNQUOTE-SPLICING" ) ); CONSTANTEXP( ADR( c2378 ) ); c2334 = STRINGTOSYMBOL( CSTRING_TSCP( "LIST->VECTOR" ) ); CONSTANTEXP( ADR( c2334 ) ); c2306 = EMPTYLIST; t2514 = STRINGTOSYMBOL( CSTRING_TSCP( "QUASIQUOTE" ) ); c2306 = CONS( t2514, c2306 ); c2306 = CONS( t2513, c2306 ); CONSTANTEXP( ADR( c2306 ) ); c2299 = STRINGTOSYMBOL( CSTRING_TSCP( "CONS*" ) ); CONSTANTEXP( ADR( c2299 ) ); c2222 = EMPTYLIST; t2515 = STRINGTOSYMBOL( CSTRING_TSCP( "UNQUOTE" ) ); c2222 = CONS( t2515, c2222 ); c2222 = CONS( t2513, c2222 ); CONSTANTEXP( ADR( c2222 ) ); c2221 = STRINGTOSYMBOL( CSTRING_TSCP( "LIST" ) ); CONSTANTEXP( ADR( c2221 ) ); c2202 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2202 ) ); c2173 = STRINGTOSYMBOL( CSTRING_TSCP( "UNQUOTE" ) ); CONSTANTEXP( ADR( c2173 ) ); c2135 = CSTRING_TSCP( t2516 ); CONSTANTEXP( ADR( c2135 ) ); c2134 = STRINGTOSYMBOL( CSTRING_TSCP( "QUASIQUOTE" ) ); CONSTANTEXP( ADR( c2134 ) ); } DEFTSCP( scqquote_quasiquotation_v ); DEFCSTRING( t2517, "QUASIQUOTATION" ); EXTERNTSCPP( scexpand_islist, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scexpand_islist_v ); EXTERNTSCPP( scqquote_template, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scqquote_template_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP scqquote_quasiquotation( d2131, e2132 ) TSCP d2131, e2132; { TSCP X2, X1; PUSHSTACKTRACE( t2517 ); if ( FALSE( scexpand_islist( e2132, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L2519; if ( EQ( TSCPTAG( e2132 ), PAIRTAG ) ) goto L2522; scrt1__24__cdr_2derror( e2132 ); L2522: X2 = PAIR_CDR( e2132 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2525; scrt1__24__car_2derror( X2 ); L2525: X1 = PAIR_CAR( X2 ); POPSTACKTRACE( scqquote_template( d2131, X1 ) ); L2519: POPSTACKTRACE( scdebug_error( c2134, c2135, CONS( e2132, EMPTYLIST ) ) ); } DEFTSCP( scqquote_template_v ); DEFCSTRING( t2527, "SCQQUOTE_TEMPLATE" ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scqquote_vector_2dtemplate, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scqquote_vector_2dtemplate_v ); EXTERNTSCPP( scqquote_list_2dtemplate, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scqquote_list_2dtemplate_v ); TSCP scqquote_template( d2148, e2149 ) TSCP d2148, e2149; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2527 ); L2528: if ( NEQ( TSCPTAG( d2148 ), FIXNUMTAG ) ) goto L2530; if ( NEQ( _S2CUINT( d2148 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L2534; POPSTACKTRACE( e2149 ); L2530: if ( FALSE( scrt2_zero_3f( d2148 ) ) ) goto L2534; POPSTACKTRACE( e2149 ); L2534: X1 = BOOLEAN( EQ( TSCPTAG( e2149 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L2567; if ( EQ( TSCPTAG( e2149 ), PAIRTAG ) ) goto L2544; scrt1__24__car_2derror( e2149 ); L2544: X2 = PAIR_CAR( e2149 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2173 ) ) ) goto L2567; if ( FALSE( scexpand_islist( e2149, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L2546; if ( NEQ( _S2CUINT( d2148 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L2548; if ( BITAND( BITOR( _S2CINT( d2148 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2550; X2 = _TSCP( IDIFFERENCE( _S2CINT( d2148 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2551; L2550: X2 = scrt2__2d_2dtwo( d2148, _TSCP( 4 ) ); L2551: X3 = PAIR_CDR( e2149 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2554; scrt1__24__car_2derror( X3 ); L2554: e2149 = PAIR_CAR( X3 ); d2148 = X2; GOBACK( L2528 ); L2548: if ( BITAND( BITOR( _S2CINT( d2148 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2556; X6 = _TSCP( IDIFFERENCE( _S2CINT( d2148 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2557; L2556: X6 = scrt2__2d_2dtwo( d2148, _TSCP( 4 ) ); L2557: X8 = PAIR_CDR( e2149 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L2560; scrt1__24__car_2derror( X8 ); L2560: X7 = PAIR_CAR( X8 ); X5 = scqquote_template( X6, X7 ); X4 = sc_cons( X5, EMPTYLIST ); X3 = sc_cons( c2222, X4 ); X2 = sc_cons( c2221, X3 ); POPSTACKTRACE( X2 ); L2546: X2 = PAIR_CDR( e2149 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2565; scrt1__24__car_2derror( X2 ); L2565: POPSTACKTRACE( scdebug_error( c2173, c2135, CONS( PAIR_CAR( X2 ), EMPTYLIST ) ) ); L2567: if ( NOT( AND( EQ( TSCPTAG( e2149 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2149 ), VECTORTAG ) ) ) ) goto L2568; POPSTACKTRACE( scqquote_vector_2dtemplate( d2148, e2149 ) ); L2568: if ( NEQ( TSCPTAG( e2149 ), PAIRTAG ) ) goto L2570; POPSTACKTRACE( scqquote_list_2dtemplate( d2148, e2149 ) ); L2570: if ( EQ( TSCPIMMEDIATETAG( e2149 ), CHARACTERTAG ) ) goto L2572; if ( EQ( TSCPTAG( e2149 ), FIXNUMTAG ) ) goto L2574; if ( AND( EQ( TSCPTAG( e2149 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2149 ), DOUBLEFLOATTAG ) ) ) goto L2576; if ( AND( EQ( TSCPTAG( e2149 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2149 ), STRINGTAG ) ) ) goto L2578; X2 = sc_cons( e2149, EMPTYLIST ); X1 = sc_cons( c2202, X2 ); POPSTACKTRACE( X1 ); L2578: POPSTACKTRACE( e2149 ); L2576: POPSTACKTRACE( e2149 ); L2574: POPSTACKTRACE( e2149 ); L2572: POPSTACKTRACE( e2149 ); } DEFTSCP( scqquote_list_2dtemplate_v ); DEFCSTRING( t2581, "SCQQUOTE_LIST-TEMPLATE" ); EXTERNTSCPP( scrt1_caadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caadr_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( scqquote_ice_2dlist_4877f2f4, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scqquote_ice_2dlist_4877f2f4_v ); TSCP scqquote_list_2dtemplate( d2256, e2257 ) TSCP d2256, e2257; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2581 ); X1 = scexpand_islist( e2257, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ); if ( FALSE( X1 ) ) goto L2608; if ( EQ( TSCPTAG( e2257 ), PAIRTAG ) ) goto L2591; scrt1__24__car_2derror( e2257 ); L2591: X2 = PAIR_CAR( e2257 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2202 ) ) ) goto L2608; X3 = PAIR_CDR( e2257 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2598; scrt1__24__car_2derror( X3 ); L2598: X2 = PAIR_CAR( X3 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2608; X2 = scrt1_caadr( e2257 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2134 ) ) ) goto L2608; X3 = PAIR_CDR( e2257 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2604; scrt1__24__car_2derror( X3 ); L2604: X2 = PAIR_CAR( X3 ); POPSTACKTRACE( scqquote_quasiquotation( d2256, X2 ) ); L2608: if ( EQ( TSCPTAG( e2257 ), PAIRTAG ) ) goto L2612; scrt1__24__car_2derror( e2257 ); L2612: X1 = PAIR_CAR( e2257 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2134 ) ) ) goto L2609; if ( NEQ( _S2CUINT( d2256 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L2614; if ( BITAND( BITOR( _S2CINT( d2256 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2616; X1 = _TSCP( IPLUS( _S2CINT( d2256 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2617; L2616: X1 = scrt2__2b_2dtwo( d2256, _TSCP( 4 ) ); L2617: POPSTACKTRACE( scqquote_quasiquotation( X1, e2257 ) ); L2614: if ( BITAND( BITOR( _S2CINT( d2256 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2618; X5 = _TSCP( IPLUS( _S2CINT( d2256 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2619; L2618: X5 = scrt2__2b_2dtwo( d2256, _TSCP( 4 ) ); L2619: X4 = scqquote_quasiquotation( X5, e2257 ); X3 = sc_cons( X4, EMPTYLIST ); X2 = sc_cons( c2306, X3 ); X1 = sc_cons( c2221, X2 ); POPSTACKTRACE( X1 ); L2609: X1 = scqquote_ice_2dlist_4877f2f4( d2256, e2257 ); POPSTACKTRACE( sc_cons( c2299, X1 ) ); } DEFTSCP( scqquote_vector_2dtemplate_v ); DEFCSTRING( t2621, "SCQQUOTE_VECTOR-TEMPLATE" ); EXTERNTSCPP( scrt4_vector_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt4_vector_2d_3elist_v ); TSCP scqquote_vector_2dtemplate( d2330, e2331 ) TSCP d2330, e2331; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2621 ); X5 = scrt4_vector_2d_3elist( e2331 ); X4 = scqquote_ice_2dlist_4877f2f4( d2330, X5 ); X3 = sc_cons( c2299, X4 ); X2 = sc_cons( X3, EMPTYLIST ); X1 = sc_cons( c2334, X2 ); POPSTACKTRACE( X1 ); } DEFTSCP( scqquote_ice_2dlist_4877f2f4_v ); DEFCSTRING( t2624, "SCQQUOTE_TEMPLATE-OR-SPLICE-LIST" ); EXTERNTSCPP( scqquote_r_2dsplice_d5e960a1, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scqquote_r_2dsplice_d5e960a1_v ); TSCP scqquote_ice_2dlist_4877f2f4( d2336, e2337 ) TSCP d2336, e2337; { TSCP X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2624 ); if ( EQ( _S2CUINT( e2337 ), _S2CUINT( EMPTYLIST ) ) ) goto L2626; if ( NEQ( TSCPTAG( e2337 ), PAIRTAG ) ) goto L2628; X1 = PAIR_CAR( e2337 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2173 ) ) ) goto L2630; X2 = scqquote_template( d2336, e2337 ); X1 = sc_cons( X2, EMPTYLIST ); POPSTACKTRACE( X1 ); L2630: X2 = PAIR_CAR( e2337 ); X1 = BOOLEAN( EQ( TSCPTAG( X2 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L2649; X3 = PAIR_CAR( e2337 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2643; scrt1__24__car_2derror( X3 ); L2643: X2 = PAIR_CAR( X3 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2378 ) ) ) goto L2649; X7 = PAIR_CAR( e2337 ); X6 = scqquote_r_2dsplice_d5e960a1( d2336, X7 ); X10 = PAIR_CDR( e2337 ); X9 = scqquote_ice_2dlist_4877f2f4( d2336, X10 ); X8 = sc_cons( c2299, X9 ); X7 = sc_cons( X8, EMPTYLIST ); X5 = sc_cons( X6, X7 ); X4 = sc_cons( c2391, X5 ); X3 = X4; X2 = sc_cons( X3, EMPTYLIST ); POPSTACKTRACE( X2 ); L2628: X2 = scqquote_r_2dsplice_d5e960a1( d2336, e2337 ); X1 = sc_cons( X2, EMPTYLIST ); POPSTACKTRACE( X1 ); L2626: POPSTACKTRACE( c2402 ); L2649: X2 = PAIR_CAR( e2337 ); X1 = scqquote_r_2dsplice_d5e960a1( d2336, X2 ); X3 = PAIR_CDR( e2337 ); X2 = scqquote_ice_2dlist_4877f2f4( d2336, X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); } DEFTSCP( scqquote_r_2dsplice_d5e960a1_v ); DEFCSTRING( t2653, "SCQQUOTE_TEMPLATE-OR-SPLICE" ); TSCP scqquote_r_2dsplice_d5e960a1( d2404, e2405 ) TSCP d2404, e2405; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2653 ); X1 = BOOLEAN( EQ( TSCPTAG( e2405 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L2682; if ( EQ( TSCPTAG( e2405 ), PAIRTAG ) ) goto L2662; scrt1__24__car_2derror( e2405 ); L2662: X2 = PAIR_CAR( e2405 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2378 ) ) ) goto L2682; if ( FALSE( scexpand_islist( e2405, _TSCP( 8 ), CONS( _TSCP( 8 ), EMPTYLIST ) ) ) ) goto L2664; if ( NEQ( _S2CUINT( d2404 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L2666; if ( BITAND( BITOR( _S2CINT( d2404 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2668; X2 = _TSCP( IDIFFERENCE( _S2CINT( d2404 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2669; L2668: X2 = scrt2__2d_2dtwo( d2404, _TSCP( 4 ) ); L2669: X4 = PAIR_CDR( e2405 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L2672; scrt1__24__car_2derror( X4 ); L2672: X3 = PAIR_CAR( X4 ); POPSTACKTRACE( scqquote_template( X2, X3 ) ); L2666: if ( BITAND( BITOR( _S2CINT( d2404 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2674; X9 = _TSCP( IDIFFERENCE( _S2CINT( d2404 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2675; L2674: X9 = scrt2__2d_2dtwo( d2404, _TSCP( 4 ) ); L2675: X11 = PAIR_CDR( e2405 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L2678; scrt1__24__car_2derror( X11 ); L2678: X10 = PAIR_CAR( X11 ); X8 = scqquote_template( X9, X10 ); X7 = sc_cons( X8, EMPTYLIST ); X6 = sc_cons( c2426, X7 ); X5 = sc_cons( c2221, X6 ); X4 = X5; X3 = sc_cons( X4, EMPTYLIST ); X2 = sc_cons( c2221, X3 ); POPSTACKTRACE( X2 ); L2664: POPSTACKTRACE( scdebug_error( c2378, c2135, CONS( e2405, EMPTYLIST ) ) ); L2682: POPSTACKTRACE( scqquote_template( d2404, e2405 ) ); } EXTERNTSCPP( scexpand_install_2dexpander, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scexpand_install_2dexpander_v ); TSCP scqquote_l2459( x2460, e2461 ) TSCP x2460, e2461; { TSCP X2, X1; PUSHSTACKTRACE( "scqquote_l2459 [inside TOP-LEVEL]" ); X2 = scqquote_quasiquotation( _TSCP( 4 ), x2460 ); X1 = e2461; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2461, PROCEDURE_CLOSURE( X1 ) ) ); } void scrt4__init(); void scrt2__init(); void scdebug__init(); void scrt1__init(); void scexpand__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt4__init(); scrt2__init(); scdebug__init(); scrt1__init(); scexpand__init(); MAXDISPLAY( 0 ); } void scqquote__init() { TSCP X1; static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scqquote SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2517, ADR( scqquote_quasiquotation_v ), MAKEPROCEDURE( 2, 0, scqquote_quasiquotation, EMPTYLIST ) ); INITIALIZEVAR( t2527, ADR( scqquote_template_v ), MAKEPROCEDURE( 2, 0, scqquote_template, EMPTYLIST ) ); INITIALIZEVAR( t2581, ADR( scqquote_list_2dtemplate_v ), MAKEPROCEDURE( 2, 0, scqquote_list_2dtemplate, EMPTYLIST ) ); INITIALIZEVAR( t2621, ADR( scqquote_vector_2dtemplate_v ), MAKEPROCEDURE( 2, 0, scqquote_vector_2dtemplate, EMPTYLIST ) ); INITIALIZEVAR( t2624, ADR( scqquote_ice_2dlist_4877f2f4_v ), MAKEPROCEDURE( 2, 0, scqquote_ice_2dlist_4877f2f4, EMPTYLIST ) ); INITIALIZEVAR( t2653, ADR( scqquote_r_2dsplice_d5e960a1_v ), MAKEPROCEDURE( 2, 0, scqquote_r_2dsplice_d5e960a1, EMPTYLIST ) ); X1 = MAKEPROCEDURE( 2, 0, scqquote_l2459, EMPTYLIST ); scexpand_install_2dexpander( c2134, X1 ); return; } scheme2c-2012.10.14/scrt/scqquote.sc000066400000000000000000000064351203736146400167570ustar00rootroot00000000000000;;; The functions in this module implement QUASIQUOTE as defined in section ;;; 7.1.4 of Revised**4. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scqquote (top-level QUASIQUOTATION)) (include "repdef.sc") (define (QUASIQUOTATION d exp) (if (islist exp 2 2) (template d (cadr exp)) (error 'quasiquote "Illegal form: ~s" exp))) (define (TEMPLATE d exp) (cond ((zero? d) exp) ((and (pair? exp) (eq? (car exp) 'unquote)) (if (islist exp 2 2) (if (eq? d 1) (template (- d 1) (cadr exp)) (list 'list ''unquote (template (- d 1) (cadr exp)))) (error 'unquote "Illegal form: ~s" (cadr exp)))) ((vector? exp) (vector-template d exp)) ((pair? exp) (list-template d exp)) ((or (char? exp) (number? exp) (string? exp)) exp) (else (list 'quote exp)))) (define (LIST-TEMPLATE d exp) (cond ((and (islist exp 2 2) (eq? (car exp) 'quote) (pair? (cadr exp)) (eq? (caadr exp) 'quasiquote)) (quasiquotation d (cadr exp))) ((eq? (car exp) 'quasiquote) (if (eq? d 0) (quasiquotation (+ d 1) exp) (list 'list ''quasiquote (quasiquotation (+ d 1) exp)))) (else (cons 'cons* (template-or-splice-list d exp))))) (define (VECTOR-TEMPLATE d exp) (list 'list->vector (cons 'cons* (template-or-splice-list d (vector->list exp))))) (define (TEMPLATE-OR-SPLICE-LIST d exp) (cond ((null? exp) '('())) ((pair? exp) (cond ((eq? (car exp) 'unquote) (list (template d exp))) ((and (pair? (car exp)) (eq? (caar exp) 'unquote-splicing)) (list (list 'append (template-or-splice d (car exp)) (cons 'cons* (template-or-splice-list d (cdr exp)))))) (else (cons (template-or-splice d (car exp)) (template-or-splice-list d (cdr exp)))))) (else (list (template-or-splice d exp))))) (define (TEMPLATE-OR-SPLICE d exp) (if (and (pair? exp) (eq? (car exp) 'unquote-splicing)) (if (islist exp 2 2) (if (eq? d 1) (template (- d 1) (cadr exp)) (list 'list (list 'list ''unquote-splicing (template (- d 1) (cadr exp))))) (error 'unquote-splicing "Illegal form: ~s" exp)) (template d exp))) (install-expander 'QUASIQUOTE (lambda (x e) (e (quasiquotation 1 x) e))) scheme2c-2012.10.14/scrt/screp.c000066400000000000000000001056611203736146400160450ustar00rootroot00000000000000 /* SCHEME->C */ #include void screp__init(); DEFCSTRING( t2482, "~s form ignored~%" ); DEFSTATICTSCP( c2373 ); DEFCSTRING( t2483, "~s~%" ); DEFSTATICTSCP( c2371 ); DEFSTATICTSCP( c2369 ); DEFSTATICTSCP( t2484 ); DEFSTATICTSCP( t2485 ); DEFCSTRING( t2486, "~a~%" ); DEFSTATICTSCP( c2316 ); DEFCSTRING( t2487, "-emacs" ); DEFSTATICTSCP( c2301 ); DEFSTATICTSCP( c2300 ); DEFSTATICTSCP( c2274 ); DEFSTATICTSCP( c2261 ); DEFSTATICTSCP( c2248 ); DEFCSTRING( t2488, "Development Company" ); DEFSTATICTSCP( c2237 ); DEFCSTRING( t2489, "Copyright 1989-1993 Hewlett-Packard" ); DEFSTATICTSCP( c2236 ); DEFCSTRING( t2490, "~a -- ~a -- ~a ~a" ); DEFSTATICTSCP( c2221 ); DEFCSTRING( t2491, "-nh" ); DEFSTATICTSCP( c2220 ); DEFSTATICTSCP( c2217 ); DEFCSTRING( t2492, "> " ); DEFSTATICTSCP( c2206 ); DEFCSTRING( t2493, "-np" ); DEFSTATICTSCP( c2205 ); DEFCSTRING( t2494, "-q" ); DEFSTATICTSCP( c2202 ); DEFSTATICTSCP( c2200 ); DEFCSTRING( t2495, "-e" ); DEFSTATICTSCP( c2196 ); DEFSTATICTSCP( c2194 ); DEFSTATICTSCP( c2188 ); DEFCSTRING( t2496, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2153 ); DEFSTATICTSCP( c2152 ); static void init_constants() { c2373 = CSTRING_TSCP( t2482 ); CONSTANTEXP( ADR( c2373 ) ); c2371 = CSTRING_TSCP( t2483 ); CONSTANTEXP( ADR( c2371 ) ); c2369 = EMPTYLIST; t2484 = STRINGTOSYMBOL( CSTRING_TSCP( "INCLUDE" ) ); c2369 = CONS( t2484, c2369 ); t2485 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); c2369 = CONS( t2485, c2369 ); CONSTANTEXP( ADR( c2369 ) ); c2316 = CSTRING_TSCP( t2486 ); CONSTANTEXP( ADR( c2316 ) ); c2301 = CSTRING_TSCP( t2487 ); CONSTANTEXP( ADR( c2301 ) ); c2300 = STRINGTOSYMBOL( CSTRING_TSCP( "INTERACTIVE" ) ); CONSTANTEXP( ADR( c2300 ) ); c2274 = STRINGTOSYMBOL( CSTRING_TSCP( "RESULT" ) ); CONSTANTEXP( ADR( c2274 ) ); c2261 = STRINGTOSYMBOL( CSTRING_TSCP( "ENV" ) ); CONSTANTEXP( ADR( c2261 ) ); c2248 = STRINGTOSYMBOL( CSTRING_TSCP( "HEADER" ) ); CONSTANTEXP( ADR( c2248 ) ); c2237 = CSTRING_TSCP( t2488 ); CONSTANTEXP( ADR( c2237 ) ); c2236 = CSTRING_TSCP( t2489 ); CONSTANTEXP( ADR( c2236 ) ); c2221 = CSTRING_TSCP( t2490 ); CONSTANTEXP( ADR( c2221 ) ); c2220 = CSTRING_TSCP( t2491 ); CONSTANTEXP( ADR( c2220 ) ); c2217 = STRINGTOSYMBOL( CSTRING_TSCP( "PROMPT" ) ); CONSTANTEXP( ADR( c2217 ) ); c2206 = CSTRING_TSCP( t2492 ); CONSTANTEXP( ADR( c2206 ) ); c2205 = CSTRING_TSCP( t2493 ); CONSTANTEXP( ADR( c2205 ) ); c2202 = CSTRING_TSCP( t2494 ); CONSTANTEXP( ADR( c2202 ) ); c2200 = STRINGTOSYMBOL( CSTRING_TSCP( "QUIET" ) ); CONSTANTEXP( ADR( c2200 ) ); c2196 = CSTRING_TSCP( t2495 ); CONSTANTEXP( ADR( c2196 ) ); c2194 = STRINGTOSYMBOL( CSTRING_TSCP( "ECHO" ) ); CONSTANTEXP( ADR( c2194 ) ); c2188 = STRINGTOSYMBOL( CSTRING_TSCP( "LOAD" ) ); CONSTANTEXP( ADR( c2188 ) ); c2153 = CSTRING_TSCP( t2496 ); CONSTANTEXP( ADR( c2153 ) ); c2152 = STRINGTOSYMBOL( CSTRING_TSCP( "EXIT" ) ); CONSTANTEXP( ADR( c2152 ) ); } DEFTSCP( screp_reset_v ); DEFCSTRING( t2497, "RESET" ); DEFTSCP( screp_top_2dlevel_v ); DEFCSTRING( t2498, "TOP-LEVEL" ); DEFTSCP( screp_default_2dexit_v ); DEFCSTRING( t2499, "SCREP_DEFAULT-EXIT" ); EXTERNTSCPP( sc_osexit, XAL1( TSCP ) ); EXTERNTSCP( sc_osexit_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP screp_default_2dexit( x2132 ) TSCP x2132; { TSCP X2, X1; PUSHSTACKTRACE( t2499 ); if ( NEQ( _S2CUINT( x2132 ), _S2CUINT( EMPTYLIST ) ) ) goto L2501; POPSTACKTRACE( sc_osexit( _TSCP( 0 ) ) ); L2501: if ( EQ( TSCPTAG( x2132 ), PAIRTAG ) ) goto L2504; scrt1__24__car_2derror( x2132 ); L2504: X1 = PAIR_CAR( x2132 ); X2 = BOOLEAN( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ); if ( TRUE( X2 ) ) goto L2511; if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), DOUBLEFLOATTAG ) ) ) goto L2511; POPSTACKTRACE( scdebug_error( c2152, c2153, CONS( PAIR_CAR( x2132 ), EMPTYLIST ) ) ); L2511: X1 = PAIR_CAR( x2132 ); POPSTACKTRACE( sc_osexit( X1 ) ); } DEFTSCP( screp_exit_v ); DEFCSTRING( t2516, "EXIT" ); TSCP screp_l2163( ) { PUSHSTACKTRACE( "screp_l2163 [inside TOP-LEVEL]" ); POPSTACKTRACE( screp_default_2dexit( CONS( _TSCP( 4 ), EMPTYLIST ) ) ); } DEFTSCP( screp__2aemacscheme_2a_v ); DEFCSTRING( t2518, "SCREP_*EMACSCHEME*" ); DEFTSCP( screp__2areading_2dstdin_2a_v ); DEFCSTRING( t2519, "SCREP_*READING-STDIN*" ); DEFTSCP( screp_read_2deval_2dprint_v ); DEFCSTRING( t2520, "READ-EVAL-PRINT" ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( scrt4_signal, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_signal_v ); EXTERNTSCP( scdebug_trace_2dlevel_v ); EXTERNTSCP( scrt5_rt_2dvalue_e3d6f738_v ); EXTERNTSCP( scrt5_rt_2dvalue_c91906c5_v ); EXTERNTSCPP( scrt1_member, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_member_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCP( sc_implementation_v ); TSCP screp_l2277( x2278, c2586 ) TSCP x2278, c2586; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "screp_l2277 [inside READ-EVAL-PRINT]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c2586, 0 ); X2 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c2586, 1 ); if ( FALSE( x2278 ) ) goto L2588; if ( EQ( TSCPTAG( x2278 ), PAIRTAG ) ) goto L2591; scrt1__24__car_2derror( x2278 ); L2591: X4 = PAIR_CAR( x2278 ); SETGEN( PAIR_CAR( DISPLAY( 0 ) ), X4 ); L2588: X4 = DISPLAY( 2 ); X4 = UNKNOWNCALL( X4, 1 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( FALSEVALUE, PROCEDURE_CLOSURE( X4 ) ); DISPLAY( 0 ) = X1; DISPLAY( 2 ) = X2; POPSTACKTRACE( X3 ); } EXTERNTSCP( scdebug_proceed_v ); TSCP screp_l2283( x2284, c2593 ) TSCP x2284, c2593; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "screp_l2283 [inside READ-EVAL-PRINT]" ); X1 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c2593, 0 ); if ( NEQ( _S2CUINT( x2284 ), _S2CUINT( EMPTYLIST ) ) ) goto L2595; X4 = FALSEVALUE; goto L2596; L2595: if ( EQ( TSCPTAG( x2284 ), PAIRTAG ) ) goto L2598; scrt1__24__car_2derror( x2284 ); L2598: X4 = PAIR_CAR( x2284 ); L2596: X3 = DISPLAY( 2 ); X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( X4, PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 2 ) = X1; POPSTACKTRACE( X2 ); } TSCP screp_m2182( e2276, c2584 ) TSCP e2276, c2584; { TSCP X2, X1; TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( "MAKE-EXIT [inside READ-EVAL-PRINT]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c2584, 0 ); DISPLAY( 2 ) = e2276; scdebug_proceed_v = MAKEPROCEDURE( 0, 1, screp_l2277, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 0 ), DISPLAY( 2 ) ) ); screp_exit_v = MAKEPROCEDURE( 0, 1, screp_l2283, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 2 ) ) ); X2 = TRUEVALUE; DISPLAY( 0 ) = X1; SDVAL = X2; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } TSCP screp_l2298( c2605 ) TSCP c2605; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "screp_l2298 [inside READ-EVAL-PRINT]" ); X1 = DISPLAY( 3 ); DISPLAY( 3 ) = CLOSURE_VAR( c2605, 0 ); X2 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c2605, 1 ); screp_exit_v = DISPLAY( 3 ); X4 = DISPLAY( 2 ); X4 = UNKNOWNCALL( X4, 1 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( FALSEVALUE, PROCEDURE_CLOSURE( X4 ) ); DISPLAY( 3 ) = X1; DISPLAY( 2 ) = X2; POPSTACKTRACE( X3 ); } TSCP screp_m2183( r2295, c2600 ) TSCP r2295, c2600; { TSCP X2, X1; TSCP SD2 = DISPLAY( 2 ); TSCP SD3 = DISPLAY( 3 ); TSCP SDVAL; PUSHSTACKTRACE( "MAKE-RESET [inside READ-EVAL-PRINT]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c2600, 0 ); DISPLAY( 2 ) = r2295; if ( TRUE( PAIR_CAR( DISPLAY( 1 ) ) ) ) goto L2602; DISPLAY( 3 ) = screp_exit_v; screp_reset_v = MAKEPROCEDURE( 0, 0, screp_l2298, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 3 ), DISPLAY( 2 ) ) ); L2602: X2 = TRUEVALUE; DISPLAY( 1 ) = X1; SDVAL = X2; DISPLAY( 2 ) = SD2; DISPLAY( 3 ) = SD3; POPSTACKTRACE( SDVAL ); } EXTERNTSCP( sc_ntinuation_1af38b9f_v ); EXTERNTSCPP( scdebug_on_2dinterrupt, XAL1( TSCP ) ); EXTERNTSCP( scdebug_on_2dinterrupt_v ); EXTERNTSCPP( scrt6_echo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_echo_v ); EXTERNTSCP( scrt5_stdout_2dport_v ); EXTERNTSCPP( sc_set_2dscheme_2dmode_21, XAL1( TSCP ) ); EXTERNTSCP( sc_set_2dscheme_2dmode_21_v ); EXTERNTSCP( scdebug_2derror_2a_ca4047fd_v ); TSCP screp_l2304( c2629 ) TSCP c2629; { TSCP X3, X2, X1; PUSHSTACKTRACE( "screp_l2304 [inside READ-EVAL-PRINT]" ); X1 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c2629, 0 ); scdebug_2derror_2a_ca4047fd_v = TRUEVALUE; screp_reset_v = DISPLAY( 2 ); X3 = screp_reset_v; X3 = UNKNOWNCALL( X3, 0 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 2 ) = X1; POPSTACKTRACE( X2 ); } EXTERNTSCPP( scdebug__2dhandler_7d8722d5, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug__2dhandler_7d8722d5_v ); EXTERNTSCP( scdebug__2aerror_2dhandler_2a_v ); EXTERNTSCPP( screp_rep, XAL5( TSCP, TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( screp_rep_v ); EXTERNTSCPP( scrt5_current_2dinput_2dport, XAL0( ) ); EXTERNTSCP( scrt5_current_2dinput_2dport_v ); EXTERNTSCP( scrt5_stdin_2dport_v ); TSCP screp_read_2deval_2dprint( f2167 ) TSCP f2167; { TSCP X18, X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( t2520 ); X1 = _TSCP( 0 ); X2 = _TSCP( 0 ); DISPLAY( 0 ) = _TSCP( 0 ); DISPLAY( 1 ) = _TSCP( 0 ); X3 = _TSCP( 0 ); X4 = _TSCP( 0 ); X5 = _TSCP( 0 ); X6 = _TSCP( 0 ); X7 = _TSCP( 0 ); X8 = _TSCP( 0 ); X9 = _TSCP( 0 ); X10 = _TSCP( 0 ); X11 = _TSCP( 0 ); X12 = _TSCP( 0 ); X13 = _TSCP( 0 ); X13 = CONS( X13, EMPTYLIST ); X12 = CONS( X12, EMPTYLIST ); X11 = CONS( X11, EMPTYLIST ); X10 = CONS( X10, EMPTYLIST ); X9 = CONS( X9, EMPTYLIST ); X8 = CONS( X8, EMPTYLIST ); X7 = CONS( X7, EMPTYLIST ); X6 = CONS( X6, EMPTYLIST ); X5 = CONS( X5, EMPTYLIST ); X4 = CONS( X4, EMPTYLIST ); X3 = CONS( X3, EMPTYLIST ); DISPLAY( 1 ) = CONS( DISPLAY( 1 ), EMPTYLIST ); DISPLAY( 0 ) = CONS( DISPLAY( 0 ), EMPTYLIST ); X2 = CONS( X2, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); X14 = screp_exit_v; SETGEN( PAIR_CAR( X13 ), X14 ); X14 = screp_reset_v; SETGEN( PAIR_CAR( X12 ), X14 ); if ( FALSE( scrt1_memq( c2188, f2167 ) ) ) goto L2523; X15 = FALSEVALUE; goto L2524; L2523: X15 = TRUEVALUE; L2524: if ( FALSE( X15 ) ) goto L2526; X14 = scrt4_signal( _TSCP( 8 ), _TSCP( 4 ) ); goto L2527; L2526: X14 = X15; L2527: SETGEN( PAIR_CAR( X11 ), X14 ); X14 = scdebug_trace_2dlevel_v; SETGEN( PAIR_CAR( X10 ), X14 ); X14 = scrt5_rt_2dvalue_e3d6f738_v; SETGEN( PAIR_CAR( X9 ), X14 ); X14 = scrt5_rt_2dvalue_c91906c5_v; SETGEN( PAIR_CAR( X8 ), X14 ); X15 = scrt1_member( c2194, f2167 ); if ( FALSE( X15 ) ) goto L2529; X14 = X15; goto L2530; L2529: X14 = scrt1_member( c2196, f2167 ); L2530: SETGEN( PAIR_CAR( X7 ), X14 ); X15 = scrt1_member( c2200, f2167 ); if ( FALSE( X15 ) ) goto L2532; X14 = X15; goto L2533; L2532: X14 = scrt1_member( c2202, f2167 ); L2533: SETGEN( PAIR_CAR( X6 ), X14 ); X15 = scrt1_member( c2217, f2167 ); if ( FALSE( X15 ) ) goto L2535; if ( EQ( TSCPTAG( X15 ), PAIRTAG ) ) goto L2538; scrt1__24__cdr_2derror( X15 ); L2538: X16 = PAIR_CDR( X15 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L2541; scrt1__24__car_2derror( X16 ); L2541: X14 = PAIR_CAR( X16 ); goto L2544; L2535: if ( FALSE( scrt1_member( c2205, f2167 ) ) ) goto L2543; X14 = FALSEVALUE; goto L2544; L2543: X14 = c2206; L2544: SETGEN( PAIR_CAR( X5 ), X14 ); X15 = scrt1_member( c2248, f2167 ); if ( FALSE( X15 ) ) goto L2546; if ( EQ( TSCPTAG( X15 ), PAIRTAG ) ) goto L2549; scrt1__24__cdr_2derror( X15 ); L2549: X16 = PAIR_CDR( X15 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L2552; scrt1__24__car_2derror( X16 ); L2552: X14 = PAIR_CAR( X16 ); goto L2555; L2546: if ( FALSE( scrt1_member( c2220, f2167 ) ) ) goto L2554; X14 = FALSEVALUE; goto L2555; L2554: X16 = CONS( c2237, EMPTYLIST ); X16 = CONS( c2236, X16 ); X18 = sc_implementation_v; X18 = UNKNOWNCALL( X18, 0 ); X17 = VIA( PROCEDURE_CODE( X18 ) )( PROCEDURE_CLOSURE( X18 ) ); if ( EQ( TSCPTAG( X17 ), PAIRTAG ) ) goto L2558; scrt1__24__cdr_2derror( X17 ); L2558: X18 = PAIR_CDR( X17 ); if ( EQ( TSCPTAG( X18 ), PAIRTAG ) ) goto L2561; scrt1__24__car_2derror( X18 ); L2561: X16 = CONS( PAIR_CAR( X18 ), X16 ); X18 = sc_implementation_v; X18 = UNKNOWNCALL( X18, 0 ); X17 = VIA( PROCEDURE_CODE( X18 ) )( PROCEDURE_CLOSURE( X18 ) ); if ( EQ( TSCPTAG( X17 ), PAIRTAG ) ) goto L2564; scrt1__24__car_2derror( X17 ); L2564: X14 = scrt6_format( c2221, CONS( PAIR_CAR( X17 ), X16 ) ); L2555: SETGEN( PAIR_CAR( X4 ), X14 ); X15 = scrt1_member( c2261, f2167 ); if ( FALSE( X15 ) ) goto L2567; if ( EQ( TSCPTAG( X15 ), PAIRTAG ) ) goto L2570; scrt1__24__cdr_2derror( X15 ); L2570: X16 = PAIR_CDR( X15 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L2573; scrt1__24__car_2derror( X16 ); L2573: X14 = PAIR_CAR( X16 ); goto L2568; L2567: X14 = EMPTYLIST; L2568: SETGEN( PAIR_CAR( X3 ), X14 ); X14 = scrt1_memq( c2188, f2167 ); SETGEN( PAIR_CAR( DISPLAY( 1 ) ), X14 ); X15 = scrt1_member( c2274, f2167 ); if ( FALSE( X15 ) ) goto L2576; if ( EQ( TSCPTAG( X15 ), PAIRTAG ) ) goto L2579; scrt1__24__cdr_2derror( X15 ); L2579: X16 = PAIR_CDR( X15 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L2582; scrt1__24__car_2derror( X16 ); L2582: X14 = PAIR_CAR( X16 ); goto L2577; L2576: X14 = FALSEVALUE; L2577: SETGEN( PAIR_CAR( DISPLAY( 0 ) ), X14 ); X14 = MAKEPROCEDURE( 1, 0, screp_m2182, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( X2 ), X14 ); X14 = MAKEPROCEDURE( 1, 0, screp_m2183, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 1 ) ) ); SETGEN( PAIR_CAR( X1 ), X14 ); X14 = sc_ntinuation_1af38b9f_v; X14 = UNKNOWNCALL( X14, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X14 ) )( PAIR_CAR( X2 ), PROCEDURE_CLOSURE( X14 ) ) ) ) goto L2608; X14 = sc_ntinuation_1af38b9f_v; X14 = UNKNOWNCALL( X14, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X14 ) )( PAIR_CAR( X1 ), PROCEDURE_CLOSURE( X14 ) ) ) ) goto L2611; if ( TRUE( PAIR_CAR( DISPLAY( 1 ) ) ) ) goto L2616; if ( EQ( _S2CUINT( PAIR_CAR( X11 ) ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L2616; scrt4_signal( _TSCP( 8 ), scdebug_on_2dinterrupt_v ); L2616: if ( FALSE( PAIR_CAR( X7 ) ) ) goto L2618; scrt6_echo( PAIR_CAR( X9 ), CONS( PAIR_CAR( X8 ), EMPTYLIST ) ); L2618: if ( FALSE( PAIR_CAR( X4 ) ) ) goto L2612; X14 = CONS( PAIR_CAR( X4 ), EMPTYLIST ); scrt6_format( scrt5_stdout_2dport_v, CONS( c2316, X14 ) ); goto L2612; L2611: scrt5_rt_2dvalue_e3d6f738_v = PAIR_CAR( X9 ); scrt5_rt_2dvalue_c91906c5_v = PAIR_CAR( X8 ); scdebug_trace_2dlevel_v = PAIR_CAR( X10 ); L2612: if ( TRUE( screp_top_2dlevel_v ) ) goto L2625; if ( TRUE( PAIR_CAR( DISPLAY( 1 ) ) ) ) goto L2625; sc_set_2dscheme_2dmode_21( c2300 ); screp__2aemacscheme_2a_v = scrt1_member( c2301, f2167 ); DISPLAY( 2 ) = screp_reset_v; screp_top_2dlevel_v = MAKEPROCEDURE( 0, 0, screp_l2304, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 2 ) ) ); scdebug__2aerror_2dhandler_2a_v = scdebug__2dhandler_7d8722d5_v; scdebug_2derror_2a_ca4047fd_v = TRUEVALUE; L2625: if ( FALSE( PAIR_CAR( DISPLAY( 1 ) ) ) ) goto L2631; X14 = scrt5_current_2dinput_2dport( ); goto L2632; L2631: X14 = scrt5_stdin_2dport_v; L2632: screp_rep( PAIR_CAR( X3 ), X14, scrt5_stdout_2dport_v, PAIR_CAR( X5 ), PAIR_CAR( X6 ) ); L2608: if ( TRUE( PAIR_CAR( DISPLAY( 1 ) ) ) ) goto L2633; scrt4_signal( _TSCP( 8 ), PAIR_CAR( X11 ) ); L2633: if ( FALSE( PAIR_CAR( X7 ) ) ) goto L2635; scrt6_echo( PAIR_CAR( X9 ), CONS( FALSEVALUE, EMPTYLIST ) ); L2635: screp_exit_v = PAIR_CAR( X13 ); screp_reset_v = PAIR_CAR( X12 ); scdebug_trace_2dlevel_v = PAIR_CAR( X10 ); SDVAL = PAIR_CAR( DISPLAY( 0 ) ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } DEFTSCP( screp_flush_2dwhite_v ); DEFCSTRING( t2637, "SCREP_FLUSH-WHITE" ); EXTERNTSCPP( scrt6_char_2dready_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_char_2dready_3f_v ); EXTERNTSCPP( scrt6_peek_2dchar, XAL1( TSCP ) ); EXTERNTSCP( scrt6_peek_2dchar_v ); EXTERNTSCPP( scrt6_eof_2dobject_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_eof_2dobject_3f_v ); EXTERNTSCPP( scrt3_char_2dwhitespace_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt3_char_2dwhitespace_3f_v ); EXTERNTSCPP( scrt6_read_2dchar, XAL1( TSCP ) ); EXTERNTSCP( scrt6_read_2dchar_v ); TSCP screp_flush_2dwhite( i2324 ) TSCP i2324; { TSCP X2, X1; PUSHSTACKTRACE( t2637 ); L2638: X2 = scrt6_char_2dready_3f( CONS( i2324, EMPTYLIST ) ); if ( FALSE( X2 ) ) goto L2640; X1 = scrt6_peek_2dchar( CONS( i2324, EMPTYLIST ) ); goto L2641; L2640: X1 = X2; L2641: if ( FALSE( X1 ) ) goto L2643; if ( TRUE( scrt6_eof_2dobject_3f( X1 ) ) ) goto L2645; if ( FALSE( scrt3_char_2dwhitespace_3f( X1 ) ) ) goto L2647; scrt6_read_2dchar( CONS( i2324, EMPTYLIST ) ); GOBACK( L2638 ); L2647: POPSTACKTRACE( FALSEVALUE ); L2645: POPSTACKTRACE( FALSEVALUE ); L2643: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( screp_rep_v ); DEFCSTRING( t2650, "SCREP_REP" ); EXTERNTSCPP( scrt6_display, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_display_v ); EXTERNTSCPP( scrt6_read, XAL1( TSCP ) ); EXTERNTSCP( scrt6_read_v ); EXTERNTSCPP( scrt6_newline, XAL1( TSCP ) ); EXTERNTSCP( scrt6_newline_v ); EXTERNTSCPP( sceval_eval, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sceval_eval_v ); TSCP screp_rep( e2341, i2342, o2343, p2344, q2345 ) TSCP e2341, i2342, o2343, p2344, q2345; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t2650 ); X1 = FALSEVALUE; L2653: X1 = CONS( X1, EMPTYLIST ); screp_flush_2dwhite( i2342 ); if ( FALSE( p2344 ) ) goto L2656; if ( TRUE( scrt6_char_2dready_3f( CONS( i2342, EMPTYLIST ) ) ) ) goto L2656; scrt6_display( p2344, CONS( o2343, EMPTYLIST ) ); L2656: screp__2areading_2dstdin_2a_v = BOOLEAN( EQ( _S2CUINT( i2342 ), _S2CUINT( scrt5_stdin_2dport_v ) ) ); X2 = scrt6_read( CONS( i2342, EMPTYLIST ) ); SETGEN( PAIR_CAR( X1 ), X2 ); screp__2areading_2dstdin_2a_v = FALSEVALUE; if ( FALSE( scrt6_eof_2dobject_3f( PAIR_CAR( X1 ) ) ) ) goto L2658; if ( FALSE( p2344 ) ) goto L2660; POPSTACKTRACE( scrt6_newline( CONS( o2343, EMPTYLIST ) ) ); L2660: POPSTACKTRACE( FALSEVALUE ); L2658: X2 = BOOLEAN( EQ( TSCPTAG( PAIR_CAR( X1 ) ), PAIRTAG ) ); if ( FALSE( X2 ) ) goto L2677; X4 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L2669; scrt1__24__car_2derror( X4 ); L2669: X3 = PAIR_CAR( X4 ); if ( FALSE( scrt1_memq( X3, c2369 ) ) ) goto L2677; screp_flush_2dwhite( i2342 ); if ( TRUE( q2345 ) ) goto L2672; X4 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L2675; scrt1__24__car_2derror( X4 ); L2675: X3 = CONS( PAIR_CAR( X4 ), EMPTYLIST ); scrt6_format( o2343, CONS( c2373, X3 ) ); L2672: X1 = FALSEVALUE; GOBACK( L2653 ); L2677: if ( FALSE( screp__2aemacscheme_2a_v ) ) goto L2679; scrt6_newline( CONS( o2343, EMPTYLIST ) ); L2679: X2 = sceval_eval( PAIR_CAR( X1 ), CONS( e2341, EMPTYLIST ) ); SETGEN( PAIR_CAR( X1 ), X2 ); screp_flush_2dwhite( i2342 ); if ( TRUE( q2345 ) ) goto L2681; X2 = CONS( PAIR_CAR( X1 ), EMPTYLIST ); scrt6_format( o2343, CONS( c2371, X2 ) ); L2681: X1 = FALSEVALUE; GOBACK( L2653 ); } DEFTSCP( screp_load_v ); DEFCSTRING( t2683, "LOAD" ); EXTERNTSCPP( scrt5_rom_2dfile_73f9e308, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt5_rom_2dfile_73f9e308_v ); TSCP screp_l2380( c2685 ) TSCP c2685; { TSCP X1; PUSHSTACKTRACE( "screp_l2380 [inside LOAD]" ); X1 = CONS( c2188, EMPTYLIST ); X1 = CONS( FALSEVALUE, X1 ); X1 = CONS( c2217, X1 ); X1 = CONS( FALSEVALUE, X1 ); POPSTACKTRACE( screp_read_2deval_2dprint( CONS( c2248, X1 ) ) ); } TSCP screp_load( f2379 ) TSCP f2379; { TSCP X1; PUSHSTACKTRACE( t2683 ); X1 = MAKEPROCEDURE( 0, 0, screp_l2380, EMPTYLIST ); scrt5_rom_2dfile_73f9e308( f2379, X1 ); POPSTACKTRACE( f2379 ); } DEFTSCP( screp_loadq_v ); DEFCSTRING( t2687, "LOADQ" ); TSCP screp_l2383( c2689 ) TSCP c2689; { TSCP X1; PUSHSTACKTRACE( "screp_l2383 [inside LOADQ]" ); X1 = CONS( c2188, EMPTYLIST ); X1 = CONS( c2200, X1 ); X1 = CONS( FALSEVALUE, X1 ); X1 = CONS( c2217, X1 ); X1 = CONS( FALSEVALUE, X1 ); POPSTACKTRACE( screp_read_2deval_2dprint( CONS( c2248, X1 ) ) ); } TSCP screp_loadq( f2382 ) TSCP f2382; { TSCP X1; PUSHSTACKTRACE( t2687 ); X1 = MAKEPROCEDURE( 0, 0, screp_l2383, EMPTYLIST ); scrt5_rom_2dfile_73f9e308( f2382, X1 ); POPSTACKTRACE( f2382 ); } DEFTSCP( screp_loade_v ); DEFCSTRING( t2691, "LOADE" ); TSCP screp_l2386( c2693 ) TSCP c2693; { TSCP X1; PUSHSTACKTRACE( "screp_l2386 [inside LOADE]" ); X1 = CONS( c2188, EMPTYLIST ); X1 = CONS( c2194, X1 ); X1 = CONS( FALSEVALUE, X1 ); X1 = CONS( c2217, X1 ); X1 = CONS( FALSEVALUE, X1 ); POPSTACKTRACE( screp_read_2deval_2dprint( CONS( c2248, X1 ) ) ); } TSCP screp_loade( f2385 ) TSCP f2385; { TSCP X1; PUSHSTACKTRACE( t2691 ); X1 = MAKEPROCEDURE( 0, 0, screp_l2386, EMPTYLIST ); scrt5_rom_2dfile_73f9e308( f2385, X1 ); POPSTACKTRACE( f2385 ); } DEFTSCP( screp_scheme2c_v ); DEFCSTRING( t2695, "SCREP_SCHEME2C" ); EXTERNTSCP( screp_return_2dto_2dscheme2c_v ); EXTERNTSCP( screp_scheme2c_2dstatus_v ); EXTERNTSCPP( scrt5_open_2dinput_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2dinput_2dstring_v ); TSCP screp_e2391( r2393, c2698 ) TSCP r2393, c2698; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "EXECUTE [inside SCHEME2C]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c2698, 0 ); screp_return_2dto_2dscheme2c_v = r2393; screp_scheme2c_2dstatus_v = _TSCP( 0 ); scrt5_stdin_2dport_v = scrt5_open_2dinput_2dstring( DISPLAY( 0 ) ); X5 = scrt6_read( CONS( scrt5_stdin_2dport_v, EMPTYLIST ) ); X4 = sceval_eval( X5, EMPTYLIST ); X3 = screp_return_2dto_2dscheme2c_v; X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( X4, PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } EXTERNTSCP( screp__2ascheme2c_2dresult_2a_v ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); EXTERNTSCPP( scrt6_write, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_write_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt6_get_2doutput_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt6_get_2doutput_2dstring_v ); EXTERNTSCP( scrt5_stderr_2dport_v ); TSCP screp_scheme2c( i2389 ) TSCP i2389; { TSCP X6, X5, X4, X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t2695 ); DISPLAY( 0 ) = i2389; X1 = _TSCP( 0 ); X1 = CONS( X1, EMPTYLIST ); X2 = MAKEPROCEDURE( 1, 0, screp_e2391, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( X1 ), X2 ); X2 = sc_ntinuation_1af38b9f_v; X2 = UNKNOWNCALL( X2, 1 ); screp__2ascheme2c_2dresult_2a_v = VIA( PROCEDURE_CODE( X2 ) )( PAIR_CAR( X1 ), PROCEDURE_CLOSURE( X2 ) ); X2 = screp_scheme2c_2dstatus_v; if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L2702; if ( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L2706; goto L2709; L2702: if ( FALSE( scrt2_zero_3f( X2 ) ) ) goto L2709; L2706: scrt6_write( screp__2ascheme2c_2dresult_2a_v, CONS( scrt5_stdout_2dport_v, EMPTYLIST ) ); L2709: X4 = scrt6_get_2doutput_2dstring( scrt5_stdout_2dport_v ); X6 = scrt6_get_2doutput_2dstring( scrt5_stderr_2dport_v ); X5 = sc_cons( X6, EMPTYLIST ); X3 = sc_cons( X4, X5 ); X2 = sc_cons( screp_scheme2c_2dstatus_v, X3 ); SDVAL = X2; DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } DEFTSCP( screp_return_2dto_2dscheme2c_v ); DEFCSTRING( t2711, "SCREP_RETURN-TO-SCHEME2C" ); DEFTSCP( screp_scheme2c_2dstatus_v ); DEFCSTRING( t2712, "SCREP_SCHEME2C-STATUS" ); DEFTSCP( screp__2ascheme2c_2dresult_2a_v ); DEFCSTRING( t2713, "*SCHEME2C-RESULT*" ); DEFTSCP( screp_jump_2dto_2dscheme2c_v ); DEFCSTRING( t2714, "SCREP_JUMP-TO-SCHEME2C" ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); TSCP screp_jump_2dto_2dscheme2c( x2409 ) TSCP x2409; { TSCP X3, X2, X1; PUSHSTACKTRACE( t2714 ); X1 = scrt1_length( x2409 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L2717; screp_scheme2c_2dstatus_v = _TSCP( 0 ); X2 = screp_return_2dto_2dscheme2c_v; X2 = UNKNOWNCALL( X2, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( FALSEVALUE, PROCEDURE_CLOSURE( X2 ) ) ); L2717: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L2720; screp_scheme2c_2dstatus_v = _TSCP( 0 ); if ( EQ( TSCPTAG( x2409 ), PAIRTAG ) ) goto L2724; scrt1__24__car_2derror( x2409 ); L2724: X3 = PAIR_CAR( x2409 ); X2 = screp_return_2dto_2dscheme2c_v; X2 = UNKNOWNCALL( X2, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ) ); L2720: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 8 ) ) ) ) goto L2726; if ( EQ( TSCPTAG( x2409 ), PAIRTAG ) ) goto L2730; scrt1__24__cdr_2derror( x2409 ); L2730: X2 = PAIR_CDR( x2409 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2733; scrt1__24__car_2derror( X2 ); L2733: screp_scheme2c_2dstatus_v = PAIR_CAR( X2 ); X3 = PAIR_CAR( x2409 ); X2 = screp_return_2dto_2dscheme2c_v; X2 = UNKNOWNCALL( X2, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ) ); L2726: POPSTACKTRACE( FALSEVALUE ); } void scrt2__init(); void sceval__init(); void scrt3__init(); void scrt6__init(); void scrt5__init(); void scrt4__init(); void scdebug__init(); void scrt1__init(); void scdebug__init(); void sceval__init(); void scexpand__init(); void scexpnd1__init(); void scexpnd2__init(); void scqquote__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt2__init(); sceval__init(); scrt3__init(); scrt6__init(); scrt5__init(); scrt4__init(); scdebug__init(); scrt1__init(); scdebug__init(); sceval__init(); scexpand__init(); scexpnd1__init(); scexpnd2__init(); scqquote__init(); MAXDISPLAY( 4 ); } void screp__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(screp SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2497, ADR( screp_reset_v ), FALSEVALUE ); INITIALIZEVAR( t2498, ADR( screp_top_2dlevel_v ), FALSEVALUE ); INITIALIZEVAR( t2499, ADR( screp_default_2dexit_v ), MAKEPROCEDURE( 0, 1, screp_default_2dexit, EMPTYLIST ) ); INITIALIZEVAR( t2516, ADR( screp_exit_v ), FALSEVALUE ); screp_exit_v = screp_default_2dexit_v; screp_reset_v = MAKEPROCEDURE( 0, 0, screp_l2163, EMPTYLIST ); INITIALIZEVAR( t2518, ADR( screp__2aemacscheme_2a_v ), FALSEVALUE ); INITIALIZEVAR( t2519, ADR( screp__2areading_2dstdin_2a_v ), FALSEVALUE ); INITIALIZEVAR( t2520, ADR( screp_read_2deval_2dprint_v ), MAKEPROCEDURE( 0, 1, screp_read_2deval_2dprint, EMPTYLIST ) ); INITIALIZEVAR( t2637, ADR( screp_flush_2dwhite_v ), MAKEPROCEDURE( 1, 0, screp_flush_2dwhite, EMPTYLIST ) ); INITIALIZEVAR( t2650, ADR( screp_rep_v ), MAKEPROCEDURE( 5, 0, screp_rep, EMPTYLIST ) ); INITIALIZEVAR( t2683, ADR( screp_load_v ), MAKEPROCEDURE( 1, 0, screp_load, EMPTYLIST ) ); INITIALIZEVAR( t2687, ADR( screp_loadq_v ), MAKEPROCEDURE( 1, 0, screp_loadq, EMPTYLIST ) ); INITIALIZEVAR( t2691, ADR( screp_loade_v ), MAKEPROCEDURE( 1, 0, screp_loade, EMPTYLIST ) ); INITIALIZEVAR( t2695, ADR( screp_scheme2c_v ), MAKEPROCEDURE( 1, 0, screp_scheme2c, EMPTYLIST ) ); INITIALIZEVAR( t2711, ADR( screp_return_2dto_2dscheme2c_v ), FALSEVALUE ); INITIALIZEVAR( t2712, ADR( screp_scheme2c_2dstatus_v ), FALSEVALUE ); INITIALIZEVAR( t2713, ADR( screp__2ascheme2c_2dresult_2a_v ), FALSEVALUE ); INITIALIZEVAR( t2714, ADR( screp_jump_2dto_2dscheme2c_v ), MAKEPROCEDURE( 0, 1, screp_jump_2dto_2dscheme2c, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/screp.sc000066400000000000000000000257141203736146400162300ustar00rootroot00000000000000;;; This file implements the basic "read-eval-print" for SCHEME->C. The ;;; interpreter is designed so that it can be run either "stand-alone", or ;;; embedded in some application. Initialization of this module will assure ;;; that the entire library is initialized. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module screp (top-level RESET EXIT TOP-LEVEL READ-EVAL-PRINT LOAD LOADQ LOADE *SCHEME2C-RESULT*) (with scdebug sceval scexpand scexpnd1 scexpnd2 scqquote)) (include "repdef.sc") ;;; The function RESET will return to the current READ-EVAL-PRINT loop (or ;;; terminate signaling an error condition. (define RESET #f) ;;; The function TOP-LEVEL will return to the outer most interpreter. (define TOP-LEVEL #f) ;;; The function EXIT will return from the current READ-EVAL-PRINT loop. At ;;; the top-level, it will terminate the Scheme process. It accepts an ;;; return code. (define (DEFAULT-EXIT . x) (if (null? x) (osexit 0) (if (number? (car x)) (osexit (car x)) (error 'EXIT "Argument is not an INTEGER: ~s" (car x))))) (define EXIT #f) (set! exit default-exit) (set! reset (lambda () (default-exit 1))) ;;; The global flag *EMACSCHEME* indicates whether the interpreter is running ;;; in GNU emacs. (define *EMACSCHEME* #f) ;;; The global flag *READING-STDIN* indicates that the interpreter is reading ;;; stdin. If control-c is pressed while this is true, then the debugger ;;; is not entered and a reset is performed. (define *READING-STDIN* #f) ;;; The entry point to this module is the following function. On entry it ;;; saves the current EXIT, RESET, TRACE-LEVEL, and keyboard interrupt ;;; handler. After arming the keyboard interrupt, it passes control ;;; to the next step, REP. On return from that function, the saved values ;;; will be restored and then the function will exit. ;;; ;;; The function is called with an optional list of options. They are: ;;; ;;; ECHO - echo the input on the output file. ;;; "-e" ;;; QUIET - do not print the result on the output file. ;;; "-q" ;;; PROMPT "prompt" / #f prompt input with the string "prompt". ;;; "-np" do not prompt input. ;;; HEADER "header" / #f print the "header" on entry. ;;; "-nh" do not print header. ;;; LOAD LOAD / LOADE /LOADQ from current input. ;;; RESULT value value to return unless overridden by proceed. ;;; ENV alist interpreter environment. ;;; "-emacs" GNU emacs mode (define (READ-EVAL-PRINT . flags) (letrec ((save-exit exit) (save-reset reset) (save-interrupt (and (not (memq 'load flags)) (signal sigint sig_ign))) (save-trace trace-level) (input current-input-port-value) (output current-output-port-value) (echoinput (or (member 'echo flags) (member "-e" flags))) (quiet (or (member 'quiet flags) (member "-q" flags))) (prompt (let ((x (member 'prompt flags))) (cond (x (cadr x)) ((member "-np" flags) #f) (else "> ")))) (header (let ((x (member 'header flags))) (cond (x (cadr x)) ((member "-nh" flags) #f) (else (format "~a -- ~a -- ~a ~a" (car (implementation-information)) (cadr (implementation-information)) "Copyright 1989-1993 Hewlett-Packard" "Development Company"))))) (env (let ((x (member 'env flags))) (if x (cadr x) '()))) (load (memq 'load flags)) (return-value (let ((x (member 'result flags))) (if x (cadr x) #f))) ;;; Exit function and proceed functions. (MAKE-EXIT (lambda (exit-here) (set! proceed (lambda x (if x (set! return-value (car x))) (exit-here #f))) (set! exit (lambda x (exit-here (if (null? x) #f (car x))))) #t)) ;;; Reset function. (MAKE-RESET (lambda (reset-here) (if (not load) (set! reset (let ((save-exit exit)) (lambda () (set! exit save-exit) (reset-here #f))))) #t)) ;;; One-time initialization code to set up TOP-LEVEL, backtracing ;;; error handler, and trap handlers. (ONE-TIME-INITIALIZATION (lambda () (set-scheme-mode! 'interactive) (set! *emacscheme* (member "-emacs" flags)) (set! top-level (let ((top-reset reset)) (lambda () (set! *debug-on-error* #t) (set! reset top-reset) (reset)))) (set! *error-handler* backtrace-error-handler) (set! *debug-on-error* #t)))) ;;; Function body starts here. (if (call-with-current-continuation make-exit) (begin (if (call-with-current-continuation make-reset) (begin (if (and (not load) (not (eq? save-interrupt sig_ign))) (signal sigint on-interrupt)) (if echoinput (echo input output)) (if header (format stdout-port "~a~%" header))) (begin (set! current-input-port-value input) (set! current-output-port-value output) (set! trace-level save-trace))) (if (and (not top-level) (not load)) (one-time-initialization)) (rep env (if load (current-input-port) stdin-port) stdout-port prompt quiet))) (unless load (signal sigint save-interrupt)) (if echoinput (echo input #f)) (set! exit save-exit) (set! reset save-reset) (set! trace-level save-trace) return-value)) ;;; Flushes white space characters from the input file. (define (FLUSH-WHITE inport) (let ((c (and (char-ready? inport) (peek-char inport)))) (if (and c (not (eof-object? c)) (char-whitespace? c)) (begin (read-char inport) (flush-white inport))))) ;;; REP is called from READ-EVAL-PRINT to actually read the commands once ;;; the initial environment is set up. (define (REP env inport outport prompt quiet) (let loop ((exp #f)) (flush-white inport) (if (and prompt (not (char-ready? inport))) (display prompt outport)) (set! *reading-stdin* (eq? inport stdin-port)) (set! exp (read inport)) (set! *reading-stdin* #f) (cond ((eof-object? exp) (if prompt (newline outport))) ((and (pair? exp) (memq (car exp) '(module include))) (flush-white inport) (if (not quiet) (format outport "~s form ignored~%" (car exp))) (loop #f)) (else (if *emacscheme* (newline outport)) (set! exp (eval exp env)) (flush-white inport) (if (not quiet) (format outport "~s~%" exp)) (loop #f))))) ;;; Expressions within files are loaded by the following functions. (define (LOAD file-name) (with-input-from-file file-name (lambda () (read-eval-print 'header #f 'prompt #f 'load))) file-name) (define (LOADQ file-name) (with-input-from-file file-name (lambda () (read-eval-print 'header #f 'prompt #f 'quiet 'load))) file-name) (define (LOADE file-name) (with-input-from-file file-name (lambda () (read-eval-print 'header #f 'prompt #f 'echo 'load))) file-name) ;;; When Scheme->C is a server embedded in a client program, the client ;;; evaluates a Scheme expression by calling the procedure SCHEME2C. ;;; ;;; input_expression: the address of a null terminated string of ASCII ;;; characters that is the Scheme expression to evaluate. ;;; ;;; The procedure returns a list of three items, reflecting the evaluation: ;;; ;;; status: 0 expression evaluated normally. The value is ;;; saved in *SCHEME2C-RESULT* and also written to ;;; stdout-port. ;;; ;;; 1 an error occurred. The error message is ;;; written to stderr-port. If no previous error ;;; is latched, then the stack trace is written to ;;; stderr-port and the associated environments are ;;; in the list *ERROR-ENV*. The client should ;;; evaluate (RESET-ERROR) when done examining the ;;; error state. ;;; ;;; 2 an internal error occurred. The error message ;;; is reported via stderr-port. No further ;;; execution is possible. ;;; ;;; 3 computation timed out. Evaluate (PROCEED) ;;; to continue execution. Evaluate (PROCEED?) ;;; to cause a breakpoint when execution resumes. ;;; ;;; 4 a procedure entry breakpoint occurred. The ;;; call is written to stderr-port and the ;;; associated environments are in the list ;;; *BPT-ENV*. The procedure stack trace can be ;;; viewed by evaluating (BACKTRACE). The ;;; procedure arguments are in *ARGS*. ;;; Evaluate (PROCEED) to continue execution, or ;;; (RESET-BPT) to abort. ;;; ;;; 5 a procedure exit breakpoint occurred. The ;;; result is written to the stderr-port and ;;; saved in *RESULT*. The environments are ;;; in the list *BPT-ENV*. Evaluate (PROCEED) ;;; to continue execution, (PROCEED exp) to ;;; continue returning a new value, or ;;; (RESET-BPT) to abort. ;;; ;;; N.B. Additional breakpoints will not occur while ;;; examining the state of a breakpoint. ;;; ;;; result: a null terminated string of ASCII characters that is ;;; the contents of the string port stdout-port, i.e. the ;;; standard output port. ;;; ;;; error: a null terminated string of ASCII characters that is ;;; the contents of the string port stderr-port, i.e. the ;;; error output port. (define (SCHEME2C input-expr) (define (EXECUTE return) (set! return-to-scheme2c return) (set! scheme2c-status 0) (set! stdin-port (open-input-string input-expr)) (return-to-scheme2c (eval (read stdin-port)))) (set! *scheme2c-result* (call-with-current-continuation execute)) (if (zero? scheme2c-status) (write *scheme2c-result* stdout-port)) (list scheme2c-status (get-output-string stdout-port) (get-output-string stderr-port))) (define RETURN-TO-SCHEME2C #f) (define SCHEME2C-STATUS #f) (define *SCHEME2C-RESULT* #f) ;;; This is called to "upexit" to SCHEME2C with an optional value and status. (define (JUMP-TO-SCHEME2C . x) (case (length x) ((0) (set! scheme2c-status 0) (return-to-scheme2c #f)) ((1) (set! scheme2c-status 0) (return-to-scheme2c (car x))) ((2) (set! scheme2c-status (cadr x)) (return-to-scheme2c (car x))))) scheme2c-2012.10.14/scrt/scrt1.c000066400000000000000000002004251203736146400157570ustar00rootroot00000000000000 /* SCHEME->C */ #include void scrt1__init(); DEFSTATICTSCP( c2674 ); DEFCSTRING( t3308, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2665 ); DEFSTATICTSCP( c2664 ); DEFSTATICTSCP( c2203 ); DEFCSTRING( t3309, "Argument not a PAIR: ~a" ); DEFSTATICTSCP( c2200 ); DEFSTATICTSCP( c2199 ); DEFCSTRING( t3310, "Index is not in bounds: ~s" ); DEFSTATICTSCP( c2109 ); DEFCSTRING( t3311, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2105 ); DEFSTATICTSCP( c2102 ); DEFCSTRING( t3312, "Argument is not a VECTOR: ~s" ); DEFSTATICTSCP( c2072 ); DEFSTATICTSCP( c2071 ); DEFSTATICTSCP( c2040 ); static void init_constants() { c2674 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2674 ) ); c2665 = CSTRING_TSCP( t3308 ); CONSTANTEXP( ADR( c2665 ) ); c2664 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CAR!" ) ); CONSTANTEXP( ADR( c2664 ) ); c2203 = STRINGTOSYMBOL( CSTRING_TSCP( "CDR" ) ); CONSTANTEXP( ADR( c2203 ) ); c2200 = CSTRING_TSCP( t3309 ); CONSTANTEXP( ADR( c2200 ) ); c2199 = STRINGTOSYMBOL( CSTRING_TSCP( "CAR" ) ); CONSTANTEXP( ADR( c2199 ) ); c2109 = CSTRING_TSCP( t3310 ); CONSTANTEXP( ADR( c2109 ) ); c2105 = CSTRING_TSCP( t3311 ); CONSTANTEXP( ADR( c2105 ) ); c2102 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-REF" ) ); CONSTANTEXP( ADR( c2102 ) ); c2072 = CSTRING_TSCP( t3312 ); CONSTANTEXP( ADR( c2072 ) ); c2071 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-LENGTH" ) ); CONSTANTEXP( ADR( c2071 ) ); c2040 = STRINGTOSYMBOL( CSTRING_TSCP( "%TO-EQUAL?" ) ); CONSTANTEXP( ADR( c2040 ) ); } DEFTSCP( scrt1_not_v ); DEFCSTRING( t3313, "NOT" ); TSCP scrt1_not( x2001 ) TSCP x2001; { PUSHSTACKTRACE( t3313 ); if ( TRUE( x2001 ) ) goto L3315; POPSTACKTRACE( TRUEVALUE ); L3315: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt1_boolean_3f_v ); DEFCSTRING( t3317, "BOOLEAN?" ); TSCP scrt1_boolean_3f( x2003 ) TSCP x2003; { PUSHSTACKTRACE( t3317 ); if ( EQ( _S2CUINT( x2003 ), _S2CUINT( FALSEVALUE ) ) ) goto L3319; POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( x2003 ), _S2CUINT( TRUEVALUE ) ) ) ); L3319: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( scrt1_eqv_3f_v ); DEFCSTRING( t3321, "EQV?" ); TSCP scrt1_eqv_3f( x2015, y2016 ) TSCP x2015, y2016; { PUSHSTACKTRACE( t3321 ); POPSTACKTRACE( BOOLEAN( OR( EQ( _S2CUINT( x2015 ), _S2CUINT( y2016 ) ), AND( EQ( TSCPTAG( x2015 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( x2015 ), DOUBLEFLOATTAG ), AND( EQ( TSCPTAG( y2016 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( y2016 ), DOUBLEFLOATTAG ), EQ( FLOAT_VALUE( x2015 ), FLOAT_VALUE( y2016 ) ) ) ) ) ) ) ) ); } DEFTSCP( scrt1_eq_3f_v ); DEFCSTRING( t3323, "EQ?" ); TSCP scrt1_eq_3f( x2021, y2022 ) TSCP x2021, y2022; { PUSHSTACKTRACE( t3323 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( x2021 ), _S2CUINT( y2022 ) ) ) ); } DEFTSCP( scrt1_equal_3f_v ); DEFCSTRING( t3325, "EQUAL?" ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt3_string_3d_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt3_string_3d_3f_v ); EXTERNTSCPP( scrt4_p_2dmethod_3ccf392b, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_p_2dmethod_3ccf392b_v ); TSCP scrt1_equal_3f( x2027, y2028 ) TSCP x2027, y2028; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3325 ); L3326: if ( NEQ( TSCPTAG( x2027 ), PAIRTAG ) ) goto L3327; if ( NEQ( TSCPTAG( y2028 ), PAIRTAG ) ) goto L3329; X2 = PAIR_CAR( x2027 ); X3 = PAIR_CAR( y2028 ); X1 = scrt1_equal_3f( X2, X3 ); if ( FALSE( X1 ) ) goto L3334; X2 = PAIR_CDR( x2027 ); y2028 = PAIR_CDR( y2028 ); x2027 = X2; GOBACK( L3326 ); L3334: POPSTACKTRACE( X1 ); L3329: POPSTACKTRACE( FALSEVALUE ); L3327: if ( NOT( AND( EQ( TSCPTAG( x2027 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2027 ), VECTORTAG ) ) ) ) goto L3338; X1 = C_FIXED( VECTOR_LENGTH( x2027 ) ); if ( NOT( AND( EQ( TSCPTAG( y2028 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2028 ), VECTORTAG ) ) ) ) goto L3342; X3 = C_FIXED( VECTOR_LENGTH( y2028 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X1 ) ), 3 ) ) goto L3346; X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( X1 ) ) ); goto L3347; L3346: X2 = scrt2__3d_2dtwo( X3, X1 ); L3347: if ( FALSE( X2 ) ) goto L3349; if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3351; X3 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3352; L3351: X3 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); L3352: X4 = X3; L3355: if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( -4 ) ) ), 3 ) ) goto L3356; X5 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( -4 ) ) ) ); goto L3357; L3356: X5 = scrt2__3d_2dtwo( X4, _TSCP( -4 ) ); L3357: if ( TRUE( X5 ) ) goto L3359; if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L3362; scdebug_error( c2102, c2105, CONS( X4, EMPTYLIST ) ); L3362: if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( x2027 ) ) ) ) goto L3364; scdebug_error( c2102, c2109, CONS( X4, EMPTYLIST ) ); L3364: X7 = VECTOR_ELEMENT( x2027, X4 ); if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( y2028 ) ) ) ) goto L3367; scdebug_error( c2102, c2109, CONS( X4, EMPTYLIST ) ); L3367: X8 = VECTOR_ELEMENT( y2028, X4 ); X6 = scrt1_equal_3f( X7, X8 ); if ( FALSE( X6 ) ) goto L3370; if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3372; X4 = _TSCP( IDIFFERENCE( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L3355 ); L3372: X4 = scrt2__2d_2dtwo( X4, _TSCP( 4 ) ); GOBACK( L3355 ); L3370: POPSTACKTRACE( X6 ); L3359: POPSTACKTRACE( X5 ); L3349: POPSTACKTRACE( X2 ); L3342: POPSTACKTRACE( FALSEVALUE ); L3338: if ( NOT( AND( EQ( TSCPTAG( x2027 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2027 ), STRINGTAG ) ) ) ) goto L3374; if ( NOT( AND( EQ( TSCPTAG( y2028 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2028 ), STRINGTAG ) ) ) ) goto L3376; POPSTACKTRACE( scrt3_string_3d_3f( x2027, y2028 ) ); L3376: POPSTACKTRACE( FALSEVALUE ); L3374: if ( NOT( AND( EQ( TSCPTAG( x2027 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2027 ), RECORDTAG ) ) ) ) goto L3378; X1 = scrt4_p_2dmethod_3ccf392b( x2027, c2040 ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( x2027, y2028, PROCEDURE_CLOSURE( X1 ) ) ); L3378: POPSTACKTRACE( BOOLEAN( OR( EQ( _S2CUINT( x2027 ), _S2CUINT( y2028 ) ), AND( EQ( TSCPTAG( x2027 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( x2027 ), DOUBLEFLOATTAG ), AND( EQ( TSCPTAG( y2028 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( y2028 ), DOUBLEFLOATTAG ), EQ( FLOAT_VALUE( x2027 ), FLOAT_VALUE( y2028 ) ) ) ) ) ) ) ) ); } DEFTSCP( scrt1_pair_3f_v ); DEFCSTRING( t3380, "PAIR?" ); TSCP scrt1_pair_3f( x2166 ) TSCP x2166; { PUSHSTACKTRACE( t3380 ); POPSTACKTRACE( BOOLEAN( EQ( TSCPTAG( x2166 ), PAIRTAG ) ) ); } DEFTSCP( scrt1_cons_2a_v ); DEFCSTRING( t3382, "CONS*" ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_c2173, XAL1( TSCP ) ); TSCP scrt1_c2173( x2175 ) TSCP x2175; { TSCP X3, X2, X1; PUSHSTACKTRACE( "CONS*1 [inside CONS*]" ); if ( EQ( TSCPTAG( x2175 ), PAIRTAG ) ) goto L3389; scrt1__24__cdr_2derror( x2175 ); L3389: X1 = PAIR_CDR( x2175 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3386; POPSTACKTRACE( PAIR_CAR( x2175 ) ); L3386: if ( EQ( TSCPTAG( x2175 ), PAIRTAG ) ) goto L3393; scrt1__24__car_2derror( x2175 ); L3393: X1 = PAIR_CAR( x2175 ); X3 = PAIR_CDR( x2175 ); X2 = scrt1_c2173( X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); } TSCP scrt1_cons_2a( x2170, y2171 ) TSCP x2170, y2171; { TSCP X1; PUSHSTACKTRACE( t3382 ); if ( FALSE( y2171 ) ) goto L3396; X1 = scrt1_c2173( y2171 ); POPSTACKTRACE( sc_cons( x2170, X1 ) ); L3396: POPSTACKTRACE( x2170 ); } DEFTSCP( scrt1__24__car_2derror_v ); DEFCSTRING( t3398, "SCRT1_$_CAR-ERROR" ); TSCP scrt1__24__car_2derror( x2198 ) TSCP x2198; { PUSHSTACKTRACE( t3398 ); POPSTACKTRACE( scdebug_error( c2199, c2200, CONS( x2198, EMPTYLIST ) ) ); } DEFTSCP( scrt1__24__cdr_2derror_v ); DEFCSTRING( t3400, "SCRT1_$_CDR-ERROR" ); TSCP scrt1__24__cdr_2derror( x2202 ) TSCP x2202; { PUSHSTACKTRACE( t3400 ); POPSTACKTRACE( scdebug_error( c2203, c2200, CONS( x2202, EMPTYLIST ) ) ); } DEFTSCP( scrt1_car_v ); DEFCSTRING( t3402, "CAR" ); TSCP scrt1_car( x2205 ) TSCP x2205; { PUSHSTACKTRACE( t3402 ); if ( EQ( TSCPTAG( x2205 ), PAIRTAG ) ) goto L3405; scrt1__24__car_2derror( x2205 ); L3405: POPSTACKTRACE( PAIR_CAR( x2205 ) ); } DEFTSCP( scrt1_cdr_v ); DEFCSTRING( t3407, "CDR" ); TSCP scrt1_cdr( x2211 ) TSCP x2211; { PUSHSTACKTRACE( t3407 ); if ( EQ( TSCPTAG( x2211 ), PAIRTAG ) ) goto L3410; scrt1__24__cdr_2derror( x2211 ); L3410: POPSTACKTRACE( PAIR_CDR( x2211 ) ); } DEFTSCP( scrt1_caar_v ); DEFCSTRING( t3412, "CAAR" ); TSCP scrt1_caar( x2217 ) TSCP x2217; { TSCP X1; PUSHSTACKTRACE( t3412 ); if ( EQ( TSCPTAG( x2217 ), PAIRTAG ) ) goto L3415; scrt1__24__car_2derror( x2217 ); L3415: X1 = PAIR_CAR( x2217 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3418; scrt1__24__car_2derror( X1 ); L3418: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_cadr_v ); DEFCSTRING( t3420, "CADR" ); TSCP scrt1_cadr( x2227 ) TSCP x2227; { TSCP X1; PUSHSTACKTRACE( t3420 ); if ( EQ( TSCPTAG( x2227 ), PAIRTAG ) ) goto L3423; scrt1__24__cdr_2derror( x2227 ); L3423: X1 = PAIR_CDR( x2227 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3426; scrt1__24__car_2derror( X1 ); L3426: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_cdar_v ); DEFCSTRING( t3428, "CDAR" ); TSCP scrt1_cdar( x2237 ) TSCP x2237; { TSCP X1; PUSHSTACKTRACE( t3428 ); if ( EQ( TSCPTAG( x2237 ), PAIRTAG ) ) goto L3431; scrt1__24__car_2derror( x2237 ); L3431: X1 = PAIR_CAR( x2237 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3434; scrt1__24__cdr_2derror( X1 ); L3434: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cddr_v ); DEFCSTRING( t3436, "CDDR" ); TSCP scrt1_cddr( x2247 ) TSCP x2247; { TSCP X1; PUSHSTACKTRACE( t3436 ); if ( EQ( TSCPTAG( x2247 ), PAIRTAG ) ) goto L3439; scrt1__24__cdr_2derror( x2247 ); L3439: X1 = PAIR_CDR( x2247 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3442; scrt1__24__cdr_2derror( X1 ); L3442: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_caaar_v ); DEFCSTRING( t3444, "CAAAR" ); TSCP scrt1_caaar( x2257 ) TSCP x2257; { TSCP X2, X1; PUSHSTACKTRACE( t3444 ); if ( EQ( TSCPTAG( x2257 ), PAIRTAG ) ) goto L3447; scrt1__24__car_2derror( x2257 ); L3447: X2 = PAIR_CAR( x2257 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3450; scrt1__24__car_2derror( X2 ); L3450: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3453; scrt1__24__car_2derror( X1 ); L3453: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_caadr_v ); DEFCSTRING( t3455, "CAADR" ); TSCP scrt1_caadr( x2271 ) TSCP x2271; { TSCP X2, X1; PUSHSTACKTRACE( t3455 ); if ( EQ( TSCPTAG( x2271 ), PAIRTAG ) ) goto L3458; scrt1__24__cdr_2derror( x2271 ); L3458: X2 = PAIR_CDR( x2271 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3461; scrt1__24__car_2derror( X2 ); L3461: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3464; scrt1__24__car_2derror( X1 ); L3464: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_cadar_v ); DEFCSTRING( t3466, "CADAR" ); TSCP scrt1_cadar( x2285 ) TSCP x2285; { TSCP X2, X1; PUSHSTACKTRACE( t3466 ); if ( EQ( TSCPTAG( x2285 ), PAIRTAG ) ) goto L3469; scrt1__24__car_2derror( x2285 ); L3469: X2 = PAIR_CAR( x2285 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3472; scrt1__24__cdr_2derror( X2 ); L3472: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3475; scrt1__24__car_2derror( X1 ); L3475: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_caddr_v ); DEFCSTRING( t3477, "CADDR" ); TSCP scrt1_caddr( x2299 ) TSCP x2299; { TSCP X2, X1; PUSHSTACKTRACE( t3477 ); if ( EQ( TSCPTAG( x2299 ), PAIRTAG ) ) goto L3480; scrt1__24__cdr_2derror( x2299 ); L3480: X2 = PAIR_CDR( x2299 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3483; scrt1__24__cdr_2derror( X2 ); L3483: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3486; scrt1__24__car_2derror( X1 ); L3486: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_cdaar_v ); DEFCSTRING( t3488, "CDAAR" ); TSCP scrt1_cdaar( x2313 ) TSCP x2313; { TSCP X2, X1; PUSHSTACKTRACE( t3488 ); if ( EQ( TSCPTAG( x2313 ), PAIRTAG ) ) goto L3491; scrt1__24__car_2derror( x2313 ); L3491: X2 = PAIR_CAR( x2313 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3494; scrt1__24__car_2derror( X2 ); L3494: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3497; scrt1__24__cdr_2derror( X1 ); L3497: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cdadr_v ); DEFCSTRING( t3499, "CDADR" ); TSCP scrt1_cdadr( x2327 ) TSCP x2327; { TSCP X2, X1; PUSHSTACKTRACE( t3499 ); if ( EQ( TSCPTAG( x2327 ), PAIRTAG ) ) goto L3502; scrt1__24__cdr_2derror( x2327 ); L3502: X2 = PAIR_CDR( x2327 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3505; scrt1__24__car_2derror( X2 ); L3505: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3508; scrt1__24__cdr_2derror( X1 ); L3508: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cddar_v ); DEFCSTRING( t3510, "CDDAR" ); TSCP scrt1_cddar( x2341 ) TSCP x2341; { TSCP X2, X1; PUSHSTACKTRACE( t3510 ); if ( EQ( TSCPTAG( x2341 ), PAIRTAG ) ) goto L3513; scrt1__24__car_2derror( x2341 ); L3513: X2 = PAIR_CAR( x2341 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3516; scrt1__24__cdr_2derror( X2 ); L3516: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3519; scrt1__24__cdr_2derror( X1 ); L3519: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cdddr_v ); DEFCSTRING( t3521, "CDDDR" ); TSCP scrt1_cdddr( x2355 ) TSCP x2355; { TSCP X2, X1; PUSHSTACKTRACE( t3521 ); if ( EQ( TSCPTAG( x2355 ), PAIRTAG ) ) goto L3524; scrt1__24__cdr_2derror( x2355 ); L3524: X2 = PAIR_CDR( x2355 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3527; scrt1__24__cdr_2derror( X2 ); L3527: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3530; scrt1__24__cdr_2derror( X1 ); L3530: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_caaaar_v ); DEFCSTRING( t3532, "CAAAAR" ); TSCP scrt1_caaaar( x2369 ) TSCP x2369; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3532 ); if ( EQ( TSCPTAG( x2369 ), PAIRTAG ) ) goto L3535; scrt1__24__car_2derror( x2369 ); L3535: X3 = PAIR_CAR( x2369 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3538; scrt1__24__car_2derror( X3 ); L3538: X2 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3541; scrt1__24__car_2derror( X2 ); L3541: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3544; scrt1__24__car_2derror( X1 ); L3544: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_caaadr_v ); DEFCSTRING( t3546, "CAAADR" ); TSCP scrt1_caaadr( x2387 ) TSCP x2387; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3546 ); if ( EQ( TSCPTAG( x2387 ), PAIRTAG ) ) goto L3549; scrt1__24__cdr_2derror( x2387 ); L3549: X3 = PAIR_CDR( x2387 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3552; scrt1__24__car_2derror( X3 ); L3552: X2 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3555; scrt1__24__car_2derror( X2 ); L3555: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3558; scrt1__24__car_2derror( X1 ); L3558: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_caadar_v ); DEFCSTRING( t3560, "CAADAR" ); TSCP scrt1_caadar( x2405 ) TSCP x2405; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3560 ); if ( EQ( TSCPTAG( x2405 ), PAIRTAG ) ) goto L3563; scrt1__24__car_2derror( x2405 ); L3563: X3 = PAIR_CAR( x2405 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3566; scrt1__24__cdr_2derror( X3 ); L3566: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3569; scrt1__24__car_2derror( X2 ); L3569: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3572; scrt1__24__car_2derror( X1 ); L3572: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_caaddr_v ); DEFCSTRING( t3574, "CAADDR" ); TSCP scrt1_caaddr( x2423 ) TSCP x2423; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3574 ); if ( EQ( TSCPTAG( x2423 ), PAIRTAG ) ) goto L3577; scrt1__24__cdr_2derror( x2423 ); L3577: X3 = PAIR_CDR( x2423 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3580; scrt1__24__cdr_2derror( X3 ); L3580: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3583; scrt1__24__car_2derror( X2 ); L3583: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3586; scrt1__24__car_2derror( X1 ); L3586: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_cadaar_v ); DEFCSTRING( t3588, "CADAAR" ); TSCP scrt1_cadaar( x2441 ) TSCP x2441; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3588 ); if ( EQ( TSCPTAG( x2441 ), PAIRTAG ) ) goto L3591; scrt1__24__car_2derror( x2441 ); L3591: X3 = PAIR_CAR( x2441 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3594; scrt1__24__car_2derror( X3 ); L3594: X2 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3597; scrt1__24__cdr_2derror( X2 ); L3597: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3600; scrt1__24__car_2derror( X1 ); L3600: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_cadadr_v ); DEFCSTRING( t3602, "CADADR" ); TSCP scrt1_cadadr( x2459 ) TSCP x2459; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3602 ); if ( EQ( TSCPTAG( x2459 ), PAIRTAG ) ) goto L3605; scrt1__24__cdr_2derror( x2459 ); L3605: X3 = PAIR_CDR( x2459 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3608; scrt1__24__car_2derror( X3 ); L3608: X2 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3611; scrt1__24__cdr_2derror( X2 ); L3611: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3614; scrt1__24__car_2derror( X1 ); L3614: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_caddar_v ); DEFCSTRING( t3616, "CADDAR" ); TSCP scrt1_caddar( x2477 ) TSCP x2477; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3616 ); if ( EQ( TSCPTAG( x2477 ), PAIRTAG ) ) goto L3619; scrt1__24__car_2derror( x2477 ); L3619: X3 = PAIR_CAR( x2477 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3622; scrt1__24__cdr_2derror( X3 ); L3622: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3625; scrt1__24__cdr_2derror( X2 ); L3625: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3628; scrt1__24__car_2derror( X1 ); L3628: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_cadddr_v ); DEFCSTRING( t3630, "CADDDR" ); TSCP scrt1_cadddr( x2495 ) TSCP x2495; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3630 ); if ( EQ( TSCPTAG( x2495 ), PAIRTAG ) ) goto L3633; scrt1__24__cdr_2derror( x2495 ); L3633: X3 = PAIR_CDR( x2495 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3636; scrt1__24__cdr_2derror( X3 ); L3636: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3639; scrt1__24__cdr_2derror( X2 ); L3639: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3642; scrt1__24__car_2derror( X1 ); L3642: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_cdaaar_v ); DEFCSTRING( t3644, "CDAAAR" ); TSCP scrt1_cdaaar( x2513 ) TSCP x2513; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3644 ); if ( EQ( TSCPTAG( x2513 ), PAIRTAG ) ) goto L3647; scrt1__24__car_2derror( x2513 ); L3647: X3 = PAIR_CAR( x2513 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3650; scrt1__24__car_2derror( X3 ); L3650: X2 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3653; scrt1__24__car_2derror( X2 ); L3653: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3656; scrt1__24__cdr_2derror( X1 ); L3656: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cdaadr_v ); DEFCSTRING( t3658, "CDAADR" ); TSCP scrt1_cdaadr( x2531 ) TSCP x2531; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3658 ); if ( EQ( TSCPTAG( x2531 ), PAIRTAG ) ) goto L3661; scrt1__24__cdr_2derror( x2531 ); L3661: X3 = PAIR_CDR( x2531 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3664; scrt1__24__car_2derror( X3 ); L3664: X2 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3667; scrt1__24__car_2derror( X2 ); L3667: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3670; scrt1__24__cdr_2derror( X1 ); L3670: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cdadar_v ); DEFCSTRING( t3672, "CDADAR" ); TSCP scrt1_cdadar( x2549 ) TSCP x2549; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3672 ); if ( EQ( TSCPTAG( x2549 ), PAIRTAG ) ) goto L3675; scrt1__24__car_2derror( x2549 ); L3675: X3 = PAIR_CAR( x2549 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3678; scrt1__24__cdr_2derror( X3 ); L3678: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3681; scrt1__24__car_2derror( X2 ); L3681: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3684; scrt1__24__cdr_2derror( X1 ); L3684: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cdaddr_v ); DEFCSTRING( t3686, "CDADDR" ); TSCP scrt1_cdaddr( x2567 ) TSCP x2567; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3686 ); if ( EQ( TSCPTAG( x2567 ), PAIRTAG ) ) goto L3689; scrt1__24__cdr_2derror( x2567 ); L3689: X3 = PAIR_CDR( x2567 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3692; scrt1__24__cdr_2derror( X3 ); L3692: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3695; scrt1__24__car_2derror( X2 ); L3695: X1 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3698; scrt1__24__cdr_2derror( X1 ); L3698: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cddaar_v ); DEFCSTRING( t3700, "CDDAAR" ); TSCP scrt1_cddaar( x2585 ) TSCP x2585; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3700 ); if ( EQ( TSCPTAG( x2585 ), PAIRTAG ) ) goto L3703; scrt1__24__car_2derror( x2585 ); L3703: X3 = PAIR_CAR( x2585 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3706; scrt1__24__car_2derror( X3 ); L3706: X2 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3709; scrt1__24__cdr_2derror( X2 ); L3709: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3712; scrt1__24__cdr_2derror( X1 ); L3712: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cddadr_v ); DEFCSTRING( t3714, "CDDADR" ); TSCP scrt1_cddadr( x2603 ) TSCP x2603; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3714 ); if ( EQ( TSCPTAG( x2603 ), PAIRTAG ) ) goto L3717; scrt1__24__cdr_2derror( x2603 ); L3717: X3 = PAIR_CDR( x2603 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3720; scrt1__24__car_2derror( X3 ); L3720: X2 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3723; scrt1__24__cdr_2derror( X2 ); L3723: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3726; scrt1__24__cdr_2derror( X1 ); L3726: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cdddar_v ); DEFCSTRING( t3728, "CDDDAR" ); TSCP scrt1_cdddar( x2621 ) TSCP x2621; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3728 ); if ( EQ( TSCPTAG( x2621 ), PAIRTAG ) ) goto L3731; scrt1__24__car_2derror( x2621 ); L3731: X3 = PAIR_CAR( x2621 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3734; scrt1__24__cdr_2derror( X3 ); L3734: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3737; scrt1__24__cdr_2derror( X2 ); L3737: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3740; scrt1__24__cdr_2derror( X1 ); L3740: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_cddddr_v ); DEFCSTRING( t3742, "CDDDDR" ); TSCP scrt1_cddddr( x2639 ) TSCP x2639; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3742 ); if ( EQ( TSCPTAG( x2639 ), PAIRTAG ) ) goto L3745; scrt1__24__cdr_2derror( x2639 ); L3745: X3 = PAIR_CDR( x2639 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3748; scrt1__24__cdr_2derror( X3 ); L3748: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3751; scrt1__24__cdr_2derror( X2 ); L3751: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3754; scrt1__24__cdr_2derror( X1 ); L3754: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt1_set_2dcar_21_v ); DEFCSTRING( t3756, "SET-CAR!" ); TSCP scrt1_set_2dcar_21( x2657, y2658 ) TSCP x2657, y2658; { PUSHSTACKTRACE( t3756 ); if ( EQ( TSCPTAG( x2657 ), PAIRTAG ) ) goto L3759; scdebug_error( c2664, c2665, CONS( x2657, EMPTYLIST ) ); L3759: POPSTACKTRACE( SETGEN( PAIR_CAR( x2657 ), y2658 ) ); } DEFTSCP( scrt1_set_2dcdr_21_v ); DEFCSTRING( t3761, "SET-CDR!" ); TSCP scrt1_set_2dcdr_21( x2667, y2668 ) TSCP x2667, y2668; { PUSHSTACKTRACE( t3761 ); if ( EQ( TSCPTAG( x2667 ), PAIRTAG ) ) goto L3764; scdebug_error( c2674, c2665, CONS( x2667, EMPTYLIST ) ); L3764: POPSTACKTRACE( SETGEN( PAIR_CDR( x2667 ), y2668 ) ); } DEFTSCP( scrt1_null_3f_v ); DEFCSTRING( t3766, "NULL?" ); TSCP scrt1_null_3f( x2676 ) TSCP x2676; { PUSHSTACKTRACE( t3766 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( x2676 ), _S2CUINT( EMPTYLIST ) ) ) ); } DEFTSCP( scrt1_list_3f_v ); DEFCSTRING( t3768, "LIST?" ); TSCP scrt1_list_3f( x2683 ) TSCP x2683; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3768 ); if ( EQ( _S2CUINT( x2683 ), _S2CUINT( EMPTYLIST ) ) ) goto L3771; if ( NEQ( TSCPTAG( x2683 ), PAIRTAG ) ) goto L3773; X1 = PAIR_CDR( x2683 ); X2 = x2683; L3776: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3777; if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3779; if ( EQ( _S2CUINT( X1 ), _S2CUINT( X2 ) ) ) goto L3781; X3 = PAIR_CDR( X1 ); X4 = X2; if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3785; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3787; if ( EQ( _S2CUINT( X3 ), _S2CUINT( X4 ) ) ) goto L3789; X5 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3793; scrt1__24__cdr_2derror( X4 ); L3793: X2 = PAIR_CDR( X4 ); X1 = X5; GOBACK( L3776 ); L3789: POPSTACKTRACE( FALSEVALUE ); L3787: POPSTACKTRACE( FALSEVALUE ); L3785: POPSTACKTRACE( TRUEVALUE ); L3781: POPSTACKTRACE( FALSEVALUE ); L3779: POPSTACKTRACE( FALSEVALUE ); L3777: POPSTACKTRACE( TRUEVALUE ); L3773: POPSTACKTRACE( FALSEVALUE ); L3771: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( scrt1_list_v ); DEFCSTRING( t3795, "LIST" ); TSCP scrt1_list( x2737 ) TSCP x2737; { PUSHSTACKTRACE( t3795 ); POPSTACKTRACE( x2737 ); } DEFTSCP( scrt1_length_v ); DEFCSTRING( t3797, "LENGTH" ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); TSCP scrt1_length( x2739 ) TSCP x2739; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3797 ); X1 = _TSCP( 0 ); X2 = x2739; L3800: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3801; if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3803; X3 = _TSCP( IPLUS( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3804; L3803: X3 = scrt2__2b_2dtwo( X1, _TSCP( 4 ) ); L3804: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3806; scrt1__24__cdr_2derror( X2 ); L3806: X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L3800 ); L3801: POPSTACKTRACE( X1 ); } DEFTSCP( scrt1_append_2dtwo_v ); DEFCSTRING( t3808, "SCRT1_APPEND-TWO" ); TSCP scrt1_append_2dtwo( x2761, y2762 ) TSCP x2761, y2762; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3808 ); if ( EQ( _S2CUINT( x2761 ), _S2CUINT( EMPTYLIST ) ) ) goto L3810; if ( EQ( TSCPTAG( x2761 ), PAIRTAG ) ) goto L3813; scrt1__24__car_2derror( x2761 ); L3813: X2 = PAIR_CAR( x2761 ); X1 = sc_cons( X2, EMPTYLIST ); X2 = PAIR_CDR( x2761 ); X3 = X1; X4 = X2; L3819: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3820; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3824; scdebug_error( c2674, c2665, CONS( X3, EMPTYLIST ) ); L3824: SETGEN( PAIR_CDR( X3 ), y2762 ); POPSTACKTRACE( X1 ); L3820: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3828; scrt1__24__car_2derror( X4 ); L3828: X6 = PAIR_CAR( X4 ); X5 = sc_cons( X6, EMPTYLIST ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3831; scdebug_error( c2674, c2665, CONS( X3, EMPTYLIST ) ); L3831: SETGEN( PAIR_CDR( X3 ), X5 ); X5 = PAIR_CDR( X3 ); X4 = PAIR_CDR( X4 ); X3 = X5; GOBACK( L3819 ); L3810: POPSTACKTRACE( y2762 ); } DEFTSCP( scrt1_append_v ); DEFCSTRING( t3835, "APPEND" ); EXTERNTSCPP( scrt1_a2819, XAL1( TSCP ) ); TSCP scrt1_a2819( x2821 ) TSCP x2821; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "APPEND-LIST [inside APPEND]" ); X1 = scrt1_length( x2821 ); if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3840; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L3842; if ( EQ( TSCPTAG( x2821 ), PAIRTAG ) ) goto L3845; scrt1__24__car_2derror( x2821 ); L3845: POPSTACKTRACE( PAIR_CAR( x2821 ) ); L3842: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 8 ) ) ) ) goto L3847; if ( EQ( TSCPTAG( x2821 ), PAIRTAG ) ) goto L3850; scrt1__24__car_2derror( x2821 ); L3850: X2 = PAIR_CAR( x2821 ); X4 = PAIR_CDR( x2821 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3854; scrt1__24__car_2derror( X4 ); L3854: X3 = PAIR_CAR( X4 ); POPSTACKTRACE( scrt1_append_2dtwo( X2, X3 ) ); L3847: if ( EQ( TSCPTAG( x2821 ), PAIRTAG ) ) goto L3857; scrt1__24__car_2derror( x2821 ); L3857: X2 = PAIR_CAR( x2821 ); X4 = PAIR_CDR( x2821 ); X3 = scrt1_a2819( X4 ); POPSTACKTRACE( scrt1_append_2dtwo( X2, X3 ) ); L3840: POPSTACKTRACE( EMPTYLIST ); } TSCP scrt1_append( x2817 ) TSCP x2817; { PUSHSTACKTRACE( t3835 ); POPSTACKTRACE( scrt1_a2819( x2817 ) ); } DEFTSCP( scrt1_reverse_v ); DEFCSTRING( t3860, "REVERSE" ); TSCP scrt1_reverse( x2861 ) TSCP x2861; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3860 ); X1 = EMPTYLIST; X2 = x2861; L3863: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3864; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3867; scrt1__24__car_2derror( X2 ); L3867: X4 = PAIR_CAR( X2 ); X3 = sc_cons( X4, X1 ); X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L3863 ); L3864: POPSTACKTRACE( X1 ); } DEFTSCP( scrt1_list_2dtail_v ); DEFCSTRING( t3870, "LIST-TAIL" ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); TSCP scrt1_list_2dtail( x2881, k2882 ) TSCP x2881, k2882; { TSCP X1; PUSHSTACKTRACE( t3870 ); L3871: if ( NEQ( TSCPTAG( k2882 ), FIXNUMTAG ) ) goto L3873; if ( NEQ( _S2CUINT( k2882 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3877; POPSTACKTRACE( x2881 ); L3873: if ( FALSE( scrt2_zero_3f( k2882 ) ) ) goto L3877; POPSTACKTRACE( x2881 ); L3877: if ( EQ( TSCPTAG( x2881 ), PAIRTAG ) ) goto L3881; scrt1__24__cdr_2derror( x2881 ); L3881: X1 = PAIR_CDR( x2881 ); if ( BITAND( BITOR( _S2CINT( k2882 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3883; k2882 = _TSCP( IDIFFERENCE( _S2CINT( k2882 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3884; L3883: k2882 = scrt2__2d_2dtwo( k2882, _TSCP( 4 ) ); L3884: x2881 = X1; GOBACK( L3871 ); } DEFTSCP( scrt1_list_2dref_v ); DEFCSTRING( t3885, "LIST-REF" ); TSCP scrt1_list_2dref( x2903, k2904 ) TSCP x2903, k2904; { TSCP X1; PUSHSTACKTRACE( t3885 ); X1 = scrt1_list_2dtail( x2903, k2904 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3888; scrt1__24__car_2derror( X1 ); L3888: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt1_last_2dpair_v ); DEFCSTRING( t3890, "LAST-PAIR" ); TSCP scrt1_last_2dpair( x2910 ) TSCP x2910; { TSCP X1; PUSHSTACKTRACE( t3890 ); L3891: if ( EQ( TSCPTAG( x2910 ), PAIRTAG ) ) goto L3893; scrt1__24__cdr_2derror( x2910 ); L3893: X1 = PAIR_CDR( x2910 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3896; x2910 = X1; GOBACK( L3891 ); L3896: POPSTACKTRACE( x2910 ); } DEFTSCP( scrt1_memq_v ); DEFCSTRING( t3898, "MEMQ" ); TSCP scrt1_memq( x2920, y2921 ) TSCP x2920, y2921; { TSCP X1; PUSHSTACKTRACE( t3898 ); L3899: if ( EQ( _S2CUINT( y2921 ), _S2CUINT( EMPTYLIST ) ) ) goto L3900; if ( EQ( TSCPTAG( y2921 ), PAIRTAG ) ) goto L3905; scrt1__24__car_2derror( y2921 ); L3905: X1 = PAIR_CAR( y2921 ); if ( EQ( _S2CUINT( x2920 ), _S2CUINT( X1 ) ) ) goto L3902; y2921 = PAIR_CDR( y2921 ); GOBACK( L3899 ); L3902: POPSTACKTRACE( y2921 ); L3900: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt1_memv_v ); DEFCSTRING( t3908, "MEMV" ); TSCP scrt1_memv( x2939, y2940 ) TSCP x2939, y2940; { TSCP X1; PUSHSTACKTRACE( t3908 ); L3909: if ( EQ( _S2CUINT( y2940 ), _S2CUINT( EMPTYLIST ) ) ) goto L3910; if ( EQ( TSCPTAG( y2940 ), PAIRTAG ) ) goto L3915; scrt1__24__car_2derror( y2940 ); L3915: X1 = PAIR_CAR( y2940 ); if ( OR( EQ( _S2CUINT( x2939 ), _S2CUINT( X1 ) ), AND( EQ( TSCPTAG( x2939 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( x2939 ), DOUBLEFLOATTAG ), AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( X1 ), DOUBLEFLOATTAG ), EQ( FLOAT_VALUE( x2939 ), FLOAT_VALUE( X1 ) ) ) ) ) ) ) ) goto L3912; y2940 = PAIR_CDR( y2940 ); GOBACK( L3909 ); L3912: POPSTACKTRACE( y2940 ); L3910: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt1_member_v ); DEFCSTRING( t3918, "MEMBER" ); TSCP scrt1_member( x2958, y2959 ) TSCP x2958, y2959; { TSCP X1; PUSHSTACKTRACE( t3918 ); L3919: if ( EQ( _S2CUINT( y2959 ), _S2CUINT( EMPTYLIST ) ) ) goto L3920; if ( EQ( TSCPTAG( y2959 ), PAIRTAG ) ) goto L3925; scrt1__24__car_2derror( y2959 ); L3925: X1 = PAIR_CAR( y2959 ); if ( TRUE( scrt1_equal_3f( x2958, X1 ) ) ) goto L3922; y2959 = PAIR_CDR( y2959 ); GOBACK( L3919 ); L3922: POPSTACKTRACE( y2959 ); L3920: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt1_assq_v ); DEFCSTRING( t3928, "ASSQ" ); TSCP scrt1_assq( x2974, y2975 ) TSCP x2974, y2975; { TSCP X2, X1; PUSHSTACKTRACE( t3928 ); L3929: if ( FALSE( y2975 ) ) goto L3930; if ( EQ( TSCPTAG( y2975 ), PAIRTAG ) ) goto L3933; scrt1__24__car_2derror( y2975 ); L3933: X1 = PAIR_CAR( y2975 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3939; scrt1__24__car_2derror( X1 ); L3939: X2 = PAIR_CAR( X1 ); if ( EQ( _S2CUINT( x2974 ), _S2CUINT( X2 ) ) ) goto L3936; y2975 = PAIR_CDR( y2975 ); GOBACK( L3929 ); L3936: POPSTACKTRACE( X1 ); L3930: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt1_assv_v ); DEFCSTRING( t3942, "ASSV" ); TSCP scrt1_assv( x2994, y2995 ) TSCP x2994, y2995; { TSCP X2, X1; PUSHSTACKTRACE( t3942 ); L3943: if ( FALSE( y2995 ) ) goto L3944; if ( EQ( TSCPTAG( y2995 ), PAIRTAG ) ) goto L3947; scrt1__24__car_2derror( y2995 ); L3947: X1 = PAIR_CAR( y2995 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3953; scrt1__24__car_2derror( X1 ); L3953: X2 = PAIR_CAR( X1 ); if ( OR( EQ( _S2CUINT( x2994 ), _S2CUINT( X2 ) ), AND( EQ( TSCPTAG( x2994 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( x2994 ), DOUBLEFLOATTAG ), AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( X2 ), DOUBLEFLOATTAG ), EQ( FLOAT_VALUE( x2994 ), FLOAT_VALUE( X2 ) ) ) ) ) ) ) ) goto L3950; y2995 = PAIR_CDR( y2995 ); GOBACK( L3943 ); L3950: POPSTACKTRACE( X1 ); L3944: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt1_assoc_v ); DEFCSTRING( t3956, "ASSOC" ); TSCP scrt1_assoc( x3014, y3015 ) TSCP x3014, y3015; { TSCP X2, X1; PUSHSTACKTRACE( t3956 ); L3957: if ( FALSE( y3015 ) ) goto L3958; if ( EQ( TSCPTAG( y3015 ), PAIRTAG ) ) goto L3961; scrt1__24__car_2derror( y3015 ); L3961: X1 = PAIR_CAR( y3015 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3967; scrt1__24__car_2derror( X1 ); L3967: X2 = PAIR_CAR( X1 ); if ( TRUE( scrt1_equal_3f( x3014, X2 ) ) ) goto L3964; y3015 = PAIR_CDR( y3015 ); GOBACK( L3957 ); L3964: POPSTACKTRACE( X1 ); L3958: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt1_remq_v ); DEFCSTRING( t3970, "REMQ" ); EXTERNTSCPP( scrt1_remq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_remq_v ); TSCP scrt1_remq( x3031, y3032 ) TSCP x3031, y3032; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3970 ); L3971: if ( EQ( _S2CUINT( y3032 ), _S2CUINT( EMPTYLIST ) ) ) goto L3972; if ( EQ( TSCPTAG( y3032 ), PAIRTAG ) ) goto L3977; scrt1__24__car_2derror( y3032 ); L3977: X1 = PAIR_CAR( y3032 ); if ( NEQ( _S2CUINT( x3031 ), _S2CUINT( X1 ) ) ) goto L3974; y3032 = PAIR_CDR( y3032 ); GOBACK( L3971 ); L3974: if ( EQ( TSCPTAG( y3032 ), PAIRTAG ) ) goto L3981; scrt1__24__car_2derror( y3032 ); L3981: X1 = PAIR_CAR( y3032 ); X3 = PAIR_CDR( y3032 ); X2 = scrt1_remq( x3031, X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L3972: POPSTACKTRACE( y3032 ); } DEFTSCP( scrt1_remv_v ); DEFCSTRING( t3984, "REMV" ); EXTERNTSCPP( scrt1_remv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_remv_v ); TSCP scrt1_remv( x3058, y3059 ) TSCP x3058, y3059; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3984 ); L3985: if ( EQ( _S2CUINT( y3059 ), _S2CUINT( EMPTYLIST ) ) ) goto L3986; if ( EQ( TSCPTAG( y3059 ), PAIRTAG ) ) goto L3991; scrt1__24__car_2derror( y3059 ); L3991: X1 = PAIR_CAR( y3059 ); if ( NOT( OR( EQ( _S2CUINT( x3058 ), _S2CUINT( X1 ) ), AND( EQ( TSCPTAG( x3058 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( x3058 ), DOUBLEFLOATTAG ), AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( X1 ), DOUBLEFLOATTAG ), EQ( FLOAT_VALUE( x3058 ), FLOAT_VALUE( X1 ) ) ) ) ) ) ) ) ) goto L3988; y3059 = PAIR_CDR( y3059 ); GOBACK( L3985 ); L3988: if ( EQ( TSCPTAG( y3059 ), PAIRTAG ) ) goto L3995; scrt1__24__car_2derror( y3059 ); L3995: X1 = PAIR_CAR( y3059 ); X3 = PAIR_CDR( y3059 ); X2 = scrt1_remv( x3058, X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L3986: POPSTACKTRACE( y3059 ); } DEFTSCP( scrt1_remove_v ); DEFCSTRING( t3998, "REMOVE" ); EXTERNTSCPP( scrt1_remove, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_remove_v ); TSCP scrt1_remove( x3085, y3086 ) TSCP x3085, y3086; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3998 ); L3999: if ( EQ( _S2CUINT( y3086 ), _S2CUINT( EMPTYLIST ) ) ) goto L4000; if ( EQ( TSCPTAG( y3086 ), PAIRTAG ) ) goto L4005; scrt1__24__car_2derror( y3086 ); L4005: X1 = PAIR_CAR( y3086 ); if ( FALSE( scrt1_equal_3f( x3085, X1 ) ) ) goto L4002; y3086 = PAIR_CDR( y3086 ); GOBACK( L3999 ); L4002: if ( EQ( TSCPTAG( y3086 ), PAIRTAG ) ) goto L4009; scrt1__24__car_2derror( y3086 ); L4009: X1 = PAIR_CAR( y3086 ); X3 = PAIR_CDR( y3086 ); X2 = scrt1_remove( x3085, X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L4000: POPSTACKTRACE( y3086 ); } DEFTSCP( scrt1_remq_21_v ); DEFCSTRING( t4012, "REMQ!" ); TSCP scrt1_remq_21( x3109, y3110 ) TSCP x3109, y3110; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4012 ); L4013: if ( EQ( _S2CUINT( y3110 ), _S2CUINT( EMPTYLIST ) ) ) goto L4014; if ( EQ( TSCPTAG( y3110 ), PAIRTAG ) ) goto L4019; scrt1__24__car_2derror( y3110 ); L4019: X1 = PAIR_CAR( y3110 ); if ( NEQ( _S2CUINT( x3109 ), _S2CUINT( X1 ) ) ) goto L4016; y3110 = PAIR_CDR( y3110 ); GOBACK( L4013 ); L4016: X1 = y3110; L4023: if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4027; scrt1__24__cdr_2derror( X1 ); L4027: X2 = PAIR_CDR( X1 ); if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4024; X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4033; scrt1__24__car_2derror( X3 ); L4033: X2 = PAIR_CAR( X3 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( x3109 ) ) ) goto L4029; X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4038; scrt1__24__cdr_2derror( X3 ); L4038: X2 = PAIR_CDR( X3 ); SETGEN( PAIR_CDR( X1 ), X2 ); GOBACK( L4023 ); L4029: X1 = PAIR_CDR( X1 ); GOBACK( L4023 ); L4024: POPSTACKTRACE( y3110 ); L4014: POPSTACKTRACE( y3110 ); } DEFTSCP( scrt1_remv_21_v ); DEFCSTRING( t4042, "REMV!" ); TSCP scrt1_remv_21( x3176, y3177 ) TSCP x3176, y3177; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4042 ); L4043: if ( EQ( _S2CUINT( y3177 ), _S2CUINT( EMPTYLIST ) ) ) goto L4044; if ( EQ( TSCPTAG( y3177 ), PAIRTAG ) ) goto L4049; scrt1__24__car_2derror( y3177 ); L4049: X1 = PAIR_CAR( y3177 ); if ( NOT( OR( EQ( _S2CUINT( x3176 ), _S2CUINT( X1 ) ), AND( EQ( TSCPTAG( x3176 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( x3176 ), DOUBLEFLOATTAG ), AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( X1 ), DOUBLEFLOATTAG ), EQ( FLOAT_VALUE( x3176 ), FLOAT_VALUE( X1 ) ) ) ) ) ) ) ) ) goto L4046; y3177 = PAIR_CDR( y3177 ); GOBACK( L4043 ); L4046: X1 = y3177; L4053: if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4057; scrt1__24__cdr_2derror( X1 ); L4057: X2 = PAIR_CDR( X1 ); if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4054; X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4063; scrt1__24__car_2derror( X3 ); L4063: X2 = PAIR_CAR( X3 ); if ( NOT( OR( EQ( _S2CUINT( X2 ), _S2CUINT( x3176 ) ), AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( X2 ), DOUBLEFLOATTAG ), AND( EQ( TSCPTAG( x3176 ), EXTENDEDTAG ), AND( EQ( TSCP_EXTENDEDTAG( x3176 ), DOUBLEFLOATTAG ), EQ( FLOAT_VALUE( X2 ), FLOAT_VALUE( x3176 ) ) ) ) ) ) ) ) ) goto L4059; X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4068; scrt1__24__cdr_2derror( X3 ); L4068: X2 = PAIR_CDR( X3 ); SETGEN( PAIR_CDR( X1 ), X2 ); GOBACK( L4053 ); L4059: X1 = PAIR_CDR( X1 ); GOBACK( L4053 ); L4054: POPSTACKTRACE( y3177 ); L4044: POPSTACKTRACE( y3177 ); } DEFTSCP( scrt1_remove_21_v ); DEFCSTRING( t4072, "REMOVE!" ); TSCP scrt1_remove_21( x3243, y3244 ) TSCP x3243, y3244; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4072 ); L4073: if ( EQ( _S2CUINT( y3244 ), _S2CUINT( EMPTYLIST ) ) ) goto L4074; if ( EQ( TSCPTAG( y3244 ), PAIRTAG ) ) goto L4079; scrt1__24__car_2derror( y3244 ); L4079: X1 = PAIR_CAR( y3244 ); if ( FALSE( scrt1_equal_3f( x3243, X1 ) ) ) goto L4076; y3244 = PAIR_CDR( y3244 ); GOBACK( L4073 ); L4076: X1 = y3244; L4083: if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4087; scrt1__24__cdr_2derror( X1 ); L4087: X2 = PAIR_CDR( X1 ); if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4084; X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4093; scrt1__24__car_2derror( X3 ); L4093: X2 = PAIR_CAR( X3 ); if ( FALSE( scrt1_equal_3f( X2, x3243 ) ) ) goto L4089; X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4098; scrt1__24__cdr_2derror( X3 ); L4098: X2 = PAIR_CDR( X3 ); SETGEN( PAIR_CDR( X1 ), X2 ); GOBACK( L4083 ); L4089: X1 = PAIR_CDR( X1 ); GOBACK( L4083 ); L4084: POPSTACKTRACE( y3244 ); L4074: POPSTACKTRACE( y3244 ); } void scrt4__init(); void scrt3__init(); void scdebug__init(); void scrt2__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt4__init(); scrt3__init(); scdebug__init(); scrt2__init(); MAXDISPLAY( 0 ); } void scrt1__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scrt1 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3313, ADR( scrt1_not_v ), MAKEPROCEDURE( 1, 0, scrt1_not, EMPTYLIST ) ); INITIALIZEVAR( t3317, ADR( scrt1_boolean_3f_v ), MAKEPROCEDURE( 1, 0, scrt1_boolean_3f, EMPTYLIST ) ); INITIALIZEVAR( t3321, ADR( scrt1_eqv_3f_v ), MAKEPROCEDURE( 2, 0, scrt1_eqv_3f, EMPTYLIST ) ); INITIALIZEVAR( t3323, ADR( scrt1_eq_3f_v ), MAKEPROCEDURE( 2, 0, scrt1_eq_3f, EMPTYLIST ) ); INITIALIZEVAR( t3325, ADR( scrt1_equal_3f_v ), MAKEPROCEDURE( 2, 0, scrt1_equal_3f, EMPTYLIST ) ); INITIALIZEVAR( t3380, ADR( scrt1_pair_3f_v ), MAKEPROCEDURE( 1, 0, scrt1_pair_3f, EMPTYLIST ) ); INITIALIZEVAR( t3382, ADR( scrt1_cons_2a_v ), MAKEPROCEDURE( 1, 1, scrt1_cons_2a, EMPTYLIST ) ); INITIALIZEVAR( t3398, ADR( scrt1__24__car_2derror_v ), MAKEPROCEDURE( 1, 0, scrt1__24__car_2derror, EMPTYLIST ) ); INITIALIZEVAR( t3400, ADR( scrt1__24__cdr_2derror_v ), MAKEPROCEDURE( 1, 0, scrt1__24__cdr_2derror, EMPTYLIST ) ); INITIALIZEVAR( t3402, ADR( scrt1_car_v ), MAKEPROCEDURE( 1, 0, scrt1_car, EMPTYLIST ) ); INITIALIZEVAR( t3407, ADR( scrt1_cdr_v ), MAKEPROCEDURE( 1, 0, scrt1_cdr, EMPTYLIST ) ); INITIALIZEVAR( t3412, ADR( scrt1_caar_v ), MAKEPROCEDURE( 1, 0, scrt1_caar, EMPTYLIST ) ); INITIALIZEVAR( t3420, ADR( scrt1_cadr_v ), MAKEPROCEDURE( 1, 0, scrt1_cadr, EMPTYLIST ) ); INITIALIZEVAR( t3428, ADR( scrt1_cdar_v ), MAKEPROCEDURE( 1, 0, scrt1_cdar, EMPTYLIST ) ); INITIALIZEVAR( t3436, ADR( scrt1_cddr_v ), MAKEPROCEDURE( 1, 0, scrt1_cddr, EMPTYLIST ) ); INITIALIZEVAR( t3444, ADR( scrt1_caaar_v ), MAKEPROCEDURE( 1, 0, scrt1_caaar, EMPTYLIST ) ); INITIALIZEVAR( t3455, ADR( scrt1_caadr_v ), MAKEPROCEDURE( 1, 0, scrt1_caadr, EMPTYLIST ) ); INITIALIZEVAR( t3466, ADR( scrt1_cadar_v ), MAKEPROCEDURE( 1, 0, scrt1_cadar, EMPTYLIST ) ); INITIALIZEVAR( t3477, ADR( scrt1_caddr_v ), MAKEPROCEDURE( 1, 0, scrt1_caddr, EMPTYLIST ) ); INITIALIZEVAR( t3488, ADR( scrt1_cdaar_v ), MAKEPROCEDURE( 1, 0, scrt1_cdaar, EMPTYLIST ) ); INITIALIZEVAR( t3499, ADR( scrt1_cdadr_v ), MAKEPROCEDURE( 1, 0, scrt1_cdadr, EMPTYLIST ) ); INITIALIZEVAR( t3510, ADR( scrt1_cddar_v ), MAKEPROCEDURE( 1, 0, scrt1_cddar, EMPTYLIST ) ); INITIALIZEVAR( t3521, ADR( scrt1_cdddr_v ), MAKEPROCEDURE( 1, 0, scrt1_cdddr, EMPTYLIST ) ); INITIALIZEVAR( t3532, ADR( scrt1_caaaar_v ), MAKEPROCEDURE( 1, 0, scrt1_caaaar, EMPTYLIST ) ); INITIALIZEVAR( t3546, ADR( scrt1_caaadr_v ), MAKEPROCEDURE( 1, 0, scrt1_caaadr, EMPTYLIST ) ); INITIALIZEVAR( t3560, ADR( scrt1_caadar_v ), MAKEPROCEDURE( 1, 0, scrt1_caadar, EMPTYLIST ) ); INITIALIZEVAR( t3574, ADR( scrt1_caaddr_v ), MAKEPROCEDURE( 1, 0, scrt1_caaddr, EMPTYLIST ) ); INITIALIZEVAR( t3588, ADR( scrt1_cadaar_v ), MAKEPROCEDURE( 1, 0, scrt1_cadaar, EMPTYLIST ) ); INITIALIZEVAR( t3602, ADR( scrt1_cadadr_v ), MAKEPROCEDURE( 1, 0, scrt1_cadadr, EMPTYLIST ) ); INITIALIZEVAR( t3616, ADR( scrt1_caddar_v ), MAKEPROCEDURE( 1, 0, scrt1_caddar, EMPTYLIST ) ); INITIALIZEVAR( t3630, ADR( scrt1_cadddr_v ), MAKEPROCEDURE( 1, 0, scrt1_cadddr, EMPTYLIST ) ); INITIALIZEVAR( t3644, ADR( scrt1_cdaaar_v ), MAKEPROCEDURE( 1, 0, scrt1_cdaaar, EMPTYLIST ) ); INITIALIZEVAR( t3658, ADR( scrt1_cdaadr_v ), MAKEPROCEDURE( 1, 0, scrt1_cdaadr, EMPTYLIST ) ); INITIALIZEVAR( t3672, ADR( scrt1_cdadar_v ), MAKEPROCEDURE( 1, 0, scrt1_cdadar, EMPTYLIST ) ); INITIALIZEVAR( t3686, ADR( scrt1_cdaddr_v ), MAKEPROCEDURE( 1, 0, scrt1_cdaddr, EMPTYLIST ) ); INITIALIZEVAR( t3700, ADR( scrt1_cddaar_v ), MAKEPROCEDURE( 1, 0, scrt1_cddaar, EMPTYLIST ) ); INITIALIZEVAR( t3714, ADR( scrt1_cddadr_v ), MAKEPROCEDURE( 1, 0, scrt1_cddadr, EMPTYLIST ) ); INITIALIZEVAR( t3728, ADR( scrt1_cdddar_v ), MAKEPROCEDURE( 1, 0, scrt1_cdddar, EMPTYLIST ) ); INITIALIZEVAR( t3742, ADR( scrt1_cddddr_v ), MAKEPROCEDURE( 1, 0, scrt1_cddddr, EMPTYLIST ) ); INITIALIZEVAR( t3756, ADR( scrt1_set_2dcar_21_v ), MAKEPROCEDURE( 2, 0, scrt1_set_2dcar_21, EMPTYLIST ) ); INITIALIZEVAR( t3761, ADR( scrt1_set_2dcdr_21_v ), MAKEPROCEDURE( 2, 0, scrt1_set_2dcdr_21, EMPTYLIST ) ); INITIALIZEVAR( t3766, ADR( scrt1_null_3f_v ), MAKEPROCEDURE( 1, 0, scrt1_null_3f, EMPTYLIST ) ); INITIALIZEVAR( t3768, ADR( scrt1_list_3f_v ), MAKEPROCEDURE( 1, 0, scrt1_list_3f, EMPTYLIST ) ); INITIALIZEVAR( t3795, ADR( scrt1_list_v ), MAKEPROCEDURE( 0, 1, scrt1_list, EMPTYLIST ) ); INITIALIZEVAR( t3797, ADR( scrt1_length_v ), MAKEPROCEDURE( 1, 0, scrt1_length, EMPTYLIST ) ); INITIALIZEVAR( t3808, ADR( scrt1_append_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt1_append_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t3835, ADR( scrt1_append_v ), MAKEPROCEDURE( 0, 1, scrt1_append, EMPTYLIST ) ); INITIALIZEVAR( t3860, ADR( scrt1_reverse_v ), MAKEPROCEDURE( 1, 0, scrt1_reverse, EMPTYLIST ) ); INITIALIZEVAR( t3870, ADR( scrt1_list_2dtail_v ), MAKEPROCEDURE( 2, 0, scrt1_list_2dtail, EMPTYLIST ) ); INITIALIZEVAR( t3885, ADR( scrt1_list_2dref_v ), MAKEPROCEDURE( 2, 0, scrt1_list_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3890, ADR( scrt1_last_2dpair_v ), MAKEPROCEDURE( 1, 0, scrt1_last_2dpair, EMPTYLIST ) ); INITIALIZEVAR( t3898, ADR( scrt1_memq_v ), MAKEPROCEDURE( 2, 0, scrt1_memq, EMPTYLIST ) ); INITIALIZEVAR( t3908, ADR( scrt1_memv_v ), MAKEPROCEDURE( 2, 0, scrt1_memv, EMPTYLIST ) ); INITIALIZEVAR( t3918, ADR( scrt1_member_v ), MAKEPROCEDURE( 2, 0, scrt1_member, EMPTYLIST ) ); INITIALIZEVAR( t3928, ADR( scrt1_assq_v ), MAKEPROCEDURE( 2, 0, scrt1_assq, EMPTYLIST ) ); INITIALIZEVAR( t3942, ADR( scrt1_assv_v ), MAKEPROCEDURE( 2, 0, scrt1_assv, EMPTYLIST ) ); INITIALIZEVAR( t3956, ADR( scrt1_assoc_v ), MAKEPROCEDURE( 2, 0, scrt1_assoc, EMPTYLIST ) ); INITIALIZEVAR( t3970, ADR( scrt1_remq_v ), MAKEPROCEDURE( 2, 0, scrt1_remq, EMPTYLIST ) ); INITIALIZEVAR( t3984, ADR( scrt1_remv_v ), MAKEPROCEDURE( 2, 0, scrt1_remv, EMPTYLIST ) ); INITIALIZEVAR( t3998, ADR( scrt1_remove_v ), MAKEPROCEDURE( 2, 0, scrt1_remove, EMPTYLIST ) ); INITIALIZEVAR( t4012, ADR( scrt1_remq_21_v ), MAKEPROCEDURE( 2, 0, scrt1_remq_21, EMPTYLIST ) ); INITIALIZEVAR( t4042, ADR( scrt1_remv_21_v ), MAKEPROCEDURE( 2, 0, scrt1_remv_21, EMPTYLIST ) ); INITIALIZEVAR( t4072, ADR( scrt1_remove_21_v ), MAKEPROCEDURE( 2, 0, scrt1_remove_21, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/scrt1.sc000066400000000000000000000157561203736146400161550ustar00rootroot00000000000000;;; SCHEME->C Runtime Library ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scrt1 (top-level NOT BOOLEAN? EQV? EQ? EQUAL? PAIR? CONS* CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR SET-CAR! SET-CDR! NULL? LIST? LIST LENGTH APPEND REVERSE LIST-TAIL LIST-REF LAST-PAIR MEMQ MEMV MEMBER ASSQ ASSV ASSOC REMQ REMV REMOVE REMQ! REMV! REMOVE!)) ;;; 6.1 Booleans. (define (NOT x) (not x)) (define (BOOLEAN? x) (or (eq? x #f) (eq? x #t))) ;;; 6.2 Equivalence Predicates. (define (EQV? x y) (eqv? x y)) (define (EQ? x y) (eq? x y)) (define (EQUAL? x y) (cond ((pair? x) (and (pair? y) (equal? (car x) (car y)) (equal? (cdr x) (cdr y)))) ((vector? x) (let ((lx (vector-length x))) (and (vector? y) (= (vector-length y) lx) (let test ((i (- lx 1))) (or (= i -1) (and (equal? (vector-ref x i) (vector-ref y i)) (test (- i 1)))))))) ((string? x) (and (string? y) (string=? x y))) ((%record? x) ((%record-lookup-method x '%to-equal?) x y)) (else (eqv? x y)))) ;;; 6.3 Pairs and Lists. (define (PAIR? x) (pair? x)) (define (CONS* x . y) (letrec ((cons*1 (lambda (x) (cond ((null? (cdr x)) (car x)) (else (cons (car x) (cons*1 (cdr x)))))))) (if y (cons x (cons*1 y)) x))) (define ($_CAR-ERROR x) (error 'CAR "Argument not a PAIR: ~a" x)) (define ($_CDR-ERROR x) (error 'CDR "Argument not a PAIR: ~a" x)) (define (CAR x) (car x)) (define (CDR x) (cdr x)) (define (CAAR x) (car (car x))) (define (CADR x) (car (cdr x))) (define (CDAR x) (cdr (car x))) (define (CDDR x) (cdr (cdr x))) (define (CAAAR x) (car (car (car x)))) (define (CAADR x) (car (car (cdr x)))) (define (CADAR x) (car (cdr (car x)))) (define (CADDR x) (car (cdr (cdr x)))) (define (CDAAR x) (cdr (car (car x)))) (define (CDADR x) (cdr (car (cdr x)))) (define (CDDAR x) (cdr (cdr (car x)))) (define (CDDDR x) (cdr (cdr (cdr x)))) (define (CAAAAR x) (car (car (car (car x))))) (define (CAAADR x) (car (car (car (cdr x))))) (define (CAADAR x) (car (car (cdr (car x))))) (define (CAADDR x) (car (car (cdr (cdr x))))) (define (CADAAR x) (car (cdr (car (car x))))) (define (CADADR x) (car (cdr (car (cdr x))))) (define (CADDAR x) (car (cdr (cdr (car x))))) (define (CADDDR x) (car (cdr (cdr (cdr x))))) (define (CDAAAR x) (cdr (car (car (car x))))) (define (CDAADR x) (cdr (car (car (cdr x))))) (define (CDADAR x) (cdr (car (cdr (car x))))) (define (CDADDR x) (cdr (car (cdr (cdr x))))) (define (CDDAAR x) (cdr (cdr (car (car x))))) (define (CDDADR x) (cdr (cdr (car (cdr x))))) (define (CDDDAR x) (cdr (cdr (cdr (car x))))) (define (CDDDDR x) (cdr (cdr (cdr (cdr x))))) (define (SET-CAR! x y) (set-car! x y)) (define (SET-CDR! x y) (set-cdr! x y)) (define (NULL? x) (null? x)) (define (LIST? x) (define (L1 x prev) (cond ((null? x) #t) ((pair? x) (if (eq? x prev) #f (l2 (cdr x) prev))) (else #f))) (define (L2 x prev) (cond ((null? x) #t) ((pair? x) (if (eq? x prev) #f (l1 (cdr x) (cdr prev)))) (else #f))) (cond ((null? x) #t) ((pair? x) (l1 (cdr x) x)) (else #f))) (define (LIST . x) x) (define (LENGTH x) (do ((len 0 (+ len 1)) (x x (cdr x))) ((null? x) len))) (define (APPEND-TWO x y) (if (null? x) y (let ((new (cons (car x) '()))) (let loop ((tail new) (old (cdr x))) (cond ((null? old) (set-cdr! tail y) new) (else (set-cdr! tail (cons (car old) '())) (loop (cdr tail) (cdr old)))))))) (define (APPEND . x) (define (APPEND-LIST x) (case (length x) ((0) '()) ((1) (car x)) ((2) (append-two (car x) (cadr x))) (else (append-two (car x) (append-list (cdr x)))))) (append-list x)) (define (REVERSE x) (do ((new '() (cons (car old) new)) (old x (cdr old))) ((null? old) new))) (define (LIST-TAIL x k) (if (zero? k) x (list-tail (cdr x) (- k 1)))) (define (LIST-REF x k) (car (list-tail x k))) (define (LAST-PAIR x) (let ((cdrx (cdr x))) (if (pair? cdrx) (last-pair cdrx) x))) (define (MEMQ x y) (cond ((null? y) #f) ((eq? x (car y)) y) (else (memq x (cdr y))))) (define (MEMV x y) (cond ((null? y) #f) ((eqv? x (car y)) y) (else (memv x (cdr y))))) (define (MEMBER x y) (cond ((null? y) #f) ((equal? x (car y)) y) (else (member x (cdr y))))) (define (ASSQ x y) (if y (let ((cary (car y))) (if (eq? x (car cary)) cary (assq x (cdr y)))) #f)) (define (ASSV x y) (if y (let ((cary (car y))) (if (eqv? x (car cary)) cary (assv x (cdr y)))) #f)) (define (ASSOC x y) (if y (let ((cary (car y))) (if (equal? x (car cary)) cary (assoc x (cdr y)))) #f)) (define (REMQ x y) (cond ((null? y) y) ((eq? x (car y)) (remq x (cdr y))) (else (cons (car y) (remq x (cdr y)))))) (define (REMV x y) (cond ((null? y) y) ((eqv? x (car y)) (remv x (cdr y))) (else (cons (car y) (remv x (cdr y)))))) (define (REMOVE x y) (cond ((null? y) y) ((equal? x (car y)) (remove x (cdr y))) (else (cons (car y) (remove x (cdr y)))))) (define (REMQ! x y) (cond ((null? y) y) ((eq? x (car y)) (remq! x (cdr y))) (else (let loop ((prev y)) (cond ((null? (cdr prev)) y) ((eq? (cadr prev) x) (set-cdr! prev (cddr prev)) (loop prev)) (else (loop (cdr prev)))))))) (define (REMV! x y) (cond ((null? y) y) ((eqv? x (car y)) (remv! x (cdr y))) (else (let loop ((prev y)) (cond ((null? (cdr prev)) y) ((eqv? (cadr prev) x) (set-cdr! prev (cddr prev)) (loop prev)) (else (loop (cdr prev)))))))) (define (REMOVE! x y) (cond ((null? y) y) ((equal? x (car y)) (remove! x (cdr y))) (else (let loop ((prev y)) (cond ((null? (cdr prev)) y) ((equal? (cadr prev) x) (set-cdr! prev (cddr prev)) (loop prev)) (else (loop (cdr prev)))))))) scheme2c-2012.10.14/scrt/scrt2.c000066400000000000000000003534311203736146400157660ustar00rootroot00000000000000 /* SCHEME->C */ #include void scrt2__init(); DEFCSTRING( t4776, "#b" ); DEFSTATICTSCP( c4268 ); DEFCSTRING( t4777, "#o" ); DEFSTATICTSCP( c4267 ); DEFCSTRING( t4778, "#x" ); DEFSTATICTSCP( c4266 ); DEFCSTRING( t4779, "Argument is not a RADIX: ~s" ); DEFSTATICTSCP( c4261 ); DEFSTATICTSCP( c4260 ); DEFSTATICTSCP( c4228 ); DEFCSTRING( t4780, "-" ); DEFSTATICTSCP( c4197 ); DEFCSTRING( t4781, "0123456789abcdef" ); DEFSTATICTSCP( c4170 ); DEFCSTRING( t4782, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c4169 ); DEFSTATICTSCP( c4168 ); DEFCSTRING( t4783, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c4147 ); DEFSTATICTSCP( c4146 ); DEFCSTRING( t4784, "~s" ); DEFSTATICTSCP( c4064 ); DEFCSTRING( t4785, "Argument is not a RADIX or FORMAT DESCRIPTOR: ~s" ); DEFSTATICTSCP( c4062 ); DEFSTATICTSCP( c3990 ); DEFSTATICTSCP( c3927 ); DEFSTATICTSCP( c3897 ); DEFSTATICTSCP( t4786 ); DEFSTATICTSCP( c3891 ); DEFSTATICTSCP( c3869 ); DEFSTATICTSCP( c3858 ); DEFSTATICTSCP( c3851 ); DEFSTATICTSCP( c3800 ); DEFCSTRING( t4787, "Argument must be a non-negative NUMBER: ~s" ); DEFSTATICTSCP( c3761 ); DEFSTATICTSCP( c3760 ); DEFSTATICTSCP( c3730 ); DEFCSTRING( t4788, "Divisor is equal to 0: ~s" ); DEFSTATICTSCP( c3155 ); DEFSTATICTSCP( c3145 ); DEFSTATICTSCP( c3075 ); DEFSTATICTSCP( c3028 ); DEFSTATICTSCP( c2982 ); DEFSTATICTSCP( c2842 ); DEFSTATICTSCP( c2778 ); DEFSTATICTSCP( c2714 ); DEFSTATICTSCP( c2650 ); DEFCSTRING( t4789, "Argument not a NUMBER: ~s" ); DEFSTATICTSCP( c2582 ); DEFCSTRING( t4790, "Argument(s) not a NUMBER: ~s ~s" ); DEFSTATICTSCP( c2579 ); DEFSTATICTSCP( c2578 ); DEFSTATICTSCP( c2560 ); DEFCSTRING( t4791, "Argument is not a NUMBER: ~s" ); DEFSTATICTSCP( c2543 ); DEFSTATICTSCP( c2542 ); DEFCSTRING( t4792, "Argument is not an FIXED: ~s" ); DEFSTATICTSCP( c2324 ); DEFSTATICTSCP( c2323 ); DEFCSTRING( t4793, "Argument is out of range: ~s" ); DEFSTATICTSCP( c2316 ); DEFCSTRING( t4794, "Argument is not a FLOAT: ~s" ); DEFSTATICTSCP( c2311 ); DEFSTATICTSCP( c2310 ); DEFSTATICTSCP( c2273 ); DEFCSTRING( t4795, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2253 ); DEFSTATICTSCP( c2252 ); DEFSTATICTSCP( c2209 ); DEFSTATICTSCP( c2202 ); DEFSTATICTSCP( c2158 ); DEFSTATICTSCP( c2152 ); DEFSTATICTSCP( c2146 ); DEFCSTRING( t4796, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c2141 ); DEFSTATICTSCP( c2140 ); static void init_constants() { c4268 = CSTRING_TSCP( t4776 ); CONSTANTEXP( ADR( c4268 ) ); c4267 = CSTRING_TSCP( t4777 ); CONSTANTEXP( ADR( c4267 ) ); c4266 = CSTRING_TSCP( t4778 ); CONSTANTEXP( ADR( c4266 ) ); c4261 = CSTRING_TSCP( t4779 ); CONSTANTEXP( ADR( c4261 ) ); c4260 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING->NUMBER" ) ); CONSTANTEXP( ADR( c4260 ) ); c4228 = EMPTYLIST; c4228 = CONS( _TSCP( 11026 ), c4228 ); c4228 = CONS( _TSCP( 11538 ), c4228 ); CONSTANTEXP( ADR( c4228 ) ); c4197 = CSTRING_TSCP( t4780 ); CONSTANTEXP( ADR( c4197 ) ); c4170 = CSTRING_TSCP( t4781 ); CONSTANTEXP( ADR( c4170 ) ); c4169 = CSTRING_TSCP( t4782 ); CONSTANTEXP( ADR( c4169 ) ); c4168 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c4168 ) ); c4147 = CSTRING_TSCP( t4783 ); CONSTANTEXP( ADR( c4147 ) ); c4146 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-REF" ) ); CONSTANTEXP( ADR( c4146 ) ); c4064 = CSTRING_TSCP( t4784 ); CONSTANTEXP( ADR( c4064 ) ); c4062 = CSTRING_TSCP( t4785 ); CONSTANTEXP( ADR( c4062 ) ); c3990 = STRINGTOSYMBOL( CSTRING_TSCP( "SCI" ) ); CONSTANTEXP( ADR( c3990 ) ); c3927 = STRINGTOSYMBOL( CSTRING_TSCP( "FIX" ) ); CONSTANTEXP( ADR( c3927 ) ); c3897 = EMPTYLIST; t4786 = STRINGTOSYMBOL( CSTRING_TSCP( "INT" ) ); c3897 = CONS( t4786, c3897 ); CONSTANTEXP( ADR( c3897 ) ); c3891 = STRINGTOSYMBOL( CSTRING_TSCP( "NUMBER->STRING" ) ); CONSTANTEXP( ADR( c3891 ) ); c3869 = STRINGTOSYMBOL( CSTRING_TSCP( "INEXACT->EXACT" ) ); CONSTANTEXP( ADR( c3869 ) ); c3858 = STRINGTOSYMBOL( CSTRING_TSCP( "EXACT->INEXACT" ) ); CONSTANTEXP( ADR( c3858 ) ); c3851 = DOUBLE_TSCP( 1. ); CONSTANTEXP( ADR( c3851 ) ); c3800 = DOUBLE_TSCP( 0. ); CONSTANTEXP( ADR( c3800 ) ); c3761 = CSTRING_TSCP( t4787 ); CONSTANTEXP( ADR( c3761 ) ); c3760 = STRINGTOSYMBOL( CSTRING_TSCP( "SQRT" ) ); CONSTANTEXP( ADR( c3760 ) ); c3730 = DOUBLE_TSCP( 0.5 ); CONSTANTEXP( ADR( c3730 ) ); c3155 = CSTRING_TSCP( t4788 ); CONSTANTEXP( ADR( c3155 ) ); c3145 = STRINGTOSYMBOL( CSTRING_TSCP( "/" ) ); CONSTANTEXP( ADR( c3145 ) ); c3075 = STRINGTOSYMBOL( CSTRING_TSCP( "-" ) ); CONSTANTEXP( ADR( c3075 ) ); c3028 = STRINGTOSYMBOL( CSTRING_TSCP( "*" ) ); CONSTANTEXP( ADR( c3028 ) ); c2982 = STRINGTOSYMBOL( CSTRING_TSCP( "+" ) ); CONSTANTEXP( ADR( c2982 ) ); c2842 = STRINGTOSYMBOL( CSTRING_TSCP( ">=" ) ); CONSTANTEXP( ADR( c2842 ) ); c2778 = STRINGTOSYMBOL( CSTRING_TSCP( "<=" ) ); CONSTANTEXP( ADR( c2778 ) ); c2714 = STRINGTOSYMBOL( CSTRING_TSCP( ">" ) ); CONSTANTEXP( ADR( c2714 ) ); c2650 = STRINGTOSYMBOL( CSTRING_TSCP( "<" ) ); CONSTANTEXP( ADR( c2650 ) ); c2582 = CSTRING_TSCP( t4789 ); CONSTANTEXP( ADR( c2582 ) ); c2579 = CSTRING_TSCP( t4790 ); CONSTANTEXP( ADR( c2579 ) ); c2578 = STRINGTOSYMBOL( CSTRING_TSCP( "=" ) ); CONSTANTEXP( ADR( c2578 ) ); c2560 = STRINGTOSYMBOL( CSTRING_TSCP( "INEXACT?" ) ); CONSTANTEXP( ADR( c2560 ) ); c2543 = CSTRING_TSCP( t4791 ); CONSTANTEXP( ADR( c2543 ) ); c2542 = STRINGTOSYMBOL( CSTRING_TSCP( "EXACT?" ) ); CONSTANTEXP( ADR( c2542 ) ); c2324 = CSTRING_TSCP( t4792 ); CONSTANTEXP( ADR( c2324 ) ); c2323 = STRINGTOSYMBOL( CSTRING_TSCP( "FIXED->FLOAT" ) ); CONSTANTEXP( ADR( c2323 ) ); c2316 = CSTRING_TSCP( t4793 ); CONSTANTEXP( ADR( c2316 ) ); c2311 = CSTRING_TSCP( t4794 ); CONSTANTEXP( ADR( c2311 ) ); c2310 = STRINGTOSYMBOL( CSTRING_TSCP( "FLOAT->FIXED" ) ); CONSTANTEXP( ADR( c2310 ) ); c2273 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2273 ) ); c2253 = CSTRING_TSCP( t4795 ); CONSTANTEXP( ADR( c2253 ) ); c2252 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CAR!" ) ); CONSTANTEXP( ADR( c2252 ) ); c2209 = STRINGTOSYMBOL( CSTRING_TSCP( "PUTPROP" ) ); CONSTANTEXP( ADR( c2209 ) ); c2202 = STRINGTOSYMBOL( CSTRING_TSCP( "GETPROP-ALL" ) ); CONSTANTEXP( ADR( c2202 ) ); c2158 = STRINGTOSYMBOL( CSTRING_TSCP( "GETPROP" ) ); CONSTANTEXP( ADR( c2158 ) ); c2152 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-TOP-LEVEL-VALUE!" ) ); CONSTANTEXP( ADR( c2152 ) ); c2146 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL-VALUE" ) ); CONSTANTEXP( ADR( c2146 ) ); c2141 = CSTRING_TSCP( t4796 ); CONSTANTEXP( ADR( c2141 ) ); c2140 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c2140 ) ); } DEFTSCP( scrt2_symbol_3f_v ); DEFCSTRING( t4797, "SYMBOL?" ); TSCP scrt2_symbol_3f( x2131 ) TSCP x2131; { PUSHSTACKTRACE( t4797 ); POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2131 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2131 ), SYMBOLTAG ) ) ) ); } DEFTSCP( scrt2_symbol_2d_3estring_v ); DEFCSTRING( t4799, "SYMBOL->STRING" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP scrt2_symbol_2d_3estring( x2135 ) TSCP x2135; { PUSHSTACKTRACE( t4799 ); if ( AND( EQ( TSCPTAG( x2135 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2135 ), SYMBOLTAG ) ) ) goto L4802; scdebug_error( c2140, c2141, CONS( x2135, EMPTYLIST ) ); L4802: POPSTACKTRACE( SYMBOL_NAME( x2135 ) ); } DEFTSCP( scrt2_top_2dlevel_2dvalue_v ); DEFCSTRING( t4804, "TOP-LEVEL-VALUE" ); TSCP scrt2_top_2dlevel_2dvalue( s2143 ) TSCP s2143; { PUSHSTACKTRACE( t4804 ); if ( AND( EQ( TSCPTAG( s2143 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( s2143 ), SYMBOLTAG ) ) ) goto L4806; scdebug_error( c2146, c2141, CONS( s2143, EMPTYLIST ) ); L4806: POPSTACKTRACE( SYMBOL_VALUE( s2143 ) ); } DEFTSCP( scrt2_2dvalue_21_c9d2a496_v ); DEFCSTRING( t4808, "SET-TOP-LEVEL-VALUE!" ); TSCP scrt2_2dvalue_21_c9d2a496( s2148, v2149 ) TSCP s2148, v2149; { PUSHSTACKTRACE( t4808 ); if ( AND( EQ( TSCPTAG( s2148 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( s2148 ), SYMBOLTAG ) ) ) goto L4810; scdebug_error( c2152, c2141, CONS( s2148, EMPTYLIST ) ); L4810: POPSTACKTRACE( SETGENTL( SYMBOL_VALUE( s2148 ), v2149 ) ); } DEFTSCP( scrt2_getprop_v ); DEFCSTRING( t4812, "GETPROP" ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); TSCP scrt2_getprop( s2154, k2155 ) TSCP s2154, k2155; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4812 ); if ( AND( EQ( TSCPTAG( s2154 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( s2154 ), SYMBOLTAG ) ) ) goto L4814; scdebug_error( c2158, c2141, CONS( s2154, EMPTYLIST ) ); L4814: X1 = SYMBOL_PROPERTYLIST( s2154 ); X2 = X1; L4818: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4819; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4824; scrt1__24__car_2derror( X2 ); L4824: X3 = PAIR_CAR( X2 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( k2155 ) ) ) goto L4821; X3 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4828; scrt1__24__car_2derror( X3 ); L4828: POPSTACKTRACE( PAIR_CAR( X3 ) ); L4821: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4831; scrt1__24__cdr_2derror( X2 ); L4831: X3 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4834; scrt1__24__cdr_2derror( X3 ); L4834: X2 = PAIR_CDR( X3 ); GOBACK( L4818 ); L4819: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt2_getprop_2dall_v ); DEFCSTRING( t4836, "GETPROP-ALL" ); TSCP scrt2_getprop_2dall( s2199 ) TSCP s2199; { PUSHSTACKTRACE( t4836 ); if ( AND( EQ( TSCPTAG( s2199 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( s2199 ), SYMBOLTAG ) ) ) goto L4838; scdebug_error( c2202, c2141, CONS( s2199, EMPTYLIST ) ); L4838: POPSTACKTRACE( SYMBOL_PROPERTYLIST( s2199 ) ); } DEFTSCP( scrt2_putprop_v ); DEFCSTRING( t4840, "PUTPROP" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP scrt2_putprop( s2204, k2205, v2206 ) TSCP s2204, k2205, v2206; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4840 ); if ( AND( EQ( TSCPTAG( s2204 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( s2204 ), SYMBOLTAG ) ) ) goto L4842; scdebug_error( c2209, c2141, CONS( s2204, EMPTYLIST ) ); L4842: X1 = SYMBOL_PROPERTYLIST( s2204 ); X2 = X1; X3 = EMPTYLIST; L4846: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4847; if ( EQ( _S2CUINT( v2206 ), _S2CUINT( FALSEVALUE ) ) ) goto L4859; if ( FALSE( X3 ) ) goto L4851; X6 = sc_cons( v2206, EMPTYLIST ); X5 = sc_cons( k2205, X6 ); X4 = X5; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4855; scdebug_error( c2273, c2253, CONS( X3, EMPTYLIST ) ); L4855: SETGEN( PAIR_CDR( X3 ), X4 ); goto L4859; L4851: X6 = sc_cons( v2206, EMPTYLIST ); X5 = sc_cons( k2205, X6 ); X4 = X5; SETGEN( SYMBOL_PROPERTYLIST( s2204 ), X4 ); goto L4859; L4847: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4861; scrt1__24__car_2derror( X2 ); L4861: X4 = PAIR_CAR( X2 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( k2205 ) ) ) goto L4858; if ( NEQ( _S2CUINT( v2206 ), _S2CUINT( FALSEVALUE ) ) ) goto L4863; if ( FALSE( X3 ) ) goto L4865; X5 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4869; scrt1__24__cdr_2derror( X5 ); L4869: X4 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4872; scdebug_error( c2273, c2253, CONS( X3, EMPTYLIST ) ); L4872: SETGEN( PAIR_CDR( X3 ), X4 ); goto L4859; L4865: X5 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4876; scrt1__24__cdr_2derror( X5 ); L4876: X4 = PAIR_CDR( X5 ); SETGEN( SYMBOL_PROPERTYLIST( s2204 ), X4 ); goto L4859; L4863: X4 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4880; scdebug_error( c2252, c2253, CONS( X4, EMPTYLIST ) ); L4880: SETGEN( PAIR_CAR( X4 ), v2206 ); goto L4859; L4858: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4883; scrt1__24__cdr_2derror( X2 ); L4883: X5 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4886; scrt1__24__cdr_2derror( X5 ); L4886: X4 = PAIR_CDR( X5 ); X3 = PAIR_CDR( X2 ); X2 = X4; GOBACK( L4846 ); L4859: POPSTACKTRACE( v2206 ); } DEFTSCP( scrt2_fixed_3f_v ); DEFCSTRING( t4889, "FIXED?" ); TSCP scrt2_fixed_3f( x2297 ) TSCP x2297; { PUSHSTACKTRACE( t4889 ); POPSTACKTRACE( BOOLEAN( EQ( TSCPTAG( x2297 ), FIXNUMTAG ) ) ); } DEFTSCP( scrt2_float_3f_v ); DEFCSTRING( t4891, "FLOAT?" ); TSCP scrt2_float_3f( x2301 ) TSCP x2301; { PUSHSTACKTRACE( t4891 ); POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2301 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2301 ), DOUBLEFLOATTAG ) ) ) ); } DEFTSCP( scrt2_float_2d_3efixed_v ); DEFCSTRING( t4893, "FLOAT->FIXED" ); TSCP scrt2_float_2d_3efixed( x2305 ) TSCP x2305; { TSCP X1; PUSHSTACKTRACE( t4893 ); if ( AND( EQ( TSCPTAG( x2305 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2305 ), DOUBLEFLOATTAG ) ) ) goto L4896; scdebug_error( c2310, c2311, CONS( x2305, EMPTYLIST ) ); L4896: X1 = BOOLEAN( LT( FLOAT_VALUE( x2305 ), MINTSCPINTF ) ); if ( TRUE( X1 ) ) goto L4902; if ( LTE( FLOAT_VALUE( x2305 ), MAXTSCPINTF ) ) goto L4905; L4902: scdebug_error( c2310, c2316, CONS( x2305, EMPTYLIST ) ); L4905: POPSTACKTRACE( FLT_FIX( x2305 ) ); } DEFTSCP( scrt2_fixed_2d_3efloat_v ); DEFCSTRING( t4906, "FIXED->FLOAT" ); TSCP scrt2_fixed_2d_3efloat( x2318 ) TSCP x2318; { PUSHSTACKTRACE( t4906 ); if ( EQ( TSCPTAG( x2318 ), FIXNUMTAG ) ) goto L4909; scdebug_error( c2323, c2324, CONS( x2318, EMPTYLIST ) ); L4909: POPSTACKTRACE( FIX_FLT( x2318 ) ); } DEFTSCP( scrt2_number_3f_v ); DEFCSTRING( t4911, "NUMBER?" ); TSCP scrt2_number_3f( x2326 ) TSCP x2326; { PUSHSTACKTRACE( t4911 ); if ( EQ( TSCPTAG( x2326 ), FIXNUMTAG ) ) goto L4913; POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2326 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2326 ), DOUBLEFLOATTAG ) ) ) ); L4913: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( scrt2_complex_3f_v ); DEFCSTRING( t4915, "COMPLEX?" ); TSCP scrt2_complex_3f( x2336 ) TSCP x2336; { PUSHSTACKTRACE( t4915 ); if ( EQ( TSCPTAG( x2336 ), FIXNUMTAG ) ) goto L4917; POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2336 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2336 ), DOUBLEFLOATTAG ) ) ) ); L4917: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( scrt2_real_3f_v ); DEFCSTRING( t4919, "REAL?" ); TSCP scrt2_real_3f( x2346 ) TSCP x2346; { PUSHSTACKTRACE( t4919 ); if ( EQ( TSCPTAG( x2346 ), FIXNUMTAG ) ) goto L4921; POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2346 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2346 ), DOUBLEFLOATTAG ) ) ) ); L4921: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( scrt2_rational_3f_v ); DEFCSTRING( t4923, "RATIONAL?" ); TSCP scrt2_rational_3f( x2356 ) TSCP x2356; { PUSHSTACKTRACE( t4923 ); if ( EQ( TSCPTAG( x2356 ), FIXNUMTAG ) ) goto L4925; POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2356 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2356 ), DOUBLEFLOATTAG ) ) ) ); L4925: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( scrt2_integer_3f_v ); DEFCSTRING( t4927, "INTEGER?" ); EXTERNTSCPP( scrt2_round, XAL1( TSCP ) ); EXTERNTSCP( scrt2_round_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); TSCP scrt2_integer_3f( x2370 ) TSCP x2370; { TSCP X1; PUSHSTACKTRACE( t4927 ); if ( EQ( TSCPTAG( x2370 ), FIXNUMTAG ) ) goto L4929; if ( NOT( AND( EQ( TSCPTAG( x2370 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2370 ), DOUBLEFLOATTAG ) ) ) ) goto L4931; X1 = scrt2_round( x2370 ); if ( BITAND( BITOR( _S2CINT( x2370 ), _S2CINT( X1 ) ), 3 ) ) goto L4934; POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( x2370 ), _S2CUINT( X1 ) ) ) ); L4934: POPSTACKTRACE( scrt2__3d_2dtwo( x2370, X1 ) ); L4931: POPSTACKTRACE( FALSEVALUE ); L4929: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( scrt2_zero_3f_v ); DEFCSTRING( t4936, "ZERO?" ); TSCP scrt2_zero_3f( x2395 ) TSCP x2395; { PUSHSTACKTRACE( t4936 ); if ( BITAND( BITOR( _S2CINT( x2395 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4938; POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( x2395 ), _S2CUINT( _TSCP( 0 ) ) ) ) ); L4938: POPSTACKTRACE( scrt2__3d_2dtwo( x2395, _TSCP( 0 ) ) ); } DEFTSCP( scrt2_positive_3f_v ); DEFCSTRING( t4940, "POSITIVE?" ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); TSCP scrt2_positive_3f( x2406 ) TSCP x2406; { PUSHSTACKTRACE( t4940 ); if ( BITAND( BITOR( _S2CINT( x2406 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4942; POPSTACKTRACE( BOOLEAN( GT( _S2CINT( x2406 ), _S2CINT( _TSCP( 0 ) ) ) ) ); L4942: POPSTACKTRACE( scrt2__3e_2dtwo( x2406, _TSCP( 0 ) ) ); } DEFTSCP( scrt2_negative_3f_v ); DEFCSTRING( t4944, "NEGATIVE?" ); EXTERNTSCPP( scrt2__3c_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_2dtwo_v ); TSCP scrt2_negative_3f( x2414 ) TSCP x2414; { PUSHSTACKTRACE( t4944 ); if ( BITAND( BITOR( _S2CINT( x2414 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4946; POPSTACKTRACE( BOOLEAN( LT( _S2CINT( x2414 ), _S2CINT( _TSCP( 0 ) ) ) ) ); L4946: POPSTACKTRACE( scrt2__3c_2dtwo( x2414, _TSCP( 0 ) ) ); } DEFTSCP( scrt2_odd_3f_v ); DEFCSTRING( t4948, "ODD?" ); EXTERNTSCPP( scrt2_remainder, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_remainder_v ); TSCP scrt2_odd_3f( x2422 ) TSCP x2422; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4948 ); if ( NEQ( TSCPTAG( x2422 ), FIXNUMTAG ) ) goto L4950; X1 = TRUEVALUE; goto L4953; L4950: if ( NOT( AND( EQ( TSCPTAG( x2422 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2422 ), DOUBLEFLOATTAG ) ) ) ) goto L4952; X2 = scrt2_round( x2422 ); if ( BITAND( BITOR( _S2CINT( x2422 ), _S2CINT( X2 ) ), 3 ) ) goto L4955; X1 = BOOLEAN( EQ( _S2CUINT( x2422 ), _S2CUINT( X2 ) ) ); goto L4953; L4955: X1 = scrt2__3d_2dtwo( x2422, X2 ); goto L4953; L4952: X1 = FALSEVALUE; L4953: if ( FALSE( X1 ) ) goto L4958; X3 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( x2422 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) ); if ( FALSE( X3 ) ) goto L4966; if ( EQ( _S2CUINT( _TSCP( 8 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4966; X2 = _TSCP( REMAINDER( _S2CINT( x2422 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L4967; L4966: X2 = scrt2_remainder( x2422, _TSCP( 8 ) ); L4967: if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L4969; POPSTACKTRACE( BOOLEAN( NEQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) ); L4969: if ( TRUE( scrt2_zero_3f( X2 ) ) ) goto L4971; POPSTACKTRACE( TRUEVALUE ); L4971: POPSTACKTRACE( FALSEVALUE ); L4958: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2_even_3f_v ); DEFCSTRING( t4973, "EVEN?" ); TSCP scrt2_even_3f( x2476 ) TSCP x2476; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4973 ); if ( NEQ( TSCPTAG( x2476 ), FIXNUMTAG ) ) goto L4975; X1 = TRUEVALUE; goto L4978; L4975: if ( NOT( AND( EQ( TSCPTAG( x2476 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2476 ), DOUBLEFLOATTAG ) ) ) ) goto L4977; X2 = scrt2_round( x2476 ); if ( BITAND( BITOR( _S2CINT( x2476 ), _S2CINT( X2 ) ), 3 ) ) goto L4980; X1 = BOOLEAN( EQ( _S2CUINT( x2476 ), _S2CUINT( X2 ) ) ); goto L4978; L4980: X1 = scrt2__3d_2dtwo( x2476, X2 ); goto L4978; L4977: X1 = FALSEVALUE; L4978: if ( FALSE( X1 ) ) goto L4983; X3 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( x2476 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) ); if ( FALSE( X3 ) ) goto L4991; if ( EQ( _S2CUINT( _TSCP( 8 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4991; X2 = _TSCP( REMAINDER( _S2CINT( x2476 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L4992; L4991: X2 = scrt2_remainder( x2476, _TSCP( 8 ) ); L4992: if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L4994; POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) ); L4994: POPSTACKTRACE( scrt2_zero_3f( X2 ) ); L4983: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2_exact_3f_v ); DEFCSTRING( t4996, "EXACT?" ); TSCP scrt2_exact_3f( x2529 ) TSCP x2529; { PUSHSTACKTRACE( t4996 ); if ( EQ( TSCPTAG( x2529 ), FIXNUMTAG ) ) goto L5001; if ( AND( EQ( TSCPTAG( x2529 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2529 ), DOUBLEFLOATTAG ) ) ) goto L5001; scdebug_error( c2542, c2543, CONS( x2529, EMPTYLIST ) ); L5001: POPSTACKTRACE( BOOLEAN( EQ( TSCPTAG( x2529 ), FIXNUMTAG ) ) ); } DEFTSCP( scrt2_inexact_3f_v ); DEFCSTRING( t5003, "INEXACT?" ); TSCP scrt2_inexact_3f( x2547 ) TSCP x2547; { PUSHSTACKTRACE( t5003 ); if ( EQ( TSCPTAG( x2547 ), FIXNUMTAG ) ) goto L5008; if ( AND( EQ( TSCPTAG( x2547 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2547 ), DOUBLEFLOATTAG ) ) ) goto L5008; scdebug_error( c2560, c2543, CONS( x2547, EMPTYLIST ) ); L5008: POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2547 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2547 ), DOUBLEFLOATTAG ) ) ) ); } DEFTSCP( scrt2__3d_2dtwo_v ); DEFCSTRING( t5010, "SCRT2_=-TWO" ); TSCP scrt2__3d_2dtwo( x2564, y2565 ) TSCP x2564, y2565; { TSCP X1; PUSHSTACKTRACE( t5010 ); if ( NEQ( TSCPTAG( x2564 ), FIXNUMTAG ) ) goto L5012; if ( NEQ( TSCPTAG( y2565 ), FIXNUMTAG ) ) goto L5014; POPSTACKTRACE( BOOLEAN( EQ( _S2CINT( x2564 ), _S2CINT( y2565 ) ) ) ); L5014: if ( NOT( AND( EQ( TSCPTAG( y2565 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2565 ), DOUBLEFLOATTAG ) ) ) ) goto L5016; POPSTACKTRACE( BOOLEAN( EQ( FIX_FLTV( x2564 ), FLOAT_VALUE( y2565 ) ) ) ); L5016: POPSTACKTRACE( scdebug_error( c2578, c2582, CONS( y2565, EMPTYLIST ) ) ); L5012: if ( NEQ( TSCPTAG( y2565 ), FIXNUMTAG ) ) goto L5018; if ( NOT( AND( EQ( TSCPTAG( x2564 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2564 ), DOUBLEFLOATTAG ) ) ) ) goto L5020; POPSTACKTRACE( BOOLEAN( EQ( FLOAT_VALUE( x2564 ), FIX_FLTV( y2565 ) ) ) ); L5020: POPSTACKTRACE( scdebug_error( c2578, c2582, CONS( x2564, EMPTYLIST ) ) ); L5018: X1 = BOOLEAN( AND( EQ( TSCPTAG( x2564 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2564 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5028; if ( NOT( AND( EQ( TSCPTAG( y2565 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2565 ), DOUBLEFLOATTAG ) ) ) ) goto L5028; POPSTACKTRACE( BOOLEAN( EQ( FLOAT_VALUE( x2564 ), FLOAT_VALUE( y2565 ) ) ) ); L5028: X1 = CONS( y2565, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c2578, c2579, CONS( x2564, X1 ) ) ); } DEFTSCP( scrt2__3d_v ); DEFCSTRING( t5029, "=" ); TSCP scrt2__3d( x2588, y2589, z2590 ) TSCP x2588, y2589, z2590; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5029 ); if ( BITAND( BITOR( _S2CINT( x2588 ), _S2CINT( y2589 ) ), 3 ) ) goto L5032; X1 = BOOLEAN( EQ( _S2CUINT( x2588 ), _S2CUINT( y2589 ) ) ); goto L5033; L5032: X1 = scrt2__3d_2dtwo( x2588, y2589 ); L5033: if ( FALSE( X1 ) ) goto L5035; X2 = y2589; X3 = z2590; L5037: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L5038; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5041; scrt1__24__car_2derror( X3 ); L5041: X4 = PAIR_CAR( X3 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) goto L5045; if ( EQ( _S2CUINT( X2 ), _S2CUINT( X4 ) ) ) goto L5049; POPSTACKTRACE( FALSEVALUE ); L5045: if ( TRUE( scrt2__3d_2dtwo( X2, X4 ) ) ) goto L5049; POPSTACKTRACE( FALSEVALUE ); L5038: POPSTACKTRACE( TRUEVALUE ); L5049: X4 = PAIR_CAR( X3 ); X3 = PAIR_CDR( X3 ); X2 = X4; GOBACK( L5037 ); L5035: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2__3c_2dtwo_v ); DEFCSTRING( t5054, "SCRT2_<-TWO" ); TSCP scrt2__3c_2dtwo( x2636, y2637 ) TSCP x2636, y2637; { TSCP X1; PUSHSTACKTRACE( t5054 ); if ( NEQ( TSCPTAG( x2636 ), FIXNUMTAG ) ) goto L5056; if ( NEQ( TSCPTAG( y2637 ), FIXNUMTAG ) ) goto L5058; POPSTACKTRACE( BOOLEAN( LT( _S2CINT( x2636 ), _S2CINT( y2637 ) ) ) ); L5058: if ( NOT( AND( EQ( TSCPTAG( y2637 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2637 ), DOUBLEFLOATTAG ) ) ) ) goto L5060; POPSTACKTRACE( BOOLEAN( LT( FIX_FLTV( x2636 ), FLOAT_VALUE( y2637 ) ) ) ); L5060: POPSTACKTRACE( scdebug_error( c2650, c2582, CONS( y2637, EMPTYLIST ) ) ); L5056: if ( NEQ( TSCPTAG( y2637 ), FIXNUMTAG ) ) goto L5062; if ( NOT( AND( EQ( TSCPTAG( x2636 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2636 ), DOUBLEFLOATTAG ) ) ) ) goto L5064; POPSTACKTRACE( BOOLEAN( LT( FLOAT_VALUE( x2636 ), FIX_FLTV( y2637 ) ) ) ); L5064: POPSTACKTRACE( scdebug_error( c2650, c2582, CONS( x2636, EMPTYLIST ) ) ); L5062: X1 = BOOLEAN( AND( EQ( TSCPTAG( x2636 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2636 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5072; if ( NOT( AND( EQ( TSCPTAG( y2637 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2637 ), DOUBLEFLOATTAG ) ) ) ) goto L5072; POPSTACKTRACE( BOOLEAN( LT( FLOAT_VALUE( x2636 ), FLOAT_VALUE( y2637 ) ) ) ); L5072: X1 = CONS( y2637, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c2650, c2579, CONS( x2636, X1 ) ) ); } DEFTSCP( scrt2__3c_v ); DEFCSTRING( t5073, "<" ); TSCP scrt2__3c( x2658, y2659, z2660 ) TSCP x2658, y2659, z2660; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5073 ); if ( BITAND( BITOR( _S2CINT( x2658 ), _S2CINT( y2659 ) ), 3 ) ) goto L5076; X1 = BOOLEAN( LT( _S2CINT( x2658 ), _S2CINT( y2659 ) ) ); goto L5077; L5076: X1 = scrt2__3c_2dtwo( x2658, y2659 ); L5077: if ( FALSE( X1 ) ) goto L5079; X2 = y2659; X3 = z2660; L5081: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L5082; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5085; scrt1__24__car_2derror( X3 ); L5085: X4 = PAIR_CAR( X3 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) goto L5089; if ( LT( _S2CINT( X2 ), _S2CINT( X4 ) ) ) goto L5093; POPSTACKTRACE( FALSEVALUE ); L5089: if ( TRUE( scrt2__3c_2dtwo( X2, X4 ) ) ) goto L5093; POPSTACKTRACE( FALSEVALUE ); L5082: POPSTACKTRACE( TRUEVALUE ); L5093: X4 = PAIR_CAR( X3 ); X3 = PAIR_CDR( X3 ); X2 = X4; GOBACK( L5081 ); L5079: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2__3e_2dtwo_v ); DEFCSTRING( t5098, "SCRT2_>-TWO" ); TSCP scrt2__3e_2dtwo( x2700, y2701 ) TSCP x2700, y2701; { TSCP X1; PUSHSTACKTRACE( t5098 ); if ( NEQ( TSCPTAG( x2700 ), FIXNUMTAG ) ) goto L5100; if ( NEQ( TSCPTAG( y2701 ), FIXNUMTAG ) ) goto L5102; POPSTACKTRACE( BOOLEAN( GT( _S2CINT( x2700 ), _S2CINT( y2701 ) ) ) ); L5102: if ( NOT( AND( EQ( TSCPTAG( y2701 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2701 ), DOUBLEFLOATTAG ) ) ) ) goto L5104; POPSTACKTRACE( BOOLEAN( GT( FIX_FLTV( x2700 ), FLOAT_VALUE( y2701 ) ) ) ); L5104: POPSTACKTRACE( scdebug_error( c2714, c2582, CONS( y2701, EMPTYLIST ) ) ); L5100: if ( NEQ( TSCPTAG( y2701 ), FIXNUMTAG ) ) goto L5106; if ( NOT( AND( EQ( TSCPTAG( x2700 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2700 ), DOUBLEFLOATTAG ) ) ) ) goto L5108; POPSTACKTRACE( BOOLEAN( GT( FLOAT_VALUE( x2700 ), FIX_FLTV( y2701 ) ) ) ); L5108: POPSTACKTRACE( scdebug_error( c2714, c2582, CONS( x2700, EMPTYLIST ) ) ); L5106: X1 = BOOLEAN( AND( EQ( TSCPTAG( x2700 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2700 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5116; if ( NOT( AND( EQ( TSCPTAG( y2701 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2701 ), DOUBLEFLOATTAG ) ) ) ) goto L5116; POPSTACKTRACE( BOOLEAN( GT( FLOAT_VALUE( x2700 ), FLOAT_VALUE( y2701 ) ) ) ); L5116: X1 = CONS( y2701, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c2714, c2579, CONS( x2700, X1 ) ) ); } DEFTSCP( scrt2__3e_v ); DEFCSTRING( t5117, ">" ); TSCP scrt2__3e( x2722, y2723, z2724 ) TSCP x2722, y2723, z2724; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5117 ); if ( BITAND( BITOR( _S2CINT( x2722 ), _S2CINT( y2723 ) ), 3 ) ) goto L5120; X1 = BOOLEAN( GT( _S2CINT( x2722 ), _S2CINT( y2723 ) ) ); goto L5121; L5120: X1 = scrt2__3e_2dtwo( x2722, y2723 ); L5121: if ( FALSE( X1 ) ) goto L5123; X2 = y2723; X3 = z2724; L5125: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L5126; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5129; scrt1__24__car_2derror( X3 ); L5129: X4 = PAIR_CAR( X3 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) goto L5133; if ( GT( _S2CINT( X2 ), _S2CINT( X4 ) ) ) goto L5137; POPSTACKTRACE( FALSEVALUE ); L5133: if ( TRUE( scrt2__3e_2dtwo( X2, X4 ) ) ) goto L5137; POPSTACKTRACE( FALSEVALUE ); L5126: POPSTACKTRACE( TRUEVALUE ); L5137: X4 = PAIR_CAR( X3 ); X3 = PAIR_CDR( X3 ); X2 = X4; GOBACK( L5125 ); L5123: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2__3c_3d_2dtwo_v ); DEFCSTRING( t5142, "SCRT2_<=-TWO" ); TSCP scrt2__3c_3d_2dtwo( x2764, y2765 ) TSCP x2764, y2765; { TSCP X1; PUSHSTACKTRACE( t5142 ); if ( NEQ( TSCPTAG( x2764 ), FIXNUMTAG ) ) goto L5144; if ( NEQ( TSCPTAG( y2765 ), FIXNUMTAG ) ) goto L5146; POPSTACKTRACE( BOOLEAN( LTE( _S2CINT( x2764 ), _S2CINT( y2765 ) ) ) ); L5146: if ( NOT( AND( EQ( TSCPTAG( y2765 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2765 ), DOUBLEFLOATTAG ) ) ) ) goto L5148; POPSTACKTRACE( BOOLEAN( LTE( FIX_FLTV( x2764 ), FLOAT_VALUE( y2765 ) ) ) ); L5148: POPSTACKTRACE( scdebug_error( c2778, c2582, CONS( y2765, EMPTYLIST ) ) ); L5144: if ( NEQ( TSCPTAG( y2765 ), FIXNUMTAG ) ) goto L5150; if ( NOT( AND( EQ( TSCPTAG( x2764 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2764 ), DOUBLEFLOATTAG ) ) ) ) goto L5152; POPSTACKTRACE( BOOLEAN( LTE( FLOAT_VALUE( x2764 ), FIX_FLTV( y2765 ) ) ) ); L5152: POPSTACKTRACE( scdebug_error( c2778, c2582, CONS( x2764, EMPTYLIST ) ) ); L5150: X1 = BOOLEAN( AND( EQ( TSCPTAG( x2764 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2764 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5160; if ( NOT( AND( EQ( TSCPTAG( y2765 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2765 ), DOUBLEFLOATTAG ) ) ) ) goto L5160; POPSTACKTRACE( BOOLEAN( LTE( FLOAT_VALUE( x2764 ), FLOAT_VALUE( y2765 ) ) ) ); L5160: X1 = CONS( y2765, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c2778, c2579, CONS( x2764, X1 ) ) ); } DEFTSCP( scrt2__3c_3d_v ); DEFCSTRING( t5161, "<=" ); TSCP scrt2__3c_3d( x2786, y2787, z2788 ) TSCP x2786, y2787, z2788; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5161 ); if ( BITAND( BITOR( _S2CINT( x2786 ), _S2CINT( y2787 ) ), 3 ) ) goto L5164; X1 = BOOLEAN( LTE( _S2CINT( x2786 ), _S2CINT( y2787 ) ) ); goto L5165; L5164: X1 = scrt2__3c_3d_2dtwo( x2786, y2787 ); L5165: if ( FALSE( X1 ) ) goto L5167; X2 = y2787; X3 = z2788; L5169: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L5170; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5173; scrt1__24__car_2derror( X3 ); L5173: X4 = PAIR_CAR( X3 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) goto L5177; if ( LTE( _S2CINT( X2 ), _S2CINT( X4 ) ) ) goto L5181; POPSTACKTRACE( FALSEVALUE ); L5177: if ( TRUE( scrt2__3c_3d_2dtwo( X2, X4 ) ) ) goto L5181; POPSTACKTRACE( FALSEVALUE ); L5170: POPSTACKTRACE( TRUEVALUE ); L5181: X4 = PAIR_CAR( X3 ); X3 = PAIR_CDR( X3 ); X2 = X4; GOBACK( L5169 ); L5167: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2__3e_3d_2dtwo_v ); DEFCSTRING( t5186, "SCRT2_>=-TWO" ); TSCP scrt2__3e_3d_2dtwo( x2828, y2829 ) TSCP x2828, y2829; { TSCP X1; PUSHSTACKTRACE( t5186 ); if ( NEQ( TSCPTAG( x2828 ), FIXNUMTAG ) ) goto L5188; if ( NEQ( TSCPTAG( y2829 ), FIXNUMTAG ) ) goto L5190; POPSTACKTRACE( BOOLEAN( GTE( _S2CINT( x2828 ), _S2CINT( y2829 ) ) ) ); L5190: if ( NOT( AND( EQ( TSCPTAG( y2829 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2829 ), DOUBLEFLOATTAG ) ) ) ) goto L5192; POPSTACKTRACE( BOOLEAN( GTE( FIX_FLTV( x2828 ), FLOAT_VALUE( y2829 ) ) ) ); L5192: POPSTACKTRACE( scdebug_error( c2842, c2582, CONS( y2829, EMPTYLIST ) ) ); L5188: if ( NEQ( TSCPTAG( y2829 ), FIXNUMTAG ) ) goto L5194; if ( NOT( AND( EQ( TSCPTAG( x2828 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2828 ), DOUBLEFLOATTAG ) ) ) ) goto L5196; POPSTACKTRACE( BOOLEAN( GTE( FLOAT_VALUE( x2828 ), FIX_FLTV( y2829 ) ) ) ); L5196: POPSTACKTRACE( scdebug_error( c2842, c2582, CONS( x2828, EMPTYLIST ) ) ); L5194: X1 = BOOLEAN( AND( EQ( TSCPTAG( x2828 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2828 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5204; if ( NOT( AND( EQ( TSCPTAG( y2829 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2829 ), DOUBLEFLOATTAG ) ) ) ) goto L5204; POPSTACKTRACE( BOOLEAN( GTE( FLOAT_VALUE( x2828 ), FLOAT_VALUE( y2829 ) ) ) ); L5204: X1 = CONS( y2829, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c2842, c2579, CONS( x2828, X1 ) ) ); } DEFTSCP( scrt2__3e_3d_v ); DEFCSTRING( t5205, ">=" ); TSCP scrt2__3e_3d( x2850, y2851, z2852 ) TSCP x2850, y2851, z2852; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5205 ); if ( BITAND( BITOR( _S2CINT( x2850 ), _S2CINT( y2851 ) ), 3 ) ) goto L5208; X1 = BOOLEAN( GTE( _S2CINT( x2850 ), _S2CINT( y2851 ) ) ); goto L5209; L5208: X1 = scrt2__3e_3d_2dtwo( x2850, y2851 ); L5209: if ( FALSE( X1 ) ) goto L5211; X2 = y2851; X3 = z2852; L5213: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L5214; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5217; scrt1__24__car_2derror( X3 ); L5217: X4 = PAIR_CAR( X3 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) goto L5221; if ( GTE( _S2CINT( X2 ), _S2CINT( X4 ) ) ) goto L5225; POPSTACKTRACE( FALSEVALUE ); L5221: if ( TRUE( scrt2__3e_3d_2dtwo( X2, X4 ) ) ) goto L5225; POPSTACKTRACE( FALSEVALUE ); L5214: POPSTACKTRACE( TRUEVALUE ); L5225: X4 = PAIR_CAR( X3 ); X3 = PAIR_CDR( X3 ); X2 = X4; GOBACK( L5213 ); L5211: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2_max_2dtwo_v ); DEFCSTRING( t5230, "SCRT2_MAX-TWO" ); TSCP scrt2_max_2dtwo( x2892, y2893 ) TSCP x2892, y2893; { PUSHSTACKTRACE( t5230 ); if ( BITAND( BITOR( _S2CINT( x2892 ), _S2CINT( y2893 ) ), 3 ) ) goto L5232; if ( GT( _S2CINT( x2892 ), _S2CINT( y2893 ) ) ) goto L5234; POPSTACKTRACE( y2893 ); L5234: POPSTACKTRACE( x2892 ); L5232: if ( TRUE( scrt2__3e_2dtwo( x2892, y2893 ) ) ) goto L5236; POPSTACKTRACE( y2893 ); L5236: POPSTACKTRACE( x2892 ); } DEFTSCP( scrt2_max_v ); DEFCSTRING( t5238, "MAX" ); TSCP scrt2_max( x2901, y2902 ) TSCP x2901, y2902; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5238 ); X1 = x2901; X2 = y2902; L5241: if ( FALSE( X2 ) ) goto L5242; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5245; scrt1__24__car_2derror( X2 ); L5245: X4 = PAIR_CAR( X2 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X4 ) ), 3 ) ) goto L5249; if ( LTE( _S2CINT( X1 ), _S2CINT( X4 ) ) ) goto L5253; X3 = X1; goto L5256; L5249: if ( FALSE( scrt2__3e_2dtwo( X1, X4 ) ) ) goto L5253; X3 = X1; goto L5256; L5253: X3 = PAIR_CAR( X2 ); L5256: X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L5241 ); L5242: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2_min_2dtwo_v ); DEFCSTRING( t5259, "SCRT2_MIN-TWO" ); TSCP scrt2_min_2dtwo( x2930, y2931 ) TSCP x2930, y2931; { PUSHSTACKTRACE( t5259 ); if ( BITAND( BITOR( _S2CINT( x2930 ), _S2CINT( y2931 ) ), 3 ) ) goto L5261; if ( LT( _S2CINT( x2930 ), _S2CINT( y2931 ) ) ) goto L5263; POPSTACKTRACE( y2931 ); L5263: POPSTACKTRACE( x2930 ); L5261: if ( TRUE( scrt2__3c_2dtwo( x2930, y2931 ) ) ) goto L5265; POPSTACKTRACE( y2931 ); L5265: POPSTACKTRACE( x2930 ); } DEFTSCP( scrt2_min_v ); DEFCSTRING( t5267, "MIN" ); TSCP scrt2_min( x2939, y2940 ) TSCP x2939, y2940; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5267 ); X1 = x2939; X2 = y2940; L5270: if ( FALSE( X2 ) ) goto L5271; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5274; scrt1__24__car_2derror( X2 ); L5274: X4 = PAIR_CAR( X2 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X4 ) ), 3 ) ) goto L5278; if ( GTE( _S2CINT( X1 ), _S2CINT( X4 ) ) ) goto L5282; X3 = X1; goto L5285; L5278: if ( FALSE( scrt2__3c_2dtwo( X1, X4 ) ) ) goto L5282; X3 = X1; goto L5285; L5282: X3 = PAIR_CAR( X2 ); L5285: X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L5270 ); L5271: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2__2b_2dtwo_v ); DEFCSTRING( t5288, "SCRT2_+-TWO" ); TSCP scrt2__2b_2dtwo( x2968, y2969 ) TSCP x2968, y2969; { TSCP X1; PUSHSTACKTRACE( t5288 ); if ( NEQ( TSCPTAG( x2968 ), FIXNUMTAG ) ) goto L5290; if ( NEQ( TSCPTAG( y2969 ), FIXNUMTAG ) ) goto L5292; POPSTACKTRACE( _TSCP( IPLUS( _S2CINT( x2968 ), _S2CINT( y2969 ) ) ) ); L5292: if ( NOT( AND( EQ( TSCPTAG( y2969 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2969 ), DOUBLEFLOATTAG ) ) ) ) goto L5294; POPSTACKTRACE( FLTV_FLT( PLUS( FIX_FLTV( x2968 ), FLOAT_VALUE( y2969 ) ) ) ); L5294: POPSTACKTRACE( scdebug_error( c2982, c2582, CONS( y2969, EMPTYLIST ) ) ); L5290: if ( NEQ( TSCPTAG( y2969 ), FIXNUMTAG ) ) goto L5296; if ( NOT( AND( EQ( TSCPTAG( x2968 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2968 ), DOUBLEFLOATTAG ) ) ) ) goto L5298; POPSTACKTRACE( FLTV_FLT( PLUS( FLOAT_VALUE( x2968 ), FIX_FLTV( y2969 ) ) ) ); L5298: POPSTACKTRACE( scdebug_error( c2982, c2582, CONS( x2968, EMPTYLIST ) ) ); L5296: X1 = BOOLEAN( AND( EQ( TSCPTAG( x2968 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2968 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5306; if ( NOT( AND( EQ( TSCPTAG( y2969 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2969 ), DOUBLEFLOATTAG ) ) ) ) goto L5306; POPSTACKTRACE( FLTV_FLT( PLUS( FLOAT_VALUE( x2968 ), FLOAT_VALUE( y2969 ) ) ) ); L5306: X1 = CONS( y2969, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c2982, c2579, CONS( x2968, X1 ) ) ); } DEFTSCP( scrt2__2b_v ); DEFCSTRING( t5307, "+" ); TSCP scrt2__2b( x2990 ) TSCP x2990; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5307 ); X1 = _TSCP( 0 ); X2 = x2990; L5310: if ( FALSE( X2 ) ) goto L5311; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5314; scrt1__24__car_2derror( X2 ); L5314: X4 = PAIR_CAR( X2 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X4 ) ), 3 ) ) goto L5317; X3 = _TSCP( IPLUS( _S2CINT( X1 ), _S2CINT( X4 ) ) ); goto L5318; L5317: X3 = scrt2__2b_2dtwo( X1, X4 ); L5318: X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L5310 ); L5311: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2__2a_2dtwo_v ); DEFCSTRING( t5320, "SCRT2_*-TWO" ); TSCP scrt2__2a_2dtwo( x3014, y3015 ) TSCP x3014, y3015; { TSCP X1; PUSHSTACKTRACE( t5320 ); if ( NEQ( TSCPTAG( x3014 ), FIXNUMTAG ) ) goto L5322; if ( NEQ( TSCPTAG( y3015 ), FIXNUMTAG ) ) goto L5324; POPSTACKTRACE( _TSCP( ITIMES( FIXED_C( x3014 ), _S2CINT( y3015 ) ) ) ); L5324: if ( NOT( AND( EQ( TSCPTAG( y3015 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y3015 ), DOUBLEFLOATTAG ) ) ) ) goto L5326; POPSTACKTRACE( FLTV_FLT( TIMES( FIX_FLTV( x3014 ), FLOAT_VALUE( y3015 ) ) ) ); L5326: POPSTACKTRACE( scdebug_error( c3028, c2582, CONS( y3015, EMPTYLIST ) ) ); L5322: if ( NEQ( TSCPTAG( y3015 ), FIXNUMTAG ) ) goto L5328; if ( NOT( AND( EQ( TSCPTAG( x3014 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3014 ), DOUBLEFLOATTAG ) ) ) ) goto L5330; POPSTACKTRACE( FLTV_FLT( TIMES( FLOAT_VALUE( x3014 ), FIX_FLTV( y3015 ) ) ) ); L5330: POPSTACKTRACE( scdebug_error( c3028, c2582, CONS( x3014, EMPTYLIST ) ) ); L5328: X1 = BOOLEAN( AND( EQ( TSCPTAG( x3014 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3014 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5338; if ( NOT( AND( EQ( TSCPTAG( y3015 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y3015 ), DOUBLEFLOATTAG ) ) ) ) goto L5338; POPSTACKTRACE( FLTV_FLT( TIMES( FLOAT_VALUE( x3014 ), FLOAT_VALUE( y3015 ) ) ) ); L5338: X1 = CONS( y3015, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c3028, c2579, CONS( x3014, X1 ) ) ); } DEFTSCP( scrt2__2a_v ); DEFCSTRING( t5339, "*" ); TSCP scrt2__2a( x3036 ) TSCP x3036; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5339 ); X1 = _TSCP( 4 ); X2 = x3036; L5342: if ( FALSE( X2 ) ) goto L5343; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5346; scrt1__24__car_2derror( X2 ); L5346: X4 = PAIR_CAR( X2 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X4 ) ), 3 ) ) goto L5349; X3 = _TSCP( ITIMES( FIXED_C( X1 ), _S2CINT( X4 ) ) ); goto L5350; L5349: X3 = scrt2__2a_2dtwo( X1, X4 ); L5350: X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L5342 ); L5343: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2__2d_2dtwo_v ); DEFCSTRING( t5352, "SCRT2_--TWO" ); TSCP scrt2__2d_2dtwo( x3061, y3062 ) TSCP x3061, y3062; { TSCP X1; PUSHSTACKTRACE( t5352 ); if ( NEQ( TSCPTAG( x3061 ), FIXNUMTAG ) ) goto L5354; if ( NEQ( TSCPTAG( y3062 ), FIXNUMTAG ) ) goto L5356; POPSTACKTRACE( _TSCP( IDIFFERENCE( _S2CINT( x3061 ), _S2CINT( y3062 ) ) ) ); L5356: if ( NOT( AND( EQ( TSCPTAG( y3062 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y3062 ), DOUBLEFLOATTAG ) ) ) ) goto L5358; POPSTACKTRACE( FLTV_FLT( DIFFERENCE( FIX_FLTV( x3061 ), FLOAT_VALUE( y3062 ) ) ) ); L5358: POPSTACKTRACE( scdebug_error( c3075, c2582, CONS( y3062, EMPTYLIST ) ) ); L5354: if ( NEQ( TSCPTAG( y3062 ), FIXNUMTAG ) ) goto L5360; if ( NOT( AND( EQ( TSCPTAG( x3061 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3061 ), DOUBLEFLOATTAG ) ) ) ) goto L5362; POPSTACKTRACE( FLTV_FLT( DIFFERENCE( FLOAT_VALUE( x3061 ), FIX_FLTV( y3062 ) ) ) ); L5362: POPSTACKTRACE( scdebug_error( c3075, c2582, CONS( x3061, EMPTYLIST ) ) ); L5360: X1 = BOOLEAN( AND( EQ( TSCPTAG( x3061 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3061 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5370; if ( NOT( AND( EQ( TSCPTAG( y3062 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y3062 ), DOUBLEFLOATTAG ) ) ) ) goto L5370; POPSTACKTRACE( FLTV_FLT( DIFFERENCE( FLOAT_VALUE( x3061 ), FLOAT_VALUE( y3062 ) ) ) ); L5370: X1 = CONS( y3062, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c3075, c2579, CONS( x3061, X1 ) ) ); } DEFTSCP( scrt2__2d_v ); DEFCSTRING( t5371, "-" ); TSCP scrt2__2d( x3083, y3084 ) TSCP x3083, y3084; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5371 ); if ( FALSE( y3084 ) ) goto L5373; if ( EQ( TSCPTAG( y3084 ), PAIRTAG ) ) goto L5376; scrt1__24__cdr_2derror( y3084 ); L5376: X1 = PAIR_CDR( y3084 ); X3 = PAIR_CAR( y3084 ); if ( BITAND( BITOR( _S2CINT( x3083 ), _S2CINT( X3 ) ), 3 ) ) goto L5380; X2 = _TSCP( IDIFFERENCE( _S2CINT( x3083 ), _S2CINT( X3 ) ) ); goto L5381; L5380: X2 = scrt2__2d_2dtwo( x3083, X3 ); L5381: X3 = X2; X4 = X1; L5384: if ( FALSE( X4 ) ) goto L5385; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5388; scrt1__24__car_2derror( X4 ); L5388: X6 = PAIR_CAR( X4 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X6 ) ), 3 ) ) goto L5391; X5 = _TSCP( IDIFFERENCE( _S2CINT( X3 ), _S2CINT( X6 ) ) ); goto L5392; L5391: X5 = scrt2__2d_2dtwo( X3, X6 ); L5392: X4 = PAIR_CDR( X4 ); X3 = X5; GOBACK( L5384 ); L5385: POPSTACKTRACE( X3 ); L5373: if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( x3083 ) ), 3 ) ) goto L5394; POPSTACKTRACE( _TSCP( IDIFFERENCE( _S2CINT( _TSCP( 0 ) ), _S2CINT( x3083 ) ) ) ); L5394: POPSTACKTRACE( scrt2__2d_2dtwo( _TSCP( 0 ), x3083 ) ); } DEFTSCP( scrt2__2f_2dtwo_v ); DEFCSTRING( t5396, "SCRT2_/-TWO" ); TSCP scrt2__2f_2dtwo( x3128, y3129 ) TSCP x3128, y3129; { TSCP X1; PUSHSTACKTRACE( t5396 ); if ( NEQ( _S2CUINT( y3129 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5398; POPSTACKTRACE( scdebug_error( c3145, c3155, CONS( y3129, EMPTYLIST ) ) ); L5398: if ( NEQ( TSCPTAG( x3128 ), FIXNUMTAG ) ) goto L5400; if ( NEQ( TSCPTAG( y3129 ), FIXNUMTAG ) ) goto L5402; X1 = _TSCP( REMAINDER( _S2CINT( x3128 ), _S2CINT( y3129 ) ) ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5404; POPSTACKTRACE( C_FIXED( QUOTIENT( _S2CINT( x3128 ), _S2CINT( y3129 ) ) ) ); L5404: POPSTACKTRACE( FLTV_FLT( QUOTIENT( FIX_FLTV( x3128 ), FIX_FLTV( y3129 ) ) ) ); L5402: if ( NOT( AND( EQ( TSCPTAG( y3129 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y3129 ), DOUBLEFLOATTAG ) ) ) ) goto L5406; POPSTACKTRACE( FLTV_FLT( QUOTIENT( FIX_FLTV( x3128 ), FLOAT_VALUE( y3129 ) ) ) ); L5406: POPSTACKTRACE( scdebug_error( c3145, c2582, CONS( y3129, EMPTYLIST ) ) ); L5400: if ( NEQ( TSCPTAG( y3129 ), FIXNUMTAG ) ) goto L5408; if ( NOT( AND( EQ( TSCPTAG( x3128 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3128 ), DOUBLEFLOATTAG ) ) ) ) goto L5410; POPSTACKTRACE( FLTV_FLT( QUOTIENT( FLOAT_VALUE( x3128 ), FIX_FLTV( y3129 ) ) ) ); L5410: POPSTACKTRACE( scdebug_error( c3145, c2582, CONS( x3128, EMPTYLIST ) ) ); L5408: X1 = BOOLEAN( AND( EQ( TSCPTAG( x3128 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3128 ), DOUBLEFLOATTAG ) ) ); if ( FALSE( X1 ) ) goto L5418; if ( NOT( AND( EQ( TSCPTAG( y3129 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y3129 ), DOUBLEFLOATTAG ) ) ) ) goto L5418; POPSTACKTRACE( FLTV_FLT( QUOTIENT( FLOAT_VALUE( x3128 ), FLOAT_VALUE( y3129 ) ) ) ); L5418: X1 = CONS( y3129, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c3145, c2579, CONS( x3128, X1 ) ) ); } DEFTSCP( scrt2__2f_v ); DEFCSTRING( t5419, "/" ); TSCP scrt2__2f( x3157, y3158 ) TSCP x3157, y3158; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5419 ); if ( FALSE( y3158 ) ) goto L5421; if ( EQ( TSCPTAG( y3158 ), PAIRTAG ) ) goto L5424; scrt1__24__cdr_2derror( y3158 ); L5424: X1 = PAIR_CDR( y3158 ); X3 = PAIR_CAR( y3158 ); X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( x3157 ), _S2CINT( X3 ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L5438; if ( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5438; X5 = _TSCP( REMAINDER( _S2CINT( x3157 ), _S2CINT( X3 ) ) ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5438; X2 = C_FIXED( QUOTIENT( _S2CINT( x3157 ), _S2CINT( X3 ) ) ); goto L5439; L5438: X2 = scrt2__2f_2dtwo( x3157, X3 ); L5439: X3 = X2; X4 = X1; L5442: if ( FALSE( X4 ) ) goto L5443; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5446; scrt1__24__car_2derror( X4 ); L5446: X6 = PAIR_CAR( X4 ); X7 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X6 ) ), 3 ) ) ); if ( FALSE( X7 ) ) goto L5459; if ( EQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5459; X8 = _TSCP( REMAINDER( _S2CINT( X3 ), _S2CINT( X6 ) ) ); if ( NEQ( _S2CUINT( X8 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5459; X5 = C_FIXED( QUOTIENT( _S2CINT( X3 ), _S2CINT( X6 ) ) ); goto L5460; L5459: X5 = scrt2__2f_2dtwo( X3, X6 ); L5460: X4 = PAIR_CDR( X4 ); X3 = X5; GOBACK( L5442 ); L5443: POPSTACKTRACE( X3 ); L5421: X1 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( x3157 ) ), 3 ) ) ); if ( FALSE( X1 ) ) goto L5472; if ( EQ( _S2CUINT( x3157 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5472; X2 = _TSCP( REMAINDER( _S2CINT( _TSCP( 4 ) ), _S2CINT( x3157 ) ) ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5472; POPSTACKTRACE( C_FIXED( QUOTIENT( _S2CINT( _TSCP( 4 ) ), _S2CINT( x3157 ) ) ) ); L5472: POPSTACKTRACE( scrt2__2f_2dtwo( _TSCP( 4 ), x3157 ) ); } DEFTSCP( scrt2_abs_v ); DEFCSTRING( t5473, "ABS" ); TSCP scrt2_abs( x3244 ) TSCP x3244; { PUSHSTACKTRACE( t5473 ); if ( NEQ( TSCPTAG( x3244 ), FIXNUMTAG ) ) goto L5476; if ( LT( _S2CINT( x3244 ), 0 ) ) goto L5480; POPSTACKTRACE( x3244 ); L5476: if ( TRUE( scrt2_negative_3f( x3244 ) ) ) goto L5480; POPSTACKTRACE( x3244 ); L5480: if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( x3244 ) ), 3 ) ) goto L5483; POPSTACKTRACE( _TSCP( IDIFFERENCE( _S2CINT( _TSCP( 0 ) ), _S2CINT( x3244 ) ) ) ); L5483: POPSTACKTRACE( scrt2__2d_2dtwo( _TSCP( 0 ), x3244 ) ); } DEFTSCP( scrt2_quotient_v ); DEFCSTRING( t5485, "QUOTIENT" ); EXTERNTSCPP( scrt2_truncate, XAL1( TSCP ) ); EXTERNTSCP( scrt2_truncate_v ); TSCP scrt2_quotient( x3258, y3259 ) TSCP x3258, y3259; { TSCP X3, X2, X1; PUSHSTACKTRACE( t5485 ); X1 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( x3258 ), _S2CINT( y3259 ) ), 3 ) ) ); if ( FALSE( X1 ) ) goto L5493; if ( EQ( _S2CUINT( y3259 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5493; POPSTACKTRACE( C_FIXED( QUOTIENT( _S2CINT( x3258 ), _S2CINT( y3259 ) ) ) ); L5493: X2 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( x3258 ), _S2CINT( y3259 ) ), 3 ) ) ); if ( FALSE( X2 ) ) goto L5504; if ( EQ( _S2CUINT( y3259 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5504; X3 = _TSCP( REMAINDER( _S2CINT( x3258 ), _S2CINT( y3259 ) ) ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5504; X1 = C_FIXED( QUOTIENT( _S2CINT( x3258 ), _S2CINT( y3259 ) ) ); goto L5505; L5504: X1 = scrt2__2f_2dtwo( x3258, y3259 ); L5505: POPSTACKTRACE( scrt2_truncate( X1 ) ); } DEFTSCP( scrt2_remainder_v ); DEFCSTRING( t5506, "REMAINDER" ); TSCP scrt2_remainder( x3291, y3292 ) TSCP x3291, y3292; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5506 ); X1 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( x3291 ), _S2CINT( y3292 ) ), 3 ) ) ); if ( FALSE( X1 ) ) goto L5514; if ( EQ( _S2CUINT( y3292 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5514; POPSTACKTRACE( _TSCP( REMAINDER( _S2CINT( x3291 ), _S2CINT( y3292 ) ) ) ); L5514: X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( x3291 ), _S2CINT( y3292 ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L5521; if ( EQ( _S2CUINT( y3292 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5521; X3 = C_FIXED( QUOTIENT( _S2CINT( x3291 ), _S2CINT( y3292 ) ) ); goto L5522; L5521: X3 = scrt2_quotient( x3291, y3292 ); L5522: if ( BITAND( BITOR( _S2CINT( y3292 ), _S2CINT( X3 ) ), 3 ) ) goto L5524; X2 = _TSCP( ITIMES( FIXED_C( y3292 ), _S2CINT( X3 ) ) ); goto L5525; L5524: X2 = scrt2__2a_2dtwo( y3292, X3 ); L5525: if ( BITAND( BITOR( _S2CINT( x3291 ), _S2CINT( X2 ) ), 3 ) ) goto L5527; X1 = _TSCP( IDIFFERENCE( _S2CINT( x3291 ), _S2CINT( X2 ) ) ); goto L5528; L5527: X1 = scrt2__2d_2dtwo( x3291, X2 ); L5528: POPSTACKTRACE( scrt2_round( X1 ) ); } DEFTSCP( scrt2_modulo_v ); DEFCSTRING( t5529, "MODULO" ); TSCP scrt2_modulo( x3329, y3330 ) TSCP x3329, y3330; { TSCP X2, X1; PUSHSTACKTRACE( t5529 ); X2 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( x3329 ), _S2CINT( y3330 ) ), 3 ) ) ); if ( FALSE( X2 ) ) goto L5537; if ( EQ( _S2CUINT( y3330 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5537; X1 = _TSCP( REMAINDER( _S2CINT( x3329 ), _S2CINT( y3330 ) ) ); goto L5538; L5537: X1 = scrt2_remainder( x3329, y3330 ); L5538: if ( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L5541; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5545; POPSTACKTRACE( X1 ); L5541: if ( FALSE( scrt2_zero_3f( X1 ) ) ) goto L5545; POPSTACKTRACE( X1 ); L5545: if ( NEQ( TSCPTAG( y3330 ), FIXNUMTAG ) ) goto L5549; if ( GT( _S2CINT( y3330 ), 0 ) ) goto L5553; goto L5554; L5549: if ( FALSE( scrt2_positive_3f( y3330 ) ) ) goto L5554; L5553: if ( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L5558; if ( LTE( _S2CINT( X1 ), 0 ) ) goto L5562; POPSTACKTRACE( X1 ); L5558: if ( FALSE( scrt2_positive_3f( X1 ) ) ) goto L5562; POPSTACKTRACE( X1 ); L5562: if ( BITAND( BITOR( _S2CINT( y3330 ), _S2CINT( X1 ) ), 3 ) ) goto L5565; POPSTACKTRACE( _TSCP( IPLUS( _S2CINT( y3330 ), _S2CINT( X1 ) ) ) ); L5565: POPSTACKTRACE( scrt2__2b_2dtwo( y3330, X1 ) ); L5554: if ( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L5568; if ( GTE( _S2CINT( X1 ), 0 ) ) goto L5572; POPSTACKTRACE( X1 ); L5568: if ( FALSE( scrt2_negative_3f( X1 ) ) ) goto L5572; POPSTACKTRACE( X1 ); L5572: if ( BITAND( BITOR( _S2CINT( y3330 ), _S2CINT( X1 ) ), 3 ) ) goto L5575; POPSTACKTRACE( _TSCP( IPLUS( _S2CINT( y3330 ), _S2CINT( X1 ) ) ) ); L5575: POPSTACKTRACE( scrt2__2b_2dtwo( y3330, X1 ) ); } DEFTSCP( scrt2_gcd_v ); DEFCSTRING( t5577, "GCD" ); TSCP scrt2_g3389( m3391, n3392 ) TSCP m3391, n3392; { TSCP X2, X1; PUSHSTACKTRACE( "GCD2 [inside GCD]" ); L5580: if ( NEQ( TSCPTAG( n3392 ), FIXNUMTAG ) ) goto L5582; if ( NEQ( _S2CUINT( n3392 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5586; POPSTACKTRACE( m3391 ); L5582: if ( FALSE( scrt2_zero_3f( n3392 ) ) ) goto L5586; POPSTACKTRACE( m3391 ); L5586: X2 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( m3391 ), _S2CINT( n3392 ) ), 3 ) ) ); if ( FALSE( X2 ) ) goto L5595; if ( EQ( _S2CUINT( n3392 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5595; X1 = _TSCP( REMAINDER( _S2CINT( m3391 ), _S2CINT( n3392 ) ) ); goto L5596; L5595: X1 = scrt2_remainder( m3391, n3392 ); L5596: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5599; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5603; POPSTACKTRACE( n3392 ); L5599: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( 0 ) ) ) ) goto L5603; POPSTACKTRACE( n3392 ); L5603: X2 = n3392; n3392 = X1; m3391 = X2; GOBACK( L5580 ); } EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); TSCP scrt2_gcd( x3387 ) TSCP x3387; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5577 ); X2 = scrt1_length( x3387 ); if ( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5607; if ( NEQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L5609; if ( EQ( TSCPTAG( x3387 ), PAIRTAG ) ) goto L5612; scrt1__24__car_2derror( x3387 ); L5612: X1 = PAIR_CAR( x3387 ); if ( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L5615; if ( LT( _S2CINT( X1 ), 0 ) ) goto L5620; POPSTACKTRACE( X1 ); L5615: POPSTACKTRACE( scrt2_abs( X1 ) ); L5609: if ( EQ( TSCPTAG( x3387 ), PAIRTAG ) ) goto L5622; scrt1__24__cdr_2derror( x3387 ); L5622: X4 = PAIR_CDR( x3387 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5625; scrt1__24__cdr_2derror( X4 ); L5625: X3 = PAIR_CDR( X4 ); X6 = PAIR_CAR( x3387 ); if ( NEQ( TSCPTAG( X6 ), FIXNUMTAG ) ) goto L5629; if ( LT( _S2CINT( X6 ), 0 ) ) goto L5634; X5 = X6; goto L5635; L5629: X5 = scrt2_abs( X6 ); goto L5635; L5634: X5 = _TSCP( INEGATE( _S2CINT( X6 ) ) ); L5635: X8 = PAIR_CDR( x3387 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L5638; scrt1__24__car_2derror( X8 ); L5638: X7 = PAIR_CAR( X8 ); if ( NEQ( TSCPTAG( X7 ), FIXNUMTAG ) ) goto L5641; if ( LT( _S2CINT( X7 ), 0 ) ) goto L5646; X6 = X7; goto L5647; L5641: X6 = scrt2_abs( X7 ); goto L5647; L5646: X6 = _TSCP( INEGATE( _S2CINT( X7 ) ) ); L5647: X4 = scrt2_g3389( X5, X6 ); X5 = X4; X6 = X3; L5650: if ( FALSE( X6 ) ) goto L5651; if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L5654; scrt1__24__car_2derror( X6 ); L5654: X9 = PAIR_CAR( X6 ); if ( NEQ( TSCPTAG( X9 ), FIXNUMTAG ) ) goto L5657; if ( LT( _S2CINT( X9 ), 0 ) ) goto L5662; X8 = X9; goto L5663; L5657: X8 = scrt2_abs( X9 ); goto L5663; L5662: X8 = _TSCP( INEGATE( _S2CINT( X9 ) ) ); L5663: X7 = scrt2_g3389( X5, X8 ); X6 = PAIR_CDR( X6 ); X5 = X7; GOBACK( L5650 ); L5651: POPSTACKTRACE( X5 ); L5607: POPSTACKTRACE( _TSCP( 0 ) ); L5620: POPSTACKTRACE( _TSCP( INEGATE( _S2CINT( X1 ) ) ) ); } DEFTSCP( scrt2_lcm_v ); DEFCSTRING( t5665, "LCM" ); TSCP scrt2_l3530( m3532, n3533 ) TSCP m3532, n3533; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "LCM2 [inside LCM]" ); if ( NEQ( TSCPTAG( n3533 ), FIXNUMTAG ) ) goto L5669; if ( LT( _S2CINT( n3533 ), 0 ) ) goto L5674; X1 = n3533; goto L5670; L5674: X1 = _TSCP( INEGATE( _S2CINT( n3533 ) ) ); goto L5670; L5669: X1 = scrt2_abs( n3533 ); L5670: if ( NEQ( TSCPTAG( m3532 ), FIXNUMTAG ) ) goto L5676; if ( LT( _S2CINT( m3532 ), 0 ) ) goto L5681; X2 = m3532; goto L5677; L5681: X2 = _TSCP( INEGATE( _S2CINT( m3532 ) ) ); goto L5677; L5676: X2 = scrt2_abs( m3532 ); L5677: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X1 ) ), 3 ) ) goto L5685; if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X1 ) ) ) goto L5689; POPSTACKTRACE( X2 ); L5685: if ( FALSE( scrt2__3d_2dtwo( X2, X1 ) ) ) goto L5689; POPSTACKTRACE( X2 ); L5689: X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X1 ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L5698; if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5698; X3 = _TSCP( REMAINDER( _S2CINT( X2 ), _S2CINT( X1 ) ) ); goto L5699; L5698: X3 = scrt2_remainder( X2, X1 ); L5699: if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5702; if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5706; POPSTACKTRACE( X2 ); L5702: if ( FALSE( scrt2__3d_2dtwo( X3, _TSCP( 0 ) ) ) ) goto L5706; POPSTACKTRACE( X2 ); L5706: X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X2 ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L5715; if ( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5715; X3 = _TSCP( REMAINDER( _S2CINT( X1 ), _S2CINT( X2 ) ) ); goto L5716; L5715: X3 = scrt2_remainder( X1, X2 ); L5716: if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5719; if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5723; POPSTACKTRACE( X1 ); L5719: if ( FALSE( scrt2__3d_2dtwo( X3, _TSCP( 0 ) ) ) ) goto L5723; POPSTACKTRACE( X1 ); L5723: X5 = CONS( X1, EMPTYLIST ); X4 = scrt2_gcd( CONS( X2, X5 ) ); X5 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) ); if ( FALSE( X5 ) ) goto L5737; if ( EQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5737; X6 = _TSCP( REMAINDER( _S2CINT( X2 ), _S2CINT( X4 ) ) ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5737; X3 = C_FIXED( QUOTIENT( _S2CINT( X2 ), _S2CINT( X4 ) ) ); goto L5738; L5737: X3 = scrt2__2f_2dtwo( X2, X4 ); L5738: if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X1 ) ), 3 ) ) goto L5740; POPSTACKTRACE( _TSCP( ITIMES( FIXED_C( X3 ), _S2CINT( X1 ) ) ) ); L5740: POPSTACKTRACE( scrt2__2a_2dtwo( X3, X1 ) ); } TSCP scrt2_lcm( x3528 ) TSCP x3528; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5665 ); X2 = scrt1_length( x3528 ); if ( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5743; if ( NEQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L5745; if ( EQ( TSCPTAG( x3528 ), PAIRTAG ) ) goto L5748; scrt1__24__car_2derror( x3528 ); L5748: X1 = PAIR_CAR( x3528 ); if ( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L5751; if ( LT( _S2CINT( X1 ), 0 ) ) goto L5756; POPSTACKTRACE( X1 ); L5751: POPSTACKTRACE( scrt2_abs( X1 ) ); L5745: if ( EQ( TSCPTAG( x3528 ), PAIRTAG ) ) goto L5758; scrt1__24__cdr_2derror( x3528 ); L5758: X4 = PAIR_CDR( x3528 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5761; scrt1__24__cdr_2derror( X4 ); L5761: X3 = PAIR_CDR( X4 ); X5 = PAIR_CAR( x3528 ); X7 = PAIR_CDR( x3528 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L5766; scrt1__24__car_2derror( X7 ); L5766: X6 = PAIR_CAR( X7 ); X4 = scrt2_l3530( X5, X6 ); X5 = X4; X6 = X3; L5770: if ( FALSE( X6 ) ) goto L5771; if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L5774; scrt1__24__car_2derror( X6 ); L5774: X8 = PAIR_CAR( X6 ); X7 = scrt2_l3530( X5, X8 ); X6 = PAIR_CDR( X6 ); X5 = X7; GOBACK( L5770 ); L5771: POPSTACKTRACE( X5 ); L5743: POPSTACKTRACE( _TSCP( 4 ) ); L5756: POPSTACKTRACE( _TSCP( INEGATE( _S2CINT( X1 ) ) ) ); } DEFTSCP( scrt2_floor_v ); DEFCSTRING( t5777, "FLOOR" ); TSCP scrt2_floor( x3705 ) TSCP x3705; { PUSHSTACKTRACE( t5777 ); if ( EQ( TSCPTAG( x3705 ), FIXNUMTAG ) ) goto L5779; POPSTACKTRACE( C_FLOOR( x3705 ) ); L5779: POPSTACKTRACE( x3705 ); } DEFTSCP( scrt2_ceiling_v ); DEFCSTRING( t5781, "CEILING" ); TSCP scrt2_ceiling( x3709 ) TSCP x3709; { PUSHSTACKTRACE( t5781 ); if ( EQ( TSCPTAG( x3709 ), FIXNUMTAG ) ) goto L5783; POPSTACKTRACE( C_CEILING( x3709 ) ); L5783: POPSTACKTRACE( x3709 ); } DEFTSCP( scrt2_truncate_v ); DEFCSTRING( t5785, "TRUNCATE" ); TSCP scrt2_truncate( x3713 ) TSCP x3713; { PUSHSTACKTRACE( t5785 ); if ( BITAND( BITOR( _S2CINT( x3713 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5788; if ( LT( _S2CINT( x3713 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L5792; goto L5793; L5788: if ( FALSE( scrt2__3c_2dtwo( x3713, _TSCP( 0 ) ) ) ) goto L5793; L5792: POPSTACKTRACE( scrt2_ceiling( x3713 ) ); L5793: POPSTACKTRACE( scrt2_floor( x3713 ) ); } DEFTSCP( scrt2_round_v ); DEFCSTRING( t5796, "ROUND" ); TSCP scrt2_round( x3721 ) TSCP x3721; { TSCP X1; PUSHSTACKTRACE( t5796 ); if ( EQ( TSCPTAG( x3721 ), FIXNUMTAG ) ) goto L5798; if ( BITAND( BITOR( _S2CINT( x3721 ), _S2CINT( c3730 ) ), 3 ) ) goto L5800; X1 = _TSCP( IPLUS( _S2CINT( x3721 ), _S2CINT( c3730 ) ) ); goto L5801; L5800: X1 = scrt2__2b_2dtwo( x3721, c3730 ); L5801: POPSTACKTRACE( scrt2_floor( X1 ) ); L5798: POPSTACKTRACE( x3721 ); } DEFTSCP( scrt2_exp_v ); DEFCSTRING( t5802, "EXP" ); TSCP scrt2_exp( x3732 ) TSCP x3732; { PUSHSTACKTRACE( t5802 ); POPSTACKTRACE( C_EXP( x3732 ) ); } DEFTSCP( scrt2_log_v ); DEFCSTRING( t5804, "LOG" ); TSCP scrt2_log( x3734 ) TSCP x3734; { PUSHSTACKTRACE( t5804 ); POPSTACKTRACE( C_LOG( x3734 ) ); } DEFTSCP( scrt2_sin_v ); DEFCSTRING( t5806, "SIN" ); TSCP scrt2_sin( x3736 ) TSCP x3736; { PUSHSTACKTRACE( t5806 ); POPSTACKTRACE( C_SIN( x3736 ) ); } DEFTSCP( scrt2_cos_v ); DEFCSTRING( t5808, "COS" ); TSCP scrt2_cos( x3738 ) TSCP x3738; { PUSHSTACKTRACE( t5808 ); POPSTACKTRACE( C_COS( x3738 ) ); } DEFTSCP( scrt2_tan_v ); DEFCSTRING( t5810, "TAN" ); TSCP scrt2_tan( x3740 ) TSCP x3740; { PUSHSTACKTRACE( t5810 ); POPSTACKTRACE( C_TAN( x3740 ) ); } DEFTSCP( scrt2_asin_v ); DEFCSTRING( t5812, "ASIN" ); TSCP scrt2_asin( x3742 ) TSCP x3742; { PUSHSTACKTRACE( t5812 ); POPSTACKTRACE( C_ASIN( x3742 ) ); } DEFTSCP( scrt2_acos_v ); DEFCSTRING( t5814, "ACOS" ); TSCP scrt2_acos( x3744 ) TSCP x3744; { PUSHSTACKTRACE( t5814 ); POPSTACKTRACE( C_ACOS( x3744 ) ); } DEFTSCP( scrt2_atan_v ); DEFCSTRING( t5816, "ATAN" ); TSCP scrt2_atan( x3746, y3747 ) TSCP x3746, y3747; { TSCP X1; PUSHSTACKTRACE( t5816 ); if ( FALSE( y3747 ) ) goto L5818; if ( EQ( TSCPTAG( y3747 ), PAIRTAG ) ) goto L5821; scrt1__24__car_2derror( y3747 ); L5821: X1 = PAIR_CAR( y3747 ); POPSTACKTRACE( C_ATAN2( x3746, X1 ) ); L5818: POPSTACKTRACE( C_ATAN( x3746 ) ); } DEFTSCP( scrt2_sqrt_v ); DEFCSTRING( t5823, "SQRT" ); TSCP scrt2_sqrt( x3753 ) TSCP x3753; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5823 ); if ( NEQ( TSCPTAG( x3753 ), FIXNUMTAG ) ) goto L5826; if ( LT( _S2CINT( x3753 ), 0 ) ) goto L5830; goto L5833; L5826: if ( FALSE( scrt2_negative_3f( x3753 ) ) ) goto L5833; L5830: scdebug_error( c3760, c3761, CONS( x3753, EMPTYLIST ) ); L5833: X1 = C_SQRT( x3753 ); if ( NEQ( TSCPTAG( x3753 ), FIXNUMTAG ) ) goto L5835; X3 = scrt2_round( X1 ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), DOUBLEFLOATTAG ) ) ) goto L5838; scdebug_error( c2310, c2311, CONS( X3, EMPTYLIST ) ); L5838: X4 = BOOLEAN( LT( FLOAT_VALUE( X3 ), MINTSCPINTF ) ); if ( TRUE( X4 ) ) goto L5844; if ( LTE( FLOAT_VALUE( X3 ), MAXTSCPINTF ) ) goto L5847; L5844: scdebug_error( c2310, c2316, CONS( X3, EMPTYLIST ) ); L5847: X2 = FLT_FIX( X3 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X2 ) ), 3 ) ) goto L5851; X3 = _TSCP( ITIMES( FIXED_C( X2 ), _S2CINT( X2 ) ) ); goto L5852; L5851: X3 = scrt2__2a_2dtwo( X2, X2 ); L5852: if ( EQ( _S2CUINT( X3 ), _S2CUINT( x3753 ) ) ) goto L5849; POPSTACKTRACE( X1 ); L5849: POPSTACKTRACE( X2 ); L5835: POPSTACKTRACE( X1 ); } DEFTSCP( scrt2_expt_v ); DEFCSTRING( t5853, "EXPT" ); TSCP scrt2_expt( x3786, y3787 ) TSCP x3786, y3787; { TSCP X3, X2, X1; PUSHSTACKTRACE( t5853 ); if ( BITAND( BITOR( _S2CINT( x3786 ), _S2CINT( c3800 ) ), 3 ) ) goto L5855; X2 = BOOLEAN( EQ( _S2CUINT( x3786 ), _S2CUINT( c3800 ) ) ); goto L5856; L5855: X2 = scrt2__3d_2dtwo( x3786, c3800 ); L5856: if ( FALSE( X2 ) ) goto L5869; if ( BITAND( BITOR( _S2CINT( y3787 ), _S2CINT( c3800 ) ), 3 ) ) goto L5862; if ( NEQ( _S2CUINT( y3787 ), _S2CUINT( c3800 ) ) ) goto L5869; POPSTACKTRACE( c3851 ); L5862: if ( FALSE( scrt2__3d_2dtwo( y3787, c3800 ) ) ) goto L5869; POPSTACKTRACE( c3851 ); L5869: X1 = C_POW( x3786, y3787 ); if ( NEQ( TSCPTAG( x3786 ), FIXNUMTAG ) ) goto L5871; if ( NEQ( TSCPTAG( y3787 ), FIXNUMTAG ) ) goto L5873; X2 = C_FIXED( MAXS2CINT >> 2 ); if ( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L5875; if ( LT( _S2CINT( X1 ), 0 ) ) goto L5880; X3 = X1; goto L5876; L5880: X3 = _TSCP( INEGATE( _S2CINT( X1 ) ) ); goto L5876; L5875: X3 = scrt2_abs( X1 ); L5876: if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X2 ) ), 3 ) ) goto L5884; if ( LTE( _S2CINT( X3 ), _S2CINT( X2 ) ) ) goto L5888; POPSTACKTRACE( X1 ); L5884: if ( TRUE( scrt2__3c_3d_2dtwo( X3, X2 ) ) ) goto L5888; POPSTACKTRACE( X1 ); L5873: POPSTACKTRACE( X1 ); L5871: POPSTACKTRACE( X1 ); L5888: X2 = scrt2_round( X1 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), DOUBLEFLOATTAG ) ) ) goto L5892; scdebug_error( c2310, c2311, CONS( X2, EMPTYLIST ) ); L5892: X3 = BOOLEAN( LT( FLOAT_VALUE( X2 ), MINTSCPINTF ) ); if ( TRUE( X3 ) ) goto L5898; if ( LTE( FLOAT_VALUE( X2 ), MAXTSCPINTF ) ) goto L5901; L5898: scdebug_error( c2310, c2316, CONS( X2, EMPTYLIST ) ); L5901: POPSTACKTRACE( FLT_FIX( X2 ) ); } DEFTSCP( scrt2_exact_2d_3einexact_v ); DEFCSTRING( t5902, "EXACT->INEXACT" ); TSCP scrt2_exact_2d_3einexact( x3853 ) TSCP x3853; { PUSHSTACKTRACE( t5902 ); if ( NEQ( TSCPTAG( x3853 ), FIXNUMTAG ) ) goto L5904; POPSTACKTRACE( FIX_FLT( x3853 ) ); L5904: if ( AND( EQ( TSCPTAG( x3853 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3853 ), DOUBLEFLOATTAG ) ) ) goto L5907; POPSTACKTRACE( scdebug_error( c3858, c2543, CONS( x3853, EMPTYLIST ) ) ); L5907: POPSTACKTRACE( x3853 ); } DEFTSCP( scrt2_inexact_2d_3eexact_v ); DEFCSTRING( t5909, "INEXACT->EXACT" ); TSCP scrt2_inexact_2d_3eexact( x3864 ) TSCP x3864; { TSCP X1; PUSHSTACKTRACE( t5909 ); if ( EQ( TSCPTAG( x3864 ), FIXNUMTAG ) ) goto L5911; if ( NOT( AND( EQ( TSCPTAG( x3864 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3864 ), DOUBLEFLOATTAG ) ) ) ) goto L5913; X1 = BOOLEAN( LT( FLOAT_VALUE( x3864 ), MINTSCPINTF ) ); if ( TRUE( X1 ) ) goto L5920; if ( LTE( FLOAT_VALUE( x3864 ), MAXTSCPINTF ) ) goto L5923; L5920: scdebug_error( c2310, c2316, CONS( x3864, EMPTYLIST ) ); L5923: POPSTACKTRACE( FLT_FIX( x3864 ) ); L5913: POPSTACKTRACE( scdebug_error( c3869, c2543, CONS( x3864, EMPTYLIST ) ) ); L5911: POPSTACKTRACE( x3864 ); } DEFTSCP( scrt2_number_2d_3estring_v ); DEFCSTRING( t5924, "NUMBER->STRING" ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( sc_formatnumber, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( sc_formatnumber_v ); EXTERNTSCPP( scrt2_integer_2d_3estring, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_integer_2d_3estring_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); TSCP scrt2_number_2d_3estring( n3879, f3880 ) TSCP n3879, f3880; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5924 ); f3880 = CONS( f3880, EMPTYLIST ); if ( EQ( TSCPTAG( n3879 ), FIXNUMTAG ) ) goto L5928; if ( AND( EQ( TSCPTAG( n3879 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( n3879 ), DOUBLEFLOATTAG ) ) ) goto L5928; scdebug_error( c3891, c2543, CONS( n3879, EMPTYLIST ) ); L5928: if ( FALSE( PAIR_CAR( f3880 ) ) ) goto L5930; X2 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5933; scrt1__24__car_2derror( X2 ); L5933: X1 = PAIR_CAR( X2 ); goto L5931; L5930: X1 = _TSCP( 40 ); L5931: SETGEN( PAIR_CAR( f3880 ), X1 ); if ( FALSE( scrt1_equal_3f( PAIR_CAR( f3880 ), c3897 ) ) ) goto L5935; POPSTACKTRACE( sc_formatnumber( n3879, _TSCP( 0 ), _TSCP( 0 ) ) ); L5935: X1 = BOOLEAN( EQ( TSCPTAG( PAIR_CAR( f3880 ) ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5984; X3 = scrt1_length( PAIR_CAR( f3880 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L5942; X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 8 ) ) ) ); goto L5943; L5942: X2 = scrt2__3d_2dtwo( X3, _TSCP( 8 ) ); L5943: if ( FALSE( X2 ) ) goto L5984; X4 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5952; scrt1__24__car_2derror( X4 ); L5952: X3 = PAIR_CAR( X4 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c3927 ) ) ) goto L5984; X4 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5959; scrt1__24__cdr_2derror( X4 ); L5959: X5 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5962; scrt1__24__car_2derror( X5 ); L5962: X3 = PAIR_CAR( X5 ); if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L5984; X4 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5966; scrt1__24__cdr_2derror( X4 ); L5966: X5 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5969; scrt1__24__car_2derror( X5 ); L5969: X3 = PAIR_CAR( X5 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5973; if ( GTE( _S2CINT( X3 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L5977; goto L5984; L5973: if ( FALSE( scrt2__3e_3d_2dtwo( X3, _TSCP( 0 ) ) ) ) goto L5984; L5977: X2 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5987; scrt1__24__cdr_2derror( X2 ); L5987: X3 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5990; scrt1__24__car_2derror( X3 ); L5990: X1 = PAIR_CAR( X3 ); POPSTACKTRACE( sc_formatnumber( n3879, _TSCP( 4 ), X1 ) ); L5984: X1 = BOOLEAN( EQ( TSCPTAG( PAIR_CAR( f3880 ) ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L6039; X3 = scrt1_length( PAIR_CAR( f3880 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L5997; X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 8 ) ) ) ); goto L5998; L5997: X2 = scrt2__3d_2dtwo( X3, _TSCP( 8 ) ); L5998: if ( FALSE( X2 ) ) goto L6039; X4 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6007; scrt1__24__car_2derror( X4 ); L6007: X3 = PAIR_CAR( X4 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c3990 ) ) ) goto L6039; X4 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6014; scrt1__24__cdr_2derror( X4 ); L6014: X5 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6017; scrt1__24__car_2derror( X5 ); L6017: X3 = PAIR_CAR( X5 ); if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L6039; X4 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6021; scrt1__24__cdr_2derror( X4 ); L6021: X5 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6024; scrt1__24__car_2derror( X5 ); L6024: X3 = PAIR_CAR( X5 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L6028; if ( GTE( _S2CINT( X3 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L6032; goto L6039; L6028: if ( FALSE( scrt2__3e_3d_2dtwo( X3, _TSCP( 0 ) ) ) ) goto L6039; L6032: X2 = PAIR_CAR( f3880 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6042; scrt1__24__cdr_2derror( X2 ); L6042: X3 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6045; scrt1__24__car_2derror( X3 ); L6045: X1 = PAIR_CAR( X3 ); POPSTACKTRACE( sc_formatnumber( n3879, _TSCP( 8 ), X1 ) ); L6039: X1 = PAIR_CAR( f3880 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L6049; if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 8 ) ) ) ) goto L6053; goto L6054; L6049: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( 8 ) ) ) ) goto L6054; L6053: POPSTACKTRACE( scrt2_integer_2d_3estring( n3879, _TSCP( 8 ) ) ); L6054: X1 = PAIR_CAR( f3880 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 32 ) ) ), 3 ) ) goto L6059; if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 32 ) ) ) ) goto L6063; goto L6064; L6059: if ( TRUE( scrt2__3d_2dtwo( X1, _TSCP( 32 ) ) ) ) goto L6063; L6064: X1 = PAIR_CAR( f3880 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) goto L6069; if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 40 ) ) ) ) goto L6073; goto L6074; L6069: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( 40 ) ) ) ) goto L6074; L6073: POPSTACKTRACE( scrt6_format( c4064, CONS( n3879, EMPTYLIST ) ) ); L6074: X1 = PAIR_CAR( f3880 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 64 ) ) ), 3 ) ) goto L6079; if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 64 ) ) ) ) goto L6083; goto L6084; L6079: if ( TRUE( scrt2__3d_2dtwo( X1, _TSCP( 64 ) ) ) ) goto L6083; L6084: POPSTACKTRACE( scdebug_error( c3891, c4062, CONS( PAIR_CAR( f3880 ), EMPTYLIST ) ) ); L6083: POPSTACKTRACE( scrt2_integer_2d_3estring( n3879, _TSCP( 64 ) ) ); L6063: POPSTACKTRACE( scrt2_integer_2d_3estring( n3879, _TSCP( 32 ) ) ); } DEFTSCP( scrt2_integer_2d_3estring_v ); DEFCSTRING( t6087, "SCRT2_INTEGER->STRING" ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( scrt3_list_2d_3estring, XAL1( TSCP ) ); EXTERNTSCP( scrt3_list_2d_3estring_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); EXTERNTSCPP( scrt2_l4098, XAL2( TSCP, TSCP ) ); TSCP scrt2_l4098( q4100, r4101 ) TSCP q4100, r4101; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside INTEGER->STRING]" ); X2 = scrt2_inexact_2d_3eexact( r4101 ); if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L6125; scdebug_error( c4146, c4147, CONS( X2, EMPTYLIST ) ); L6125: X3 = BOOLEAN( LT( _S2CINT( X2 ), 0 ) ); if ( TRUE( X3 ) ) goto L6131; if ( AND( EQ( TSCPTAG( c4170 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c4170 ), STRINGTAG ) ) ) goto L6133; scdebug_error( c4168, c4169, CONS( c4170, EMPTYLIST ) ); L6133: X4 = C_FIXED( STRING_LENGTH( c4170 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) goto L6137; if ( GTE( _S2CINT( X2 ), _S2CINT( X4 ) ) ) goto L6131; goto L6144; L6137: if ( FALSE( scrt2__3e_3d_2dtwo( X2, X4 ) ) ) goto L6144; L6131: scdebug_error( c4146, c2316, CONS( X2, EMPTYLIST ) ); L6144: X1 = C_CHAR( STRING_CHAR( c4170, X2 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( q4100 ) ), 3 ) ) goto L6147; if ( EQ( _S2CUINT( _TSCP( 0 ) ), _S2CUINT( q4100 ) ) ) goto L6151; goto L6152; L6147: if ( TRUE( scrt2__3d_2dtwo( _TSCP( 0 ), q4100 ) ) ) goto L6151; L6152: X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( q4100 ), _S2CINT( DISPLAY( 0 ) ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L6161; if ( EQ( _S2CUINT( DISPLAY( 0 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L6161; X3 = C_FIXED( QUOTIENT( _S2CINT( q4100 ), _S2CINT( DISPLAY( 0 ) ) ) ); goto L6162; L6161: X3 = scrt2_quotient( q4100, DISPLAY( 0 ) ); L6162: X5 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( q4100 ), _S2CINT( DISPLAY( 0 ) ) ), 3 ) ) ); if ( FALSE( X5 ) ) goto L6169; if ( EQ( _S2CUINT( DISPLAY( 0 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L6169; X4 = _TSCP( REMAINDER( _S2CINT( q4100 ), _S2CINT( DISPLAY( 0 ) ) ) ); goto L6170; L6169: X4 = scrt2_remainder( q4100, DISPLAY( 0 ) ); L6170: X2 = scrt2_l4098( X3, X4 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L6151: X2 = sc_cons( X1, EMPTYLIST ); POPSTACKTRACE( X2 ); } TSCP scrt2_integer_2d_3estring( n4086, b4087 ) TSCP n4086, b4087; { TSCP X5, X4, X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t6087 ); DISPLAY( 0 ) = b4087; if ( BITAND( BITOR( _S2CINT( n4086 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L6090; if ( LT( _S2CINT( n4086 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L6094; goto L6095; L6090: if ( FALSE( scrt2__3c_2dtwo( n4086, _TSCP( 0 ) ) ) ) goto L6095; L6094: if ( NEQ( TSCPTAG( n4086 ), FIXNUMTAG ) ) goto L6098; if ( LT( _S2CINT( n4086 ), 0 ) ) goto L6103; X2 = n4086; goto L6099; L6103: X2 = _TSCP( INEGATE( _S2CINT( n4086 ) ) ); goto L6099; L6098: X2 = scrt2_abs( n4086 ); L6099: X1 = CONS( scrt2_integer_2d_3estring( X2, DISPLAY( 0 ) ), EMPTYLIST ); SDVAL = scrt3_string_2dappend( CONS( c4197, X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L6095: X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( n4086 ), _S2CINT( DISPLAY( 0 ) ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L6111; if ( EQ( _S2CUINT( DISPLAY( 0 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L6111; X3 = C_FIXED( QUOTIENT( _S2CINT( n4086 ), _S2CINT( DISPLAY( 0 ) ) ) ); goto L6112; L6111: X3 = scrt2_quotient( n4086, DISPLAY( 0 ) ); L6112: X5 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( n4086 ), _S2CINT( DISPLAY( 0 ) ) ), 3 ) ) ); if ( FALSE( X5 ) ) goto L6119; if ( EQ( _S2CUINT( DISPLAY( 0 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L6119; X4 = _TSCP( REMAINDER( _S2CINT( n4086 ), _S2CINT( DISPLAY( 0 ) ) ) ); goto L6120; L6119: X4 = scrt2_remainder( n4086, DISPLAY( 0 ) ); L6120: X2 = scrt2_l4098( X3, X4 ); X1 = scrt1_reverse( X2 ); SDVAL = scrt3_list_2d_3estring( X1 ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } DEFTSCP( scrt2_string_2d_3enumber_v ); DEFCSTRING( t6172, "STRING->NUMBER" ); EXTERNTSCPP( scrt3_string_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2d_3elist_v ); EXTERNTSCP( sc_emptystring ); EXTERNTSCPP( scrt1_memv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memv_v ); EXTERNTSCPP( sc_make_2dstring, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dstring_v ); EXTERNTSCPP( scrt2_try_2dto_2dread, XAL1( TSCP ) ); EXTERNTSCP( scrt2_try_2dto_2dread_v ); TSCP scrt2_string_2d_3enumber( s4213, r4214 ) TSCP s4213, r4214; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6172 ); X1 = scrt3_string_2d_3elist( s4213 ); if ( FALSE( r4214 ) ) goto L6174; if ( EQ( TSCPTAG( r4214 ), PAIRTAG ) ) goto L6177; scrt1__24__car_2derror( r4214 ); L6177: X3 = PAIR_CAR( r4214 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 8 ) ) ) ) goto L6180; X2 = c4268; goto L6175; L6180: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 32 ) ) ) ) goto L6182; X2 = c4267; goto L6175; L6182: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 40 ) ) ) ) goto L6184; X2 = sc_emptystring; goto L6175; L6184: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 64 ) ) ) ) goto L6186; X2 = c4266; goto L6175; L6186: X2 = scdebug_error( c4260, c4261, CONS( PAIR_CAR( r4214 ), EMPTYLIST ) ); goto L6175; L6174: X2 = sc_emptystring; L6175: X3 = sc_emptystring; X4 = X3; X5 = X1; L6192: if ( FALSE( X5 ) ) goto L6193; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6196; scrt1__24__car_2derror( X5 ); L6196: X6 = PAIR_CAR( X5 ); if ( FALSE( scrt1_memv( X6, c4228 ) ) ) goto L6199; X7 = sc_make_2dstring( _TSCP( 4 ), CONS( PAIR_CAR( X5 ), EMPTYLIST ) ); X5 = PAIR_CDR( X5 ); X4 = X7; GOBACK( L6192 ); L6199: if ( NEQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 8978 ) ) ) ) goto L6203; POPSTACKTRACE( scrt2_try_2dto_2dread( s4213 ) ); L6203: X8 = CONS( scrt3_list_2d_3estring( X5 ), EMPTYLIST ); X8 = CONS( X2, X8 ); X7 = scrt3_string_2dappend( CONS( X4, X8 ) ); POPSTACKTRACE( scrt2_try_2dto_2dread( X7 ) ); L6193: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt2_try_2dto_2dread_v ); DEFCSTRING( t6205, "SCRT2_TRY-TO-READ" ); EXTERNTSCP( scdebug__2aerror_2dhandler_2a_v ); TSCP scrt2_l4279( x4280, c6210 ) TSCP x4280, c6210; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "scrt2_l4279 [inside TRY-TO-READ]" ); X1 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c6210, 0 ); X2 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c6210, 1 ); scdebug__2aerror_2dhandler_2a_v = DISPLAY( 2 ); X4 = DISPLAY( 1 ); X4 = UNKNOWNCALL( X4, 1 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( FALSEVALUE, PROCEDURE_CLOSURE( X4 ) ); DISPLAY( 2 ) = X1; DISPLAY( 1 ) = X2; POPSTACKTRACE( X3 ); } EXTERNTSCPP( scrt5_open_2dinput_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2dinput_2dstring_v ); EXTERNTSCPP( scrt6_read, XAL1( TSCP ) ); EXTERNTSCP( scrt6_read_v ); EXTERNTSCPP( scrt6_eof_2dobject_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_eof_2dobject_3f_v ); TSCP scrt2_l4275( r4276, c6207 ) TSCP r4276, c6207; { TSCP X5, X4, X3, X2, X1; TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( "scrt2_l4275 [inside TRY-TO-READ]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c6207, 0 ); DISPLAY( 1 ) = r4276; DISPLAY( 2 ) = scdebug__2aerror_2dhandler_2a_v; scdebug__2aerror_2dhandler_2a_v = MAKEPROCEDURE( 0, 1, scrt2_l4279, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 2 ), DISPLAY( 1 ) ) ); X5 = scrt5_open_2dinput_2dstring( DISPLAY( 0 ) ); X3 = scrt6_read( CONS( X5, EMPTYLIST ) ); X4 = scrt6_read( CONS( X5, EMPTYLIST ) ); scdebug__2aerror_2dhandler_2a_v = DISPLAY( 2 ); if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L6218; if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), DOUBLEFLOATTAG ) ) ) goto L6218; X2 = FALSEVALUE; goto L6223; L6218: if ( FALSE( scrt6_eof_2dobject_3f( X4 ) ) ) goto L6222; X2 = X3; goto L6223; L6222: X2 = FALSEVALUE; L6223: DISPLAY( 0 ) = X1; SDVAL = X2; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } EXTERNTSCP( sc_ntinuation_1af38b9f_v ); TSCP scrt2_try_2dto_2dread( s4274 ) TSCP s4274; { TSCP X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t6205 ); DISPLAY( 0 ) = s4274; X2 = MAKEPROCEDURE( 1, 0, scrt2_l4275, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); X1 = sc_ntinuation_1af38b9f_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } void scrt5__init(); void scrt3__init(); void scrt6__init(); void scrt1__init(); void scdebug__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt5__init(); scrt3__init(); scrt6__init(); scrt1__init(); scdebug__init(); MAXDISPLAY( 3 ); } void scrt2__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scrt2 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t4797, ADR( scrt2_symbol_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_symbol_3f, EMPTYLIST ) ); INITIALIZEVAR( t4799, ADR( scrt2_symbol_2d_3estring_v ), MAKEPROCEDURE( 1, 0, scrt2_symbol_2d_3estring, EMPTYLIST ) ); INITIALIZEVAR( t4804, ADR( scrt2_top_2dlevel_2dvalue_v ), MAKEPROCEDURE( 1, 0, scrt2_top_2dlevel_2dvalue, EMPTYLIST ) ); INITIALIZEVAR( t4808, ADR( scrt2_2dvalue_21_c9d2a496_v ), MAKEPROCEDURE( 2, 0, scrt2_2dvalue_21_c9d2a496, EMPTYLIST ) ); INITIALIZEVAR( t4812, ADR( scrt2_getprop_v ), MAKEPROCEDURE( 2, 0, scrt2_getprop, EMPTYLIST ) ); INITIALIZEVAR( t4836, ADR( scrt2_getprop_2dall_v ), MAKEPROCEDURE( 1, 0, scrt2_getprop_2dall, EMPTYLIST ) ); INITIALIZEVAR( t4840, ADR( scrt2_putprop_v ), MAKEPROCEDURE( 3, 0, scrt2_putprop, EMPTYLIST ) ); INITIALIZEVAR( t4889, ADR( scrt2_fixed_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_fixed_3f, EMPTYLIST ) ); INITIALIZEVAR( t4891, ADR( scrt2_float_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_float_3f, EMPTYLIST ) ); INITIALIZEVAR( t4893, ADR( scrt2_float_2d_3efixed_v ), MAKEPROCEDURE( 1, 0, scrt2_float_2d_3efixed, EMPTYLIST ) ); INITIALIZEVAR( t4906, ADR( scrt2_fixed_2d_3efloat_v ), MAKEPROCEDURE( 1, 0, scrt2_fixed_2d_3efloat, EMPTYLIST ) ); INITIALIZEVAR( t4911, ADR( scrt2_number_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_number_3f, EMPTYLIST ) ); INITIALIZEVAR( t4915, ADR( scrt2_complex_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_complex_3f, EMPTYLIST ) ); INITIALIZEVAR( t4919, ADR( scrt2_real_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_real_3f, EMPTYLIST ) ); INITIALIZEVAR( t4923, ADR( scrt2_rational_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_rational_3f, EMPTYLIST ) ); INITIALIZEVAR( t4927, ADR( scrt2_integer_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_integer_3f, EMPTYLIST ) ); INITIALIZEVAR( t4936, ADR( scrt2_zero_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_zero_3f, EMPTYLIST ) ); INITIALIZEVAR( t4940, ADR( scrt2_positive_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_positive_3f, EMPTYLIST ) ); INITIALIZEVAR( t4944, ADR( scrt2_negative_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_negative_3f, EMPTYLIST ) ); INITIALIZEVAR( t4948, ADR( scrt2_odd_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_odd_3f, EMPTYLIST ) ); INITIALIZEVAR( t4973, ADR( scrt2_even_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_even_3f, EMPTYLIST ) ); INITIALIZEVAR( t4996, ADR( scrt2_exact_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_exact_3f, EMPTYLIST ) ); INITIALIZEVAR( t5003, ADR( scrt2_inexact_3f_v ), MAKEPROCEDURE( 1, 0, scrt2_inexact_3f, EMPTYLIST ) ); INITIALIZEVAR( t5010, ADR( scrt2__3d_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__3d_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5029, ADR( scrt2__3d_v ), MAKEPROCEDURE( 2, 1, scrt2__3d, EMPTYLIST ) ); INITIALIZEVAR( t5054, ADR( scrt2__3c_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__3c_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5073, ADR( scrt2__3c_v ), MAKEPROCEDURE( 2, 1, scrt2__3c, EMPTYLIST ) ); INITIALIZEVAR( t5098, ADR( scrt2__3e_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__3e_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5117, ADR( scrt2__3e_v ), MAKEPROCEDURE( 2, 1, scrt2__3e, EMPTYLIST ) ); INITIALIZEVAR( t5142, ADR( scrt2__3c_3d_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__3c_3d_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5161, ADR( scrt2__3c_3d_v ), MAKEPROCEDURE( 2, 1, scrt2__3c_3d, EMPTYLIST ) ); INITIALIZEVAR( t5186, ADR( scrt2__3e_3d_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__3e_3d_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5205, ADR( scrt2__3e_3d_v ), MAKEPROCEDURE( 2, 1, scrt2__3e_3d, EMPTYLIST ) ); INITIALIZEVAR( t5230, ADR( scrt2_max_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2_max_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5238, ADR( scrt2_max_v ), MAKEPROCEDURE( 1, 1, scrt2_max, EMPTYLIST ) ); INITIALIZEVAR( t5259, ADR( scrt2_min_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2_min_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5267, ADR( scrt2_min_v ), MAKEPROCEDURE( 1, 1, scrt2_min, EMPTYLIST ) ); INITIALIZEVAR( t5288, ADR( scrt2__2b_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__2b_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5307, ADR( scrt2__2b_v ), MAKEPROCEDURE( 0, 1, scrt2__2b, EMPTYLIST ) ); INITIALIZEVAR( t5320, ADR( scrt2__2a_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__2a_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5339, ADR( scrt2__2a_v ), MAKEPROCEDURE( 0, 1, scrt2__2a, EMPTYLIST ) ); INITIALIZEVAR( t5352, ADR( scrt2__2d_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__2d_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5371, ADR( scrt2__2d_v ), MAKEPROCEDURE( 1, 1, scrt2__2d, EMPTYLIST ) ); INITIALIZEVAR( t5396, ADR( scrt2__2f_2dtwo_v ), MAKEPROCEDURE( 2, 0, scrt2__2f_2dtwo, EMPTYLIST ) ); INITIALIZEVAR( t5419, ADR( scrt2__2f_v ), MAKEPROCEDURE( 1, 1, scrt2__2f, EMPTYLIST ) ); INITIALIZEVAR( t5473, ADR( scrt2_abs_v ), MAKEPROCEDURE( 1, 0, scrt2_abs, EMPTYLIST ) ); INITIALIZEVAR( t5485, ADR( scrt2_quotient_v ), MAKEPROCEDURE( 2, 0, scrt2_quotient, EMPTYLIST ) ); INITIALIZEVAR( t5506, ADR( scrt2_remainder_v ), MAKEPROCEDURE( 2, 0, scrt2_remainder, EMPTYLIST ) ); INITIALIZEVAR( t5529, ADR( scrt2_modulo_v ), MAKEPROCEDURE( 2, 0, scrt2_modulo, EMPTYLIST ) ); INITIALIZEVAR( t5577, ADR( scrt2_gcd_v ), MAKEPROCEDURE( 0, 1, scrt2_gcd, EMPTYLIST ) ); INITIALIZEVAR( t5665, ADR( scrt2_lcm_v ), MAKEPROCEDURE( 0, 1, scrt2_lcm, EMPTYLIST ) ); INITIALIZEVAR( t5777, ADR( scrt2_floor_v ), MAKEPROCEDURE( 1, 0, scrt2_floor, EMPTYLIST ) ); INITIALIZEVAR( t5781, ADR( scrt2_ceiling_v ), MAKEPROCEDURE( 1, 0, scrt2_ceiling, EMPTYLIST ) ); INITIALIZEVAR( t5785, ADR( scrt2_truncate_v ), MAKEPROCEDURE( 1, 0, scrt2_truncate, EMPTYLIST ) ); INITIALIZEVAR( t5796, ADR( scrt2_round_v ), MAKEPROCEDURE( 1, 0, scrt2_round, EMPTYLIST ) ); INITIALIZEVAR( t5802, ADR( scrt2_exp_v ), MAKEPROCEDURE( 1, 0, scrt2_exp, EMPTYLIST ) ); INITIALIZEVAR( t5804, ADR( scrt2_log_v ), MAKEPROCEDURE( 1, 0, scrt2_log, EMPTYLIST ) ); INITIALIZEVAR( t5806, ADR( scrt2_sin_v ), MAKEPROCEDURE( 1, 0, scrt2_sin, EMPTYLIST ) ); INITIALIZEVAR( t5808, ADR( scrt2_cos_v ), MAKEPROCEDURE( 1, 0, scrt2_cos, EMPTYLIST ) ); INITIALIZEVAR( t5810, ADR( scrt2_tan_v ), MAKEPROCEDURE( 1, 0, scrt2_tan, EMPTYLIST ) ); INITIALIZEVAR( t5812, ADR( scrt2_asin_v ), MAKEPROCEDURE( 1, 0, scrt2_asin, EMPTYLIST ) ); INITIALIZEVAR( t5814, ADR( scrt2_acos_v ), MAKEPROCEDURE( 1, 0, scrt2_acos, EMPTYLIST ) ); INITIALIZEVAR( t5816, ADR( scrt2_atan_v ), MAKEPROCEDURE( 1, 1, scrt2_atan, EMPTYLIST ) ); INITIALIZEVAR( t5823, ADR( scrt2_sqrt_v ), MAKEPROCEDURE( 1, 0, scrt2_sqrt, EMPTYLIST ) ); INITIALIZEVAR( t5853, ADR( scrt2_expt_v ), MAKEPROCEDURE( 2, 0, scrt2_expt, EMPTYLIST ) ); INITIALIZEVAR( t5902, ADR( scrt2_exact_2d_3einexact_v ), MAKEPROCEDURE( 1, 0, scrt2_exact_2d_3einexact, EMPTYLIST ) ); INITIALIZEVAR( t5909, ADR( scrt2_inexact_2d_3eexact_v ), MAKEPROCEDURE( 1, 0, scrt2_inexact_2d_3eexact, EMPTYLIST ) ); INITIALIZEVAR( t5924, ADR( scrt2_number_2d_3estring_v ), MAKEPROCEDURE( 1, 1, scrt2_number_2d_3estring, EMPTYLIST ) ); INITIALIZEVAR( t6087, ADR( scrt2_integer_2d_3estring_v ), MAKEPROCEDURE( 2, 0, scrt2_integer_2d_3estring, EMPTYLIST ) ); INITIALIZEVAR( t6172, ADR( scrt2_string_2d_3enumber_v ), MAKEPROCEDURE( 1, 1, scrt2_string_2d_3enumber, EMPTYLIST ) ); INITIALIZEVAR( t6205, ADR( scrt2_try_2dto_2dread_v ), MAKEPROCEDURE( 1, 0, scrt2_try_2dto_2dread, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/scrt2.sc000066400000000000000000000405121203736146400161420ustar00rootroot00000000000000;;; SCHEME->C Runtime Library ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scrt2 (top-level SYMBOL? SYMBOL->STRING TOP-LEVEL-VALUE SET-TOP-LEVEL-VALUE! GETPROP GETPROP-ALL PUTPROP FIXED? FLOAT? FLOAT->FIXED FIXED->FLOAT NUMBER? COMPLEX? REAL? RATIONAL? INTEGER? ZERO? POSITIVE? NEGATIVE? ODD? EVEN? EXACT? INEXACT? = < > <= >= MAX MIN + * - / ABS QUOTIENT REMAINDER MODULO GCD LCM FLOOR CEILING TRUNCATE ROUND EXP LOG SIN COS TAN ASIN ACOS ATAN SQRT EXPT EXACT->INEXACT INEXACT->EXACT NUMBER->STRING STRING->NUMBER)) (include "repdef.sc") ;;; 6.4 Symbols. (define (SYMBOL? x) (symbol? x)) (define (SYMBOL->STRING x) (symbol->string x)) (define (TOP-LEVEL-VALUE symbol) (if (not (symbol? symbol)) (error 'TOP-LEVEL-VALUE "Argument is not a SYMBOL: ~s" symbol)) ((lap (symbol) (SYMBOL_VALUE symbol)) symbol)) (define (SET-TOP-LEVEL-VALUE! symbol value) (if (not (symbol? symbol)) (error 'SET-TOP-LEVEL-VALUE! "Argument is not a SYMBOL: ~s" symbol)) ((lap (symbol value) (SETGENTL (SYMBOL_VALUE symbol) value)) symbol value)) (define (GETPROP symbol key) (if (not (symbol? symbol)) (error 'GETPROP "Argument is not a SYMBOL: ~s" symbol)) (let loop ((pl ((lap (symbol) (SYMBOL_PROPERTYLIST symbol)) symbol))) (cond ((null? pl) #f) ((eq? (car pl) key) (cadr pl)) (else (loop (cddr pl)))))) (define (GETPROP-ALL symbol) (if (not (symbol? symbol)) (error 'GETPROP-ALL "Argument is not a SYMBOL: ~s" symbol)) ((lap (symbol) (SYMBOL_PROPERTYLIST symbol)) symbol)) (define (PUTPROP symbol key value) (if (not (symbol? symbol)) (error 'PUTPROP "Argument is not a SYMBOL: ~s" symbol)) (let loop ((pl ((lap (symbol) (SYMBOL_PROPERTYLIST symbol)) symbol)) (prev '())) (cond ((null? pl) (if (not (eq? value #f)) (if prev (set-cdr! prev (list key value)) ((lap (symbol newpl) (SETGEN (SYMBOL_PROPERTYLIST symbol) newpl)) symbol (list key value))))) ((eq? (car pl) key) (if (eq? value #f) (if prev (set-cdr! prev (cddr pl)) ((lap (symbol newpl) (SETGEN (SYMBOL_PROPERTYLIST symbol) newpl)) symbol (cddr pl))) (set-car! (cdr pl) value))) (else (loop (cddr pl) (cdr pl))))) value) ;;; 6.5 Numbers. (define (FIXED? x) (fixed? x)) (define (FLOAT? x) (float? x)) (define (FLOAT->FIXED x) (float->fixed x)) (define (FIXED->FLOAT x) (fixed->float x)) (define (NUMBER? x) (or (fixed? x) (float? x))) (define (COMPLEX? x) (or (fixed? x) (float? x))) (define (REAL? x) (or (fixed? x) (float? x))) (define (RATIONAL? x) (rational? x)) (define (INTEGER? x) (integer? x)) (define (ZERO? x) (= x 0)) (define (POSITIVE? x) (> x 0)) (define (NEGATIVE? x) (< x 0)) (define (ODD? x) (odd? x)) (define (EVEN? x) (even? x)) (define (EXACT? x) (exact? x)) (define (INEXACT? x) (inexact? x)) (define (=-TWO x y) (cond ((fixed? x) (cond ((fixed? y) ((lap (x y) (BOOLEAN (EQ (_S2CINT x) (_S2CINT y)))) x y)) ((float? y) ((lap (x y) (BOOLEAN (EQ (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '= "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (BOOLEAN (EQ (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '= "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (BOOLEAN (EQ (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '= "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (= x y . z) (define (=-LIST x z) (cond ((null? z) #t) ((= x (car z)) (=-list (car z) (cdr z))) (else #f))) (and (= x y) (=-list y z))) (define (<-TWO x y) (cond ((fixed? x) (cond ((fixed? y) ((lap (x y) (BOOLEAN (LT (_S2CINT x) (_S2CINT y)))) x y)) ((float? y) ((lap (x y) (BOOLEAN (LT (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '< "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (BOOLEAN (LT (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '< "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (BOOLEAN (LT (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '< "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (< x y . z) (define (<-LIST x z) (cond ((null? z) #t) ((< x (car z)) (<-list (car z) (cdr z))) (else #f))) (and (< x y) (<-list y z))) (define (>-TWO x y) (cond ((fixed? x) (cond ((fixed? y) ((lap (x y) (BOOLEAN (GT (_S2CINT x) (_S2CINT y)))) x y)) ((float? y) ((lap (x y) (BOOLEAN (GT (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '> "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (BOOLEAN (GT (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '> "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (BOOLEAN (GT (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '> "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (> x y . z) (define (>-LIST x z) (cond ((null? z) #t) ((> x (car z)) (>-list (car z) (cdr z))) (else #f))) (and (> x y) (>-list y z))) (define (<=-TWO x y) (cond ((fixed? x) (cond ((fixed? y) ((lap (x y) (BOOLEAN (LTE (_S2CINT x) (_S2CINT y)))) x y)) ((float? y) ((lap (x y) (BOOLEAN (LTE (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '<= "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (BOOLEAN (LTE (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '<= "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (BOOLEAN (LTE (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '<= "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (<= x y . z) (define (<=-LIST x z) (cond ((null? z) #t) ((<= x (car z)) (<=-list (car z) (cdr z))) (else #f))) (and (<= x y) (<=-list y z))) (define (>=-TWO x y) (cond ((fixed? x) (cond ((fixed? y) ((lap (x y) (BOOLEAN (GTE (_S2CINT x) (_S2CINT y)))) x y)) ((float? y) ((lap (x y) (BOOLEAN (GTE (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '>= "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (BOOLEAN (GTE (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '>= "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (BOOLEAN (GTE (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '>= "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (>= x y . z) (define (>=-LIST x z) (cond ((null? z) #t) ((>= x (car z)) (>=-list (car z) (cdr z))) (else #f))) (and (>= x y) (>=-list y z))) (define (MAX-TWO x y) (if (> x y) x y)) (define (MAX x . y) (let loop ((x x) (y y)) (if y (loop (if (> x (car y)) x (car y)) (cdr y)) x))) (define (MIN-TWO x y) (if (< x y) x y)) (define (MIN x . y) (let loop ((x x) (y y)) (if y (loop (if (< x (car y)) x (car y)) (cdr y)) x))) (define (+-TWO x y) (cond ((fixed? x) (cond ((fixed? y) ((lap (x y) (_TSCP (IPLUS (_S2CINT x) (_S2CINT y)))) x y)) ((float? y) ((lap (x y) (FLTV_FLT (PLUS (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '+ "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (FLTV_FLT (PLUS (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '+ "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (FLTV_FLT (PLUS (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '+ "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (+ . x) (let loop ((sum 0) (x x)) (if x (loop (+ sum (car x)) (cdr x)) sum))) (define (*-TWO x y) (cond ((fixed? x) (cond ((fixed? y) ((lap (x y) (_TSCP (ITIMES (FIXED_C x) (_S2CINT y)))) x y)) ((float? y) ((lap (x y) (FLTV_FLT (TIMES (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '* "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (FLTV_FLT (TIMES (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '* "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (FLTV_FLT (TIMES (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '* "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (* . x) (let loop ((product 1) (x x)) (if x (loop (* product (car x)) (cdr x)) product))) (define (--TWO x y) (cond ((fixed? x) (cond ((fixed? y) ((lap (x y) (_TSCP (IDIFFERENCE (_S2CINT x) (_S2CINT y)))) x y)) ((float? y) ((lap (x y) (FLTV_FLT (DIFFERENCE (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '- "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (FLTV_FLT (DIFFERENCE (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '- "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (FLTV_FLT (DIFFERENCE (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '- "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (- x . y) (if y (let loop ((result (- x (car y))) (args (cdr y))) (if args (loop (- result (car args)) (cdr args)) result)) (- 0 x))) (define (/-TWO x y) (cond ((eq? y 0) (error '/ "Divisor is equal to 0: ~s" y)) ((fixed? x) (cond ((fixed? y) (if (eq? ((lap (x y) (_TSCP (REMAINDER (_S2CINT x) (_S2CINT y)))) x y) 0) ((lap (x y) (C_FIXED (QUOTIENT (_S2CINT x) (_S2CINT y)))) x y) ((lap (x y) (FLTV_FLT (QUOTIENT (FIX_FLTV x) (FIX_FLTV y)))) x y))) ((float? y) ((lap (x y) (FLTV_FLT (QUOTIENT (FIX_FLTV x) (FLOAT_VALUE y)))) x y)) (else (error '/ "Argument not a NUMBER: ~s" y)))) ((fixed? y) (cond ((float? x) ((lap (x y) (FLTV_FLT (QUOTIENT (FLOAT_VALUE x) (FIX_FLTV y)))) x y)) (else (error '/ "Argument not a NUMBER: ~s" x)))) ((and (float? x) (float? y)) ((lap (x y) (FLTV_FLT (QUOTIENT (FLOAT_VALUE x) (FLOAT_VALUE y)))) x y)) (else (error '/ "Argument(s) not a NUMBER: ~s ~s" x y)))) (define (/ x . y) (if y (let loop ((result (/ x (car y))) (z (cdr y))) (if z (loop (/ result (car z)) (cdr z)) result)) (/ 1 x))) (define (ABS x) (if (negative? x) (- 0 x) x)) (define (QUOTIENT x y) (if (and (two-fixeds? x y) (not (eq? y 0))) ((lap (x y) (C_FIXED (QUOTIENT (_S2CINT x) (_S2CINT y)))) x y) (truncate (/ x y)))) (define (REMAINDER x y) (if (and (two-fixeds? x y) (not (eq? y 0))) ((lap (x y) (_TSCP (REMAINDER (_S2CINT x) (_S2CINT y)))) x y) (round (- x (* y (quotient x y)))))) (define (MODULO x y) (let ((r (remainder x y))) (if (zero? r) r (if (positive? y) (if (positive? r) r (+ y r)) (if (negative? r) r (+ y r)))))) (define (GCD . x) (define (GCD2 m n) (if (zero? n) m (let ((r (remainder m n))) (if (= r 0) n (gcd2 n r))))) (case (length x) ((0) 0) ((1) (abs (car x))) (else (let loop ((result (gcd2 (abs (car x)) (abs (cadr x)))) (left (cddr x))) (if left (loop (gcd2 result (abs (car left))) (cdr left)) result))))) (define (LCM . x) (define (LCM2 m n) (let ((m (abs m)) (n (abs n))) (cond ((= m n) m) ((= (remainder m n) 0) m) ((= (remainder n m) 0) n) (else (* (/ m (gcd m n)) n))))) (case (length x) ((0) 1) ((1) (abs (car x))) (else (let loop ((result (lcm2 (car x) (cadr x))) (left (cddr x))) (if left (loop (lcm2 result (car left)) (cdr left)) result))))) (define (FLOOR x) (if (fixed? x) x ((lap (x) (C_FLOOR x)) x))) (define (CEILING x) (if (fixed? x) x ((lap (x) (C_CEILING x)) x))) (define (TRUNCATE x) (if (< x 0) (ceiling x) (floor x))) (define (ROUND x) (if (fixed? x) x (floor (+ x .5)))) (define (EXP x) ((lap (x) (C_EXP x)) x)) (define (LOG x) ((lap (x) (C_LOG x)) x)) (define (SIN x) ((lap (x) (C_SIN x)) x)) (define (COS x) ((lap (x) (C_COS x)) x)) (define (TAN x) ((lap (x) (C_TAN x)) x)) (define (ASIN x) ((lap (x) (C_ASIN x)) x)) (define (ACOS x) ((lap (x) (C_ACOS x)) x)) (define (ATAN x . y) (if y ((lap (x y) (C_ATAN2 x y)) x (car y)) ((lap (x) (C_ATAN x)) x))) (define (SQRT x) (if (negative? x) (error 'SQRT "Argument must be a non-negative NUMBER: ~s" x)) (let ((iresult ((lap (x) (C_SQRT x)) x))) (if (fixed? x) (let ((eresult (float->fixed (round iresult)))) (if (eq? (* eresult eresult) x) eresult iresult)) iresult))) (define (EXPT x y) (if (and (= x 0.0) (= y 0.0)) 1.0 (let ((iresult ((lap (x y) (C_POW x y)) x y))) (if (and (fixed? x) (fixed? y) (<= (abs iresult) ((lap () (C_FIXED "MAXS2CINT >> 2"))))) (float->fixed (round iresult)) iresult)))) (define (EXACT->INEXACT x) (cond ((fixed? x) (fixed->float x)) ((float? x) x) (else (error 'EXACT->INEXACT "Argument is not a NUMBER: ~s" x)))) (define (INEXACT->EXACT x) (cond ((fixed? x) x) ((float? x) (float->fixed x)) (else (error 'INEXACT->EXACT "Argument is not a NUMBER: ~s" x)))) (define (NUMBER->STRING number . form) (if (not (number? number)) (error 'NUMBER->STRING "Argument is not a NUMBER: ~s" number)) (set! form (if form (car form) 10)) (cond ((equal? form '(int)) ; (int) => [-]dddddddd (formatnumber number 0 0)) ((and (pair? form) (= (length form) 2) (eq? (car form) 'fix) (fixed? (cadr form)) (>= (cadr form) 0)) ; (fix n) => [-]dddddddd. (formatnumber number 1 (cadr form))) ((and (pair? form) (= (length form) 2) (eq? (car form) 'sci) (fixed? (cadr form)) (>= (cadr form) 0)) ; (sci n) => [-]d.ddde+dd (formatnumber number 2 (cadr form))) ((= form 2) ; 2 => binary integer (integer->string number 2)) ((= form 8) ; 8 => octal integer (integer->string number 8)) ((= form 10) ; 10 => any number (format "~s" number)) ((= form 16) (integer->string number 16)) (else (error 'NUMBER->STRING "Argument is not a RADIX or FORMAT DESCRIPTOR: ~s" form)))) (define (INTEGER->STRING number base) (if (< number 0) (string-append "-" (integer->string (abs number) base)) (list->string (reverse (let loop ((q (quotient number base)) (r (remainder number base))) (let ((digit (string-ref "0123456789abcdef" (inexact->exact r)))) (if (= 0 q) (list digit) (cons digit (loop (quotient q base) (remainder q base)))))))))) (define (STRING->NUMBER string . radix) (let ((radix (if radix (case (car radix) ((2) "#b") ((8) "#o") ((10) "") ((16) "#x") (else (error 'STRING->NUMBER "Argument is not a RADIX: ~s" (car radix)))) "")) (chars (string->list string))) (let loop ((sign "") (chars chars)) (if chars (case (car chars) ((#\- #\+) (loop (make-string 1 (car chars)) (cdr chars))) ((#\#) (try-to-read string)) (else (try-to-read (string-append sign radix (list->string chars))))))))) (define (TRY-TO-READ string) (call-with-current-continuation (lambda (return) (let ((restore-error-handler *error-handler*)) (set! *error-handler* (lambda x (set! *error-handler* restore-error-handler) (return #f))) (let* ((port (open-input-string string)) (number (read port)) (eof (read port))) (set! *error-handler* restore-error-handler) (if (and (number? number) (eof-object? eof)) number #f)))))) scheme2c-2012.10.14/scrt/scrt3.c000066400000000000000000002530601203736146400157640ustar00rootroot00000000000000 /* SCHEME->C */ #include void scrt3__init(); DEFSTATICTSCP( c3560 ); DEFCSTRING( t3800, "Argument is not a list of CHARACTERS: ~s" ); DEFSTATICTSCP( c3536 ); DEFSTATICTSCP( c3535 ); DEFSTATICTSCP( c3484 ); DEFSTATICTSCP( c3459 ); DEFCSTRING( t3801, "Argument(s) not a STRING INDEX" ); DEFSTATICTSCP( c3323 ); DEFCSTRING( t3802, "Argument is not a STRING" ); DEFSTATICTSCP( c3282 ); DEFSTATICTSCP( c3281 ); DEFSTATICTSCP( c3175 ); DEFSTATICTSCP( c3070 ); DEFSTATICTSCP( c2969 ); DEFSTATICTSCP( c2890 ); DEFSTATICTSCP( c2817 ); DEFCSTRING( t3803, "Argument(s) not a STRING" ); DEFSTATICTSCP( c2748 ); DEFSTATICTSCP( c2747 ); DEFCSTRING( t3804, "Argument(s) incorrect" ); DEFSTATICTSCP( c2735 ); DEFCSTRING( t3805, "Argument is not a CHAR: ~s" ); DEFSTATICTSCP( c2714 ); DEFSTATICTSCP( c2711 ); DEFCSTRING( t3806, "Argument is out of range: ~s" ); DEFSTATICTSCP( c2700 ); DEFSTATICTSCP( c2679 ); DEFCSTRING( t3807, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c2670 ); DEFSTATICTSCP( c2669 ); DEFSTATICTSCP( c2586 ); DEFSTATICTSCP( c2565 ); DEFSTATICTSCP( c2544 ); DEFSTATICTSCP( c2523 ); DEFSTATICTSCP( c2482 ); DEFSTATICTSCP( c2459 ); DEFCSTRING( t3808, "Argument not a CHAR" ); DEFSTATICTSCP( c2416 ); DEFSTATICTSCP( c2415 ); DEFSTATICTSCP( c2378 ); DEFSTATICTSCP( c2336 ); DEFSTATICTSCP( c2219 ); DEFCSTRING( t3809, "Argument not a CHAR: ~s" ); DEFSTATICTSCP( c2196 ); DEFSTATICTSCP( c2195 ); DEFCSTRING( t3810, "Argument not an unsigned 8-bit INTEGER: ~s" ); DEFSTATICTSCP( c2113 ); DEFSTATICTSCP( c2112 ); DEFCSTRING( t3811, "Index is not in bounds: ~s" ); DEFSTATICTSCP( c2085 ); DEFCSTRING( t3812, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2081 ); DEFCSTRING( t3813, "Argument is not a VECTOR: ~s" ); DEFSTATICTSCP( c2078 ); DEFSTATICTSCP( c2077 ); DEFSTATICTSCP( c2034 ); DEFSTATICTSCP( c2024 ); DEFCSTRING( t3814, "Argument(s) not CHAR: ~s ~s" ); DEFSTATICTSCP( c2014 ); DEFSTATICTSCP( c2013 ); static void init_constants() { c3560 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-FILL!" ) ); CONSTANTEXP( ADR( c3560 ) ); c3536 = CSTRING_TSCP( t3800 ); CONSTANTEXP( ADR( c3536 ) ); c3535 = STRINGTOSYMBOL( CSTRING_TSCP( "LIST->STRING" ) ); CONSTANTEXP( ADR( c3535 ) ); c3484 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING->LIST" ) ); CONSTANTEXP( ADR( c3484 ) ); c3459 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-APPEND" ) ); CONSTANTEXP( ADR( c3459 ) ); c3323 = CSTRING_TSCP( t3801 ); CONSTANTEXP( ADR( c3323 ) ); c3282 = CSTRING_TSCP( t3802 ); CONSTANTEXP( ADR( c3282 ) ); c3281 = STRINGTOSYMBOL( CSTRING_TSCP( "SUBSTRING" ) ); CONSTANTEXP( ADR( c3281 ) ); c3175 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-CI>?" ) ); CONSTANTEXP( ADR( c3175 ) ); c3070 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-CI?" ) ); CONSTANTEXP( ADR( c2890 ) ); c2817 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING=?" ) ); CONSTANTEXP( ADR( c2378 ) ); c2336 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR<=?" ) ); CONSTANTEXP( ADR( c2336 ) ); c2219 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-REF" ) ); CONSTANTEXP( ADR( c2219 ) ); c2196 = CSTRING_TSCP( t3809 ); CONSTANTEXP( ADR( c2196 ) ); c2195 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR->INTEGER" ) ); CONSTANTEXP( ADR( c2195 ) ); c2113 = CSTRING_TSCP( t3810 ); CONSTANTEXP( ADR( c2113 ) ); c2112 = STRINGTOSYMBOL( CSTRING_TSCP( "INTEGER->CHAR" ) ); CONSTANTEXP( ADR( c2112 ) ); c2085 = CSTRING_TSCP( t3811 ); CONSTANTEXP( ADR( c2085 ) ); c2081 = CSTRING_TSCP( t3812 ); CONSTANTEXP( ADR( c2081 ) ); c2078 = CSTRING_TSCP( t3813 ); CONSTANTEXP( ADR( c2078 ) ); c2077 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-SET!" ) ); CONSTANTEXP( ADR( c2077 ) ); c2034 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR>?" ) ); CONSTANTEXP( ADR( c2034 ) ); c2024 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR?" ); TSCP scrt3_char_3e_3f( x2026, y2027 ) TSCP x2026, y2027; { TSCP X1; PUSHSTACKTRACE( t3827 ); if ( AND( EQ( TSCPIMMEDIATETAG( x2026 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( y2027 ), CHARACTERTAG ) ) ) goto L3830; X1 = CONS( y2027, EMPTYLIST ); scdebug_error( c2034, c2014, CONS( x2026, X1 ) ); L3830: POPSTACKTRACE( BOOLEAN( GT( _S2CINT( x2026 ), _S2CINT( y2027 ) ) ) ); } DEFTSCP( scrt3_char_3c_3d_3f_v ); DEFCSTRING( t3832, "CHAR<=?" ); TSCP scrt3_char_3c_3d_3f( x2036, y2037 ) TSCP x2036, y2037; { TSCP X1; PUSHSTACKTRACE( t3832 ); if ( AND( EQ( TSCPIMMEDIATETAG( x2036 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( y2037 ), CHARACTERTAG ) ) ) goto L3835; X1 = CONS( y2037, EMPTYLIST ); scdebug_error( c2034, c2014, CONS( x2036, X1 ) ); L3835: POPSTACKTRACE( BOOLEAN( LTE( _S2CINT( x2036 ), _S2CINT( y2037 ) ) ) ); } DEFTSCP( scrt3_char_3e_3d_3f_v ); DEFCSTRING( t3837, "CHAR>=?" ); TSCP scrt3_char_3e_3d_3f( x2045, y2046 ) TSCP x2045, y2046; { TSCP X1; PUSHSTACKTRACE( t3837 ); if ( AND( EQ( TSCPIMMEDIATETAG( x2045 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( y2046 ), CHARACTERTAG ) ) ) goto L3840; X1 = CONS( y2046, EMPTYLIST ); scdebug_error( c2024, c2014, CONS( x2045, X1 ) ); L3840: POPSTACKTRACE( BOOLEAN( GTE( _S2CINT( x2045 ), _S2CINT( y2046 ) ) ) ); } DEFTSCP( scrt3_char_2dupcase_2dtable_v ); DEFCSTRING( t3842, "SCRT3_CHAR-UPCASE-TABLE" ); EXTERNTSCPP( sc_make_2dvector, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dvector_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt2__3c_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_2dtwo_v ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); DEFTSCP( scrt3_char_2dci_3d_3f_v ); DEFCSTRING( t3941, "CHAR-CI=?" ); TSCP scrt3_char_2dci_3d_3f( x2204, y2205 ) TSCP x2204, y2205; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3941 ); X2 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( y2205 ), CHARACTERTAG ) ) goto L3944; scdebug_error( c2195, c2196, CONS( y2205, EMPTYLIST ) ); L3944: X3 = CHAR_FIX( y2205 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), VECTORTAG ) ) ) goto L3947; scdebug_error( c2219, c2078, CONS( X2, EMPTYLIST ) ); L3947: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L3949; scdebug_error( c2219, c2081, CONS( X3, EMPTYLIST ) ); L3949: if ( LT( _S2CUINT( FIXED_C( X3 ) ), _S2CUINT( VECTOR_LENGTH( X2 ) ) ) ) goto L3951; scdebug_error( c2219, c2085, CONS( X3, EMPTYLIST ) ); L3951: X1 = VECTOR_ELEMENT( X2, X3 ); X3 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( x2204 ), CHARACTERTAG ) ) goto L3954; scdebug_error( c2195, c2196, CONS( x2204, EMPTYLIST ) ); L3954: X4 = CHAR_FIX( x2204 ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), VECTORTAG ) ) ) goto L3957; scdebug_error( c2219, c2078, CONS( X3, EMPTYLIST ) ); L3957: if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L3959; scdebug_error( c2219, c2081, CONS( X4, EMPTYLIST ) ); L3959: if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( X3 ) ) ) ) goto L3961; scdebug_error( c2219, c2085, CONS( X4, EMPTYLIST ) ); L3961: X2 = VECTOR_ELEMENT( X3, X4 ); if ( AND( EQ( TSCPIMMEDIATETAG( X2 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( X1 ), CHARACTERTAG ) ) ) goto L3964; X3 = CONS( X1, EMPTYLIST ); scdebug_error( c2013, c2014, CONS( X2, X3 ) ); L3964: POPSTACKTRACE( BOOLEAN( EQ( _S2CINT( X2 ), _S2CINT( X1 ) ) ) ); } DEFTSCP( scrt3_char_2dci_3c_3f_v ); DEFCSTRING( t3966, "CHAR-CI?" ); TSCP scrt3_char_2dci_3e_3f( x2287, y2288 ) TSCP x2287, y2288; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3991 ); X2 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( y2288 ), CHARACTERTAG ) ) goto L3994; scdebug_error( c2195, c2196, CONS( y2288, EMPTYLIST ) ); L3994: X3 = CHAR_FIX( y2288 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), VECTORTAG ) ) ) goto L3997; scdebug_error( c2219, c2078, CONS( X2, EMPTYLIST ) ); L3997: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L3999; scdebug_error( c2219, c2081, CONS( X3, EMPTYLIST ) ); L3999: if ( LT( _S2CUINT( FIXED_C( X3 ) ), _S2CUINT( VECTOR_LENGTH( X2 ) ) ) ) goto L4001; scdebug_error( c2219, c2085, CONS( X3, EMPTYLIST ) ); L4001: X1 = VECTOR_ELEMENT( X2, X3 ); X3 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( x2287 ), CHARACTERTAG ) ) goto L4004; scdebug_error( c2195, c2196, CONS( x2287, EMPTYLIST ) ); L4004: X4 = CHAR_FIX( x2287 ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), VECTORTAG ) ) ) goto L4007; scdebug_error( c2219, c2078, CONS( X3, EMPTYLIST ) ); L4007: if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L4009; scdebug_error( c2219, c2081, CONS( X4, EMPTYLIST ) ); L4009: if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( X3 ) ) ) ) goto L4011; scdebug_error( c2219, c2085, CONS( X4, EMPTYLIST ) ); L4011: X2 = VECTOR_ELEMENT( X3, X4 ); if ( AND( EQ( TSCPIMMEDIATETAG( X2 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( X1 ), CHARACTERTAG ) ) ) goto L4014; X3 = CONS( X1, EMPTYLIST ); scdebug_error( c2034, c2014, CONS( X2, X3 ) ); L4014: POPSTACKTRACE( BOOLEAN( GT( _S2CINT( X2 ), _S2CINT( X1 ) ) ) ); } DEFTSCP( scrt3_char_2dci_3c_3d_3f_v ); DEFCSTRING( t4016, "CHAR-CI<=?" ); TSCP scrt3_char_2dci_3c_3d_3f( x2328, y2329 ) TSCP x2328, y2329; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4016 ); X2 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( y2329 ), CHARACTERTAG ) ) goto L4019; scdebug_error( c2195, c2196, CONS( y2329, EMPTYLIST ) ); L4019: X3 = CHAR_FIX( y2329 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), VECTORTAG ) ) ) goto L4022; scdebug_error( c2219, c2078, CONS( X2, EMPTYLIST ) ); L4022: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L4024; scdebug_error( c2219, c2081, CONS( X3, EMPTYLIST ) ); L4024: if ( LT( _S2CUINT( FIXED_C( X3 ) ), _S2CUINT( VECTOR_LENGTH( X2 ) ) ) ) goto L4026; scdebug_error( c2219, c2085, CONS( X3, EMPTYLIST ) ); L4026: X1 = VECTOR_ELEMENT( X2, X3 ); X3 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( x2328 ), CHARACTERTAG ) ) goto L4029; scdebug_error( c2195, c2196, CONS( x2328, EMPTYLIST ) ); L4029: X4 = CHAR_FIX( x2328 ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), VECTORTAG ) ) ) goto L4032; scdebug_error( c2219, c2078, CONS( X3, EMPTYLIST ) ); L4032: if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L4034; scdebug_error( c2219, c2081, CONS( X4, EMPTYLIST ) ); L4034: if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( X3 ) ) ) ) goto L4036; scdebug_error( c2219, c2085, CONS( X4, EMPTYLIST ) ); L4036: X2 = VECTOR_ELEMENT( X3, X4 ); if ( AND( EQ( TSCPIMMEDIATETAG( X2 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( X1 ), CHARACTERTAG ) ) ) goto L4039; X3 = CONS( X1, EMPTYLIST ); scdebug_error( c2336, c2014, CONS( X2, X3 ) ); L4039: POPSTACKTRACE( BOOLEAN( LTE( _S2CINT( X2 ), _S2CINT( X1 ) ) ) ); } DEFTSCP( scrt3_char_2dci_3e_3d_3f_v ); DEFCSTRING( t4041, "CHAR-CI>=?" ); TSCP scrt3_char_2dci_3e_3d_3f( x2370, y2371 ) TSCP x2370, y2371; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4041 ); X2 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( y2371 ), CHARACTERTAG ) ) goto L4044; scdebug_error( c2195, c2196, CONS( y2371, EMPTYLIST ) ); L4044: X3 = CHAR_FIX( y2371 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), VECTORTAG ) ) ) goto L4047; scdebug_error( c2219, c2078, CONS( X2, EMPTYLIST ) ); L4047: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L4049; scdebug_error( c2219, c2081, CONS( X3, EMPTYLIST ) ); L4049: if ( LT( _S2CUINT( FIXED_C( X3 ) ), _S2CUINT( VECTOR_LENGTH( X2 ) ) ) ) goto L4051; scdebug_error( c2219, c2085, CONS( X3, EMPTYLIST ) ); L4051: X1 = VECTOR_ELEMENT( X2, X3 ); X3 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( x2370 ), CHARACTERTAG ) ) goto L4054; scdebug_error( c2195, c2196, CONS( x2370, EMPTYLIST ) ); L4054: X4 = CHAR_FIX( x2370 ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), VECTORTAG ) ) ) goto L4057; scdebug_error( c2219, c2078, CONS( X3, EMPTYLIST ) ); L4057: if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L4059; scdebug_error( c2219, c2081, CONS( X4, EMPTYLIST ) ); L4059: if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( X3 ) ) ) ) goto L4061; scdebug_error( c2219, c2085, CONS( X4, EMPTYLIST ) ); L4061: X2 = VECTOR_ELEMENT( X3, X4 ); if ( AND( EQ( TSCPIMMEDIATETAG( X2 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( X1 ), CHARACTERTAG ) ) ) goto L4064; X3 = CONS( X1, EMPTYLIST ); scdebug_error( c2378, c2014, CONS( X2, X3 ) ); L4064: POPSTACKTRACE( BOOLEAN( GTE( _S2CINT( X2 ), _S2CINT( X1 ) ) ) ); } DEFTSCP( scrt3_char_2dalphabetic_3f_v ); DEFCSTRING( t4066, "CHAR-ALPHABETIC?" ); TSCP scrt3_char_2dalphabetic_3f( x2412 ) TSCP x2412; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4066 ); if ( EQ( TSCPIMMEDIATETAG( x2412 ), CHARACTERTAG ) ) goto L4068; scdebug_error( c2415, c2416, EMPTYLIST ); L4068: if ( AND( EQ( TSCPIMMEDIATETAG( x2412 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 16658 ) ), CHARACTERTAG ) ) ) goto L4071; X3 = CONS( _TSCP( 16658 ), EMPTYLIST ); scdebug_error( c2378, c2014, CONS( x2412, X3 ) ); L4071: X2 = BOOLEAN( GTE( _S2CINT( x2412 ), _S2CINT( _TSCP( 16658 ) ) ) ); if ( FALSE( X2 ) ) goto L4074; if ( AND( EQ( TSCPIMMEDIATETAG( x2412 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 23058 ) ), CHARACTERTAG ) ) ) goto L4077; X3 = CONS( _TSCP( 23058 ), EMPTYLIST ); scdebug_error( c2336, c2014, CONS( x2412, X3 ) ); L4077: X1 = BOOLEAN( LTE( _S2CINT( x2412 ), _S2CINT( _TSCP( 23058 ) ) ) ); goto L4075; L4074: X1 = X2; L4075: if ( TRUE( X1 ) ) goto L4080; if ( AND( EQ( TSCPIMMEDIATETAG( x2412 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 24850 ) ), CHARACTERTAG ) ) ) goto L4083; X3 = CONS( _TSCP( 24850 ), EMPTYLIST ); scdebug_error( c2378, c2014, CONS( x2412, X3 ) ); L4083: X2 = BOOLEAN( GTE( _S2CINT( x2412 ), _S2CINT( _TSCP( 24850 ) ) ) ); if ( FALSE( X2 ) ) goto L4086; if ( AND( EQ( TSCPIMMEDIATETAG( x2412 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 31250 ) ), CHARACTERTAG ) ) ) goto L4089; X3 = CONS( _TSCP( 31250 ), EMPTYLIST ); scdebug_error( c2336, c2014, CONS( x2412, X3 ) ); L4089: POPSTACKTRACE( BOOLEAN( LTE( _S2CINT( x2412 ), _S2CINT( _TSCP( 31250 ) ) ) ) ); L4086: POPSTACKTRACE( X2 ); L4080: POPSTACKTRACE( X1 ); } DEFTSCP( scrt3_char_2dnumeric_3f_v ); DEFCSTRING( t4091, "CHAR-NUMERIC?" ); TSCP scrt3_char_2dnumeric_3f( x2456 ) TSCP x2456; { TSCP X2, X1; PUSHSTACKTRACE( t4091 ); if ( EQ( TSCPIMMEDIATETAG( x2456 ), CHARACTERTAG ) ) goto L4093; scdebug_error( c2459, c2416, EMPTYLIST ); L4093: if ( AND( EQ( TSCPIMMEDIATETAG( x2456 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 12306 ) ), CHARACTERTAG ) ) ) goto L4096; X2 = CONS( _TSCP( 12306 ), EMPTYLIST ); scdebug_error( c2378, c2014, CONS( x2456, X2 ) ); L4096: X1 = BOOLEAN( GTE( _S2CINT( x2456 ), _S2CINT( _TSCP( 12306 ) ) ) ); if ( FALSE( X1 ) ) goto L4099; if ( AND( EQ( TSCPIMMEDIATETAG( x2456 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 14610 ) ), CHARACTERTAG ) ) ) goto L4102; X2 = CONS( _TSCP( 14610 ), EMPTYLIST ); scdebug_error( c2336, c2014, CONS( x2456, X2 ) ); L4102: POPSTACKTRACE( BOOLEAN( LTE( _S2CINT( x2456 ), _S2CINT( _TSCP( 14610 ) ) ) ) ); L4099: POPSTACKTRACE( X1 ); } DEFTSCP( scrt3_char_2dwhitespace_3f_v ); DEFCSTRING( t4104, "CHAR-WHITESPACE?" ); EXTERNTSCPP( scrt2__3e_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_3d_2dtwo_v ); EXTERNTSCPP( scrt2__3c_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_3d_2dtwo_v ); TSCP scrt3_char_2dwhitespace_3f( x2479 ) TSCP x2479; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4104 ); x2479 = CONS( x2479, EMPTYLIST ); if ( EQ( TSCPIMMEDIATETAG( PAIR_CAR( x2479 ) ), CHARACTERTAG ) ) goto L4106; scdebug_error( c2482, c2416, EMPTYLIST ); L4106: X2 = PAIR_CAR( x2479 ); if ( EQ( TSCPIMMEDIATETAG( X2 ), CHARACTERTAG ) ) goto L4109; scdebug_error( c2195, c2196, CONS( X2, EMPTYLIST ) ); L4109: X1 = CHAR_FIX( X2 ); SETGEN( PAIR_CAR( x2479 ), X1 ); X3 = PAIR_CAR( x2479 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 36 ) ) ), 3 ) ) goto L4112; X2 = BOOLEAN( GTE( _S2CINT( X3 ), _S2CINT( _TSCP( 36 ) ) ) ); goto L4113; L4112: X2 = scrt2__3e_3d_2dtwo( X3, _TSCP( 36 ) ); L4113: if ( FALSE( X2 ) ) goto L4115; X3 = PAIR_CAR( x2479 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 52 ) ) ), 3 ) ) goto L4118; X1 = BOOLEAN( LTE( _S2CINT( X3 ), _S2CINT( _TSCP( 52 ) ) ) ); goto L4116; L4118: X1 = scrt2__3c_3d_2dtwo( X3, _TSCP( 52 ) ); goto L4116; L4115: X1 = X2; L4116: if ( TRUE( X1 ) ) goto L4121; X2 = PAIR_CAR( x2479 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 128 ) ) ), 3 ) ) goto L4124; POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 128 ) ) ) ) ); L4124: POPSTACKTRACE( scrt2__3d_2dtwo( X2, _TSCP( 128 ) ) ); L4121: POPSTACKTRACE( X1 ); } DEFTSCP( scrt3_char_2dupper_2dcase_3f_v ); DEFCSTRING( t4126, "CHAR-UPPER-CASE?" ); TSCP scrt3_char_2dupper_2dcase_3f( l2520 ) TSCP l2520; { TSCP X2, X1; PUSHSTACKTRACE( t4126 ); if ( EQ( TSCPIMMEDIATETAG( l2520 ), CHARACTERTAG ) ) goto L4128; scdebug_error( c2523, c2416, EMPTYLIST ); L4128: if ( AND( EQ( TSCPIMMEDIATETAG( l2520 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 16658 ) ), CHARACTERTAG ) ) ) goto L4131; X2 = CONS( _TSCP( 16658 ), EMPTYLIST ); scdebug_error( c2378, c2014, CONS( l2520, X2 ) ); L4131: X1 = BOOLEAN( GTE( _S2CINT( l2520 ), _S2CINT( _TSCP( 16658 ) ) ) ); if ( FALSE( X1 ) ) goto L4134; if ( AND( EQ( TSCPIMMEDIATETAG( l2520 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 23058 ) ), CHARACTERTAG ) ) ) goto L4137; X2 = CONS( _TSCP( 23058 ), EMPTYLIST ); scdebug_error( c2336, c2014, CONS( l2520, X2 ) ); L4137: POPSTACKTRACE( BOOLEAN( LTE( _S2CINT( l2520 ), _S2CINT( _TSCP( 23058 ) ) ) ) ); L4134: POPSTACKTRACE( X1 ); } DEFTSCP( scrt3_char_2dlower_2dcase_3f_v ); DEFCSTRING( t4139, "CHAR-LOWER-CASE?" ); TSCP scrt3_char_2dlower_2dcase_3f( l2541 ) TSCP l2541; { TSCP X2, X1; PUSHSTACKTRACE( t4139 ); if ( EQ( TSCPIMMEDIATETAG( l2541 ), CHARACTERTAG ) ) goto L4141; scdebug_error( c2544, c2416, EMPTYLIST ); L4141: if ( AND( EQ( TSCPIMMEDIATETAG( l2541 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 24850 ) ), CHARACTERTAG ) ) ) goto L4144; X2 = CONS( _TSCP( 24850 ), EMPTYLIST ); scdebug_error( c2378, c2014, CONS( l2541, X2 ) ); L4144: X1 = BOOLEAN( GTE( _S2CINT( l2541 ), _S2CINT( _TSCP( 24850 ) ) ) ); if ( FALSE( X1 ) ) goto L4147; if ( AND( EQ( TSCPIMMEDIATETAG( l2541 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 31250 ) ), CHARACTERTAG ) ) ) goto L4150; X2 = CONS( _TSCP( 31250 ), EMPTYLIST ); scdebug_error( c2336, c2014, CONS( l2541, X2 ) ); L4150: POPSTACKTRACE( BOOLEAN( LTE( _S2CINT( l2541 ), _S2CINT( _TSCP( 31250 ) ) ) ) ); L4147: POPSTACKTRACE( X1 ); } DEFTSCP( scrt3_char_2dupcase_v ); DEFCSTRING( t4152, "CHAR-UPCASE" ); TSCP scrt3_char_2dupcase( x2562 ) TSCP x2562; { TSCP X2, X1; PUSHSTACKTRACE( t4152 ); if ( EQ( TSCPIMMEDIATETAG( x2562 ), CHARACTERTAG ) ) goto L4154; scdebug_error( c2565, c2416, EMPTYLIST ); L4154: X1 = scrt3_char_2dupcase_2dtable_v; X2 = CHAR_FIX( x2562 ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L4158; scdebug_error( c2219, c2078, CONS( X1, EMPTYLIST ) ); L4158: if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L4160; scdebug_error( c2219, c2081, CONS( X2, EMPTYLIST ) ); L4160: if ( LT( _S2CUINT( FIXED_C( X2 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L4162; scdebug_error( c2219, c2085, CONS( X2, EMPTYLIST ) ); L4162: POPSTACKTRACE( VECTOR_ELEMENT( X1, X2 ) ); } DEFTSCP( scrt3_char_2ddowncase_v ); DEFCSTRING( t4164, "CHAR-DOWNCASE" ); TSCP scrt3_char_2ddowncase( x2583 ) TSCP x2583; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4164 ); if ( EQ( TSCPIMMEDIATETAG( x2583 ), CHARACTERTAG ) ) goto L4166; scdebug_error( c2586, c2416, EMPTYLIST ); L4166: if ( FALSE( scrt3_char_2dalphabetic_3f( x2583 ) ) ) goto L4168; if ( FALSE( scrt3_char_2dupper_2dcase_3f( x2583 ) ) ) goto L4170; X2 = CHAR_FIX( x2583 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 128 ) ) ), 3 ) ) goto L4174; X1 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 128 ) ) ) ); goto L4175; L4174: X1 = scrt2__2b_2dtwo( X2, _TSCP( 128 ) ); L4175: X2 = BOOLEAN( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ); if ( TRUE( X2 ) ) goto L4181; if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4182; X3 = BOOLEAN( LT( _S2CINT( X1 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4183; L4182: X3 = scrt2__3c_2dtwo( X1, _TSCP( 0 ) ); L4183: if ( TRUE( X3 ) ) goto L4181; if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4190; if ( GT( _S2CINT( X1 ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4181; goto L4197; L4190: if ( FALSE( scrt2__3e_2dtwo( X1, _TSCP( 1020 ) ) ) ) goto L4197; L4181: scdebug_error( c2112, c2113, CONS( X1, EMPTYLIST ) ); L4197: POPSTACKTRACE( FIX_CHAR( X1 ) ); L4170: POPSTACKTRACE( x2583 ); L4168: POPSTACKTRACE( x2583 ); } DEFTSCP( scrt3_char_2d_3einteger_v ); DEFCSTRING( t4198, "CHAR->INTEGER" ); TSCP scrt3_char_2d_3einteger( x2626 ) TSCP x2626; { PUSHSTACKTRACE( t4198 ); if ( EQ( TSCPIMMEDIATETAG( x2626 ), CHARACTERTAG ) ) goto L4201; scdebug_error( c2195, c2196, CONS( x2626, EMPTYLIST ) ); L4201: POPSTACKTRACE( CHAR_FIX( x2626 ) ); } DEFTSCP( scrt3_integer_2d_3echar_v ); DEFCSTRING( t4203, "INTEGER->CHAR" ); TSCP scrt3_integer_2d_3echar( x2632 ) TSCP x2632; { TSCP X2, X1; PUSHSTACKTRACE( t4203 ); X1 = BOOLEAN( NEQ( TSCPTAG( x2632 ), FIXNUMTAG ) ); if ( TRUE( X1 ) ) goto L4210; if ( BITAND( BITOR( _S2CINT( x2632 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4211; X2 = BOOLEAN( LT( _S2CINT( x2632 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4212; L4211: X2 = scrt2__3c_2dtwo( x2632, _TSCP( 0 ) ); L4212: if ( TRUE( X2 ) ) goto L4210; if ( BITAND( BITOR( _S2CINT( x2632 ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4219; if ( GT( _S2CINT( x2632 ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4210; goto L4226; L4219: if ( FALSE( scrt2__3e_2dtwo( x2632, _TSCP( 1020 ) ) ) ) goto L4226; L4210: scdebug_error( c2112, c2113, CONS( x2632, EMPTYLIST ) ); L4226: POPSTACKTRACE( FIX_CHAR( x2632 ) ); } DEFTSCP( scrt3_string_3f_v ); DEFCSTRING( t4227, "STRING?" ); TSCP scrt3_string_3f( x2658 ) TSCP x2658; { PUSHSTACKTRACE( t4227 ); POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2658 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2658 ), STRINGTAG ) ) ) ); } DEFTSCP( scrt3_string_v ); DEFCSTRING( t4229, "STRING" ); EXTERNTSCPP( scrt3_list_2d_3estring, XAL1( TSCP ) ); EXTERNTSCP( scrt3_list_2d_3estring_v ); TSCP scrt3_string( x2662 ) TSCP x2662; { PUSHSTACKTRACE( t4229 ); POPSTACKTRACE( scrt3_list_2d_3estring( x2662 ) ); } DEFTSCP( scrt3_string_2dlength_v ); DEFCSTRING( t4231, "STRING-LENGTH" ); TSCP scrt3_string_2dlength( x2664 ) TSCP x2664; { PUSHSTACKTRACE( t4231 ); if ( AND( EQ( TSCPTAG( x2664 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2664 ), STRINGTAG ) ) ) goto L4234; scdebug_error( c2669, c2670, CONS( x2664, EMPTYLIST ) ); L4234: POPSTACKTRACE( C_FIXED( STRING_LENGTH( x2664 ) ) ); } DEFTSCP( scrt3_string_2dref_v ); DEFCSTRING( t4236, "STRING-REF" ); TSCP scrt3_string_2dref( x2672, y2673 ) TSCP x2672, y2673; { TSCP X2, X1; PUSHSTACKTRACE( t4236 ); if ( EQ( TSCPTAG( y2673 ), FIXNUMTAG ) ) goto L4239; scdebug_error( c2679, c2081, CONS( y2673, EMPTYLIST ) ); L4239: X1 = BOOLEAN( LT( _S2CINT( y2673 ), 0 ) ); if ( TRUE( X1 ) ) goto L4245; if ( AND( EQ( TSCPTAG( x2672 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2672 ), STRINGTAG ) ) ) goto L4247; scdebug_error( c2669, c2670, CONS( x2672, EMPTYLIST ) ); L4247: X2 = C_FIXED( STRING_LENGTH( x2672 ) ); if ( BITAND( BITOR( _S2CINT( y2673 ), _S2CINT( X2 ) ), 3 ) ) goto L4251; if ( GTE( _S2CINT( y2673 ), _S2CINT( X2 ) ) ) goto L4245; goto L4258; L4251: if ( FALSE( scrt2__3e_3d_2dtwo( y2673, X2 ) ) ) goto L4258; L4245: scdebug_error( c2679, c2700, CONS( y2673, EMPTYLIST ) ); L4258: POPSTACKTRACE( C_CHAR( STRING_CHAR( x2672, y2673 ) ) ); } DEFTSCP( scrt3_string_2dset_21_v ); DEFCSTRING( t4259, "STRING-SET!" ); TSCP scrt3_string_2dset_21( x2702, y2703, z2704 ) TSCP x2702, y2703, z2704; { TSCP X2, X1; PUSHSTACKTRACE( t4259 ); if ( EQ( TSCPTAG( y2703 ), FIXNUMTAG ) ) goto L4262; scdebug_error( c2711, c2081, CONS( y2703, EMPTYLIST ) ); L4262: if ( EQ( TSCPIMMEDIATETAG( z2704 ), CHARACTERTAG ) ) goto L4264; scdebug_error( c2711, c2714, CONS( z2704, EMPTYLIST ) ); L4264: X1 = BOOLEAN( LT( _S2CINT( y2703 ), 0 ) ); if ( TRUE( X1 ) ) goto L4270; if ( AND( EQ( TSCPTAG( x2702 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2702 ), STRINGTAG ) ) ) goto L4272; scdebug_error( c2669, c2670, CONS( x2702, EMPTYLIST ) ); L4272: X2 = C_FIXED( STRING_LENGTH( x2702 ) ); if ( BITAND( BITOR( _S2CINT( y2703 ), _S2CINT( X2 ) ), 3 ) ) goto L4276; if ( GTE( _S2CINT( y2703 ), _S2CINT( X2 ) ) ) goto L4270; goto L4283; L4276: if ( FALSE( scrt2__3e_3d_2dtwo( y2703, X2 ) ) ) goto L4283; L4270: scdebug_error( c2711, c2735, EMPTYLIST ); L4283: STRING_CHAR( x2702, y2703 ) = CHAR_C( z2704 ); POPSTACKTRACE( z2704 ); } DEFTSCP( scrt3_string_3d_3f_v ); DEFCSTRING( t4284, "STRING=?" ); TSCP scrt3_string_3d_3f( x2737, y2738 ) TSCP x2737, y2738; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4284 ); X3 = BOOLEAN( NOT( AND( EQ( TSCPTAG( x2737 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2737 ), STRINGTAG ) ) ) ); if ( TRUE( X3 ) ) goto L4290; if ( AND( EQ( TSCPTAG( y2738 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2738 ), STRINGTAG ) ) ) goto L4293; L4290: scdebug_error( c2747, c2748, EMPTYLIST ); L4293: X3 = C_FIXED( STRING_LENGTH( y2738 ) ); X1 = C_FIXED( STRING_LENGTH( x2737 ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X3 ) ), 3 ) ) goto L4296; if ( EQ( _S2CUINT( X1 ), _S2CUINT( X3 ) ) ) goto L4300; POPSTACKTRACE( FALSEVALUE ); L4296: if ( TRUE( scrt2__3d_2dtwo( X1, X3 ) ) ) goto L4300; POPSTACKTRACE( FALSEVALUE ); L4300: X2 = _TSCP( 0 ); L4304: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X1 ) ), 3 ) ) goto L4305; X3 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( X1 ) ) ); goto L4306; L4305: X3 = scrt2__3d_2dtwo( X2, X1 ); L4306: if ( TRUE( X3 ) ) goto L4311; X4 = C_CHAR( STRING_CHAR( x2737, X2 ) ); X5 = C_CHAR( STRING_CHAR( y2738, X2 ) ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( X5 ) ) ) goto L4311; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4314; X2 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L4304 ); L4314: X2 = scrt2__2b_2dtwo( X2, _TSCP( 4 ) ); GOBACK( L4304 ); L4311: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X1 ) ), 3 ) ) goto L4316; POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( X1 ) ) ) ); L4316: POPSTACKTRACE( scrt2__3d_2dtwo( X2, X1 ) ); } DEFTSCP( scrt3_string_3c_3f_v ); DEFCSTRING( t4318, "STRING?" ); TSCP scrt3_string_3e_3f( x2880, y2881 ) TSCP x2880, y2881; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4356 ); X1 = BOOLEAN( NOT( AND( EQ( TSCPTAG( x2880 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2880 ), STRINGTAG ) ) ) ); if ( TRUE( X1 ) ) goto L4362; if ( AND( EQ( TSCPTAG( y2881 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2881 ), STRINGTAG ) ) ) goto L4365; L4362: scdebug_error( c2890, c2748, EMPTYLIST ); L4365: X1 = C_FIXED( STRING_LENGTH( x2880 ) ); X2 = C_FIXED( STRING_LENGTH( y2881 ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X2 ) ), 3 ) ) goto L4368; if ( GTE( _S2CINT( X1 ), _S2CINT( X2 ) ) ) goto L4370; X3 = X1; goto L4369; L4370: X3 = X2; goto L4369; L4368: X3 = scrt2_min_2dtwo( X1, X2 ); L4369: X4 = _TSCP( 0 ); L4374: if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( X3 ) ), 3 ) ) goto L4376; if ( EQ( _S2CUINT( X4 ), _S2CUINT( X3 ) ) ) goto L4380; goto L4381; L4376: if ( TRUE( scrt2__3d_2dtwo( X4, X3 ) ) ) goto L4380; L4381: X5 = C_CHAR( STRING_CHAR( y2881, X4 ) ); X6 = C_CHAR( STRING_CHAR( x2880, X4 ) ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( X5 ) ) ) goto L4385; if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4387; X4 = _TSCP( IPLUS( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L4374 ); L4387: X4 = scrt2__2b_2dtwo( X4, _TSCP( 4 ) ); GOBACK( L4374 ); L4385: if ( AND( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( X5 ), CHARACTERTAG ) ) ) goto L4390; X7 = CONS( X5, EMPTYLIST ); scdebug_error( c2034, c2014, CONS( X6, X7 ) ); L4390: POPSTACKTRACE( BOOLEAN( GT( _S2CINT( X6 ), _S2CINT( X5 ) ) ) ); L4380: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X2 ) ), 3 ) ) goto L4392; POPSTACKTRACE( BOOLEAN( GT( _S2CINT( X1 ), _S2CINT( X2 ) ) ) ); L4392: POPSTACKTRACE( scrt2__3e_2dtwo( X1, X2 ) ); } DEFTSCP( scrt3_string_3c_3d_3f_v ); DEFCSTRING( t4394, "STRING<=?" ); TSCP scrt3_string_3c_3d_3f( x2953, y2954 ) TSCP x2953, y2954; { PUSHSTACKTRACE( t4394 ); if ( TRUE( scrt3_string_3e_3f( x2953, y2954 ) ) ) goto L4396; POPSTACKTRACE( TRUEVALUE ); L4396: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt3_string_3e_3d_3f_v ); DEFCSTRING( t4398, "STRING>=?" ); TSCP scrt3_string_3e_3d_3f( x2956, y2957 ) TSCP x2956, y2957; { PUSHSTACKTRACE( t4398 ); if ( TRUE( scrt3_string_3c_3f( x2956, y2957 ) ) ) goto L4400; POPSTACKTRACE( TRUEVALUE ); L4400: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt3_string_2dci_3d_3f_v ); DEFCSTRING( t4402, "STRING-CI=?" ); TSCP scrt3_string_2dci_3d_3f( x2959, y2960 ) TSCP x2959, y2960; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4402 ); X3 = BOOLEAN( NOT( AND( EQ( TSCPTAG( x2959 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2959 ), STRINGTAG ) ) ) ); if ( TRUE( X3 ) ) goto L4408; if ( AND( EQ( TSCPTAG( y2960 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y2960 ), STRINGTAG ) ) ) goto L4411; L4408: scdebug_error( c2969, c2748, EMPTYLIST ); L4411: X3 = C_FIXED( STRING_LENGTH( y2960 ) ); X1 = C_FIXED( STRING_LENGTH( x2959 ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X3 ) ), 3 ) ) goto L4414; if ( EQ( _S2CUINT( X1 ), _S2CUINT( X3 ) ) ) goto L4418; POPSTACKTRACE( FALSEVALUE ); L4414: if ( TRUE( scrt2__3d_2dtwo( X1, X3 ) ) ) goto L4418; POPSTACKTRACE( FALSEVALUE ); L4418: X2 = _TSCP( 0 ); L4422: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X1 ) ), 3 ) ) goto L4423; X3 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( X1 ) ) ); goto L4424; L4423: X3 = scrt2__3d_2dtwo( X2, X1 ); L4424: if ( TRUE( X3 ) ) goto L4429; X5 = C_CHAR( STRING_CHAR( x2959, X2 ) ); X6 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( X5 ), CHARACTERTAG ) ) goto L4434; scdebug_error( c2195, c2196, CONS( X5, EMPTYLIST ) ); L4434: X7 = CHAR_FIX( X5 ); if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), VECTORTAG ) ) ) goto L4437; scdebug_error( c2219, c2078, CONS( X6, EMPTYLIST ) ); L4437: if ( EQ( TSCPTAG( X7 ), FIXNUMTAG ) ) goto L4439; scdebug_error( c2219, c2081, CONS( X7, EMPTYLIST ) ); L4439: if ( LT( _S2CUINT( FIXED_C( X7 ) ), _S2CUINT( VECTOR_LENGTH( X6 ) ) ) ) goto L4441; scdebug_error( c2219, c2085, CONS( X7, EMPTYLIST ) ); L4441: X4 = VECTOR_ELEMENT( X6, X7 ); X6 = C_CHAR( STRING_CHAR( y2960, X2 ) ); X7 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ) ) goto L4445; scdebug_error( c2195, c2196, CONS( X6, EMPTYLIST ) ); L4445: X8 = CHAR_FIX( X6 ); if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), VECTORTAG ) ) ) goto L4448; scdebug_error( c2219, c2078, CONS( X7, EMPTYLIST ) ); L4448: if ( EQ( TSCPTAG( X8 ), FIXNUMTAG ) ) goto L4450; scdebug_error( c2219, c2081, CONS( X8, EMPTYLIST ) ); L4450: if ( LT( _S2CUINT( FIXED_C( X8 ) ), _S2CUINT( VECTOR_LENGTH( X7 ) ) ) ) goto L4452; scdebug_error( c2219, c2085, CONS( X8, EMPTYLIST ) ); L4452: X5 = VECTOR_ELEMENT( X7, X8 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( X5 ) ) ) goto L4429; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4454; X2 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L4422 ); L4454: X2 = scrt2__2b_2dtwo( X2, _TSCP( 4 ) ); GOBACK( L4422 ); L4429: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X1 ) ), 3 ) ) goto L4456; POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( X1 ) ) ) ); L4456: POPSTACKTRACE( scrt2__3d_2dtwo( X2, X1 ) ); } DEFTSCP( scrt3_string_2dci_3c_3f_v ); DEFCSTRING( t4458, "STRING-CI?" ); TSCP scrt3_string_2dci_3e_3f( x3165, y3166 ) TSCP x3165, y3166; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4518 ); X1 = BOOLEAN( NOT( AND( EQ( TSCPTAG( x3165 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3165 ), STRINGTAG ) ) ) ); if ( TRUE( X1 ) ) goto L4524; if ( AND( EQ( TSCPTAG( y3166 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( y3166 ), STRINGTAG ) ) ) goto L4527; L4524: scdebug_error( c3175, c2748, EMPTYLIST ); L4527: X1 = C_FIXED( STRING_LENGTH( x3165 ) ); X2 = C_FIXED( STRING_LENGTH( y3166 ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X2 ) ), 3 ) ) goto L4530; if ( GTE( _S2CINT( X1 ), _S2CINT( X2 ) ) ) goto L4532; X3 = X1; goto L4531; L4532: X3 = X2; goto L4531; L4530: X3 = scrt2_min_2dtwo( X1, X2 ); L4531: X4 = _TSCP( 0 ); L4536: if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( X3 ) ), 3 ) ) goto L4538; if ( EQ( _S2CUINT( X4 ), _S2CUINT( X3 ) ) ) goto L4542; goto L4543; L4538: if ( TRUE( scrt2__3d_2dtwo( X4, X3 ) ) ) goto L4542; L4543: X6 = C_CHAR( STRING_CHAR( y3166, X4 ) ); X7 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ) ) goto L4548; scdebug_error( c2195, c2196, CONS( X6, EMPTYLIST ) ); L4548: X8 = CHAR_FIX( X6 ); if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), VECTORTAG ) ) ) goto L4551; scdebug_error( c2219, c2078, CONS( X7, EMPTYLIST ) ); L4551: if ( EQ( TSCPTAG( X8 ), FIXNUMTAG ) ) goto L4553; scdebug_error( c2219, c2081, CONS( X8, EMPTYLIST ) ); L4553: if ( LT( _S2CUINT( FIXED_C( X8 ) ), _S2CUINT( VECTOR_LENGTH( X7 ) ) ) ) goto L4555; scdebug_error( c2219, c2085, CONS( X8, EMPTYLIST ) ); L4555: X5 = VECTOR_ELEMENT( X7, X8 ); X7 = C_CHAR( STRING_CHAR( x3165, X4 ) ); X8 = scrt3_char_2dupcase_2dtable_v; if ( EQ( TSCPIMMEDIATETAG( X7 ), CHARACTERTAG ) ) goto L4559; scdebug_error( c2195, c2196, CONS( X7, EMPTYLIST ) ); L4559: X9 = CHAR_FIX( X7 ); if ( AND( EQ( TSCPTAG( X8 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X8 ), VECTORTAG ) ) ) goto L4562; scdebug_error( c2219, c2078, CONS( X8, EMPTYLIST ) ); L4562: if ( EQ( TSCPTAG( X9 ), FIXNUMTAG ) ) goto L4564; scdebug_error( c2219, c2081, CONS( X9, EMPTYLIST ) ); L4564: if ( LT( _S2CUINT( FIXED_C( X9 ) ), _S2CUINT( VECTOR_LENGTH( X8 ) ) ) ) goto L4566; scdebug_error( c2219, c2085, CONS( X9, EMPTYLIST ) ); L4566: X6 = VECTOR_ELEMENT( X8, X9 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( X5 ) ) ) goto L4569; if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4571; X4 = _TSCP( IPLUS( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L4536 ); L4571: X4 = scrt2__2b_2dtwo( X4, _TSCP( 4 ) ); GOBACK( L4536 ); L4569: if ( AND( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( X5 ), CHARACTERTAG ) ) ) goto L4574; X7 = CONS( X5, EMPTYLIST ); scdebug_error( c2034, c2014, CONS( X6, X7 ) ); L4574: POPSTACKTRACE( BOOLEAN( GT( _S2CINT( X6 ), _S2CINT( X5 ) ) ) ); L4542: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X2 ) ), 3 ) ) goto L4576; POPSTACKTRACE( BOOLEAN( GT( _S2CINT( X1 ), _S2CINT( X2 ) ) ) ); L4576: POPSTACKTRACE( scrt2__3e_2dtwo( X1, X2 ) ); } DEFTSCP( scrt3_string_2dci_3c_3d_3f_v ); DEFCSTRING( t4578, "STRING-CI<=?" ); TSCP scrt3_string_2dci_3c_3d_3f( x3270, y3271 ) TSCP x3270, y3271; { PUSHSTACKTRACE( t4578 ); if ( TRUE( scrt3_string_2dci_3e_3f( x3270, y3271 ) ) ) goto L4580; POPSTACKTRACE( TRUEVALUE ); L4580: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt3_string_2dci_3e_3d_3f_v ); DEFCSTRING( t4582, "STRING-CI>=?" ); TSCP scrt3_string_2dci_3e_3d_3f( x3273, y3274 ) TSCP x3273, y3274; { PUSHSTACKTRACE( t4582 ); if ( TRUE( scrt3_string_2dci_3c_3f( x3273, y3274 ) ) ) goto L4584; POPSTACKTRACE( TRUEVALUE ); L4584: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt3_substring_v ); DEFCSTRING( t4586, "SUBSTRING" ); EXTERNTSCPP( scrt2_negative_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_negative_3f_v ); EXTERNTSCPP( sc_make_2dstring, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dstring_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); TSCP scrt3_substring( x3276, y3277, z3278 ) TSCP x3276, y3277, z3278; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4586 ); if ( AND( EQ( TSCPTAG( x3276 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3276 ), STRINGTAG ) ) ) goto L4588; scdebug_error( c3281, c3282, EMPTYLIST ); L4588: X1 = BOOLEAN( NEQ( TSCPTAG( y3277 ), FIXNUMTAG ) ); if ( TRUE( X1 ) ) goto L4594; if ( NEQ( TSCPTAG( y3277 ), FIXNUMTAG ) ) goto L4595; X2 = BOOLEAN( LT( _S2CINT( y3277 ), 0 ) ); goto L4596; L4595: X2 = scrt2_negative_3f( y3277 ); L4596: if ( TRUE( X2 ) ) goto L4594; if ( NEQ( TSCPTAG( z3278 ), FIXNUMTAG ) ) goto L4594; if ( BITAND( BITOR( _S2CINT( z3278 ), _S2CINT( y3277 ) ), 3 ) ) goto L4606; X3 = BOOLEAN( LT( _S2CINT( z3278 ), _S2CINT( y3277 ) ) ); goto L4607; L4606: X3 = scrt2__3c_2dtwo( z3278, y3277 ); L4607: if ( TRUE( X3 ) ) goto L4594; X4 = C_FIXED( STRING_LENGTH( x3276 ) ); if ( BITAND( BITOR( _S2CINT( z3278 ), _S2CINT( X4 ) ), 3 ) ) goto L4615; if ( GT( _S2CINT( z3278 ), _S2CINT( X4 ) ) ) goto L4594; goto L4622; L4615: if ( FALSE( scrt2__3e_2dtwo( z3278, X4 ) ) ) goto L4622; L4594: scdebug_error( c3281, c3323, EMPTYLIST ); L4622: X1 = y3277; X2 = _TSCP( 0 ); if ( BITAND( BITOR( _S2CINT( z3278 ), _S2CINT( y3277 ) ), 3 ) ) goto L4624; X4 = _TSCP( IDIFFERENCE( _S2CINT( z3278 ), _S2CINT( y3277 ) ) ); goto L4625; L4624: X4 = scrt2__2d_2dtwo( z3278, y3277 ); L4625: X3 = sc_make_2dstring( X4, EMPTYLIST ); L4626: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( z3278 ) ), 3 ) ) goto L4628; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( z3278 ) ) ) goto L4632; POPSTACKTRACE( X3 ); L4628: if ( FALSE( scrt2__3d_2dtwo( X1, z3278 ) ) ) goto L4632; POPSTACKTRACE( X3 ); L4632: X4 = C_CHAR( STRING_CHAR( x3276, X1 ) ); STRING_CHAR( X3, X2 ) = CHAR_C( X4 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4636; X4 = _TSCP( IPLUS( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4637; L4636: X4 = scrt2__2b_2dtwo( X1, _TSCP( 4 ) ); L4637: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4638; X5 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4639; L4638: X5 = scrt2__2b_2dtwo( X2, _TSCP( 4 ) ); L4639: X2 = X5; X1 = X4; GOBACK( L4626 ); } DEFTSCP( scrt3_string_2dappend_v ); DEFCSTRING( t4640, "STRING-APPEND" ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); TSCP scrt3_string_2dappend( x3366 ) TSCP x3366; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4640 ); X2 = x3366; X3 = _TSCP( 0 ); L4644: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4645; X1 = sc_make_2dstring( X3, EMPTYLIST ); goto L4648; L4645: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4650; scrt1__24__car_2derror( X2 ); L4650: X4 = PAIR_CAR( X2 ); if ( NOT( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), STRINGTAG ) ) ) ) goto L4647; X4 = PAIR_CDR( X2 ); X6 = PAIR_CAR( X2 ); X5 = C_FIXED( STRING_LENGTH( X6 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X5 ) ), 3 ) ) goto L4655; X3 = _TSCP( IPLUS( _S2CINT( X3 ), _S2CINT( X5 ) ) ); goto L4656; L4655: X3 = scrt2__2b_2dtwo( X3, X5 ); L4656: X2 = X4; GOBACK( L4644 ); L4647: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4658; scrt1__24__car_2derror( X2 ); L4658: X1 = scdebug_error( c3459, c2670, CONS( PAIR_CAR( X2 ), EMPTYLIST ) ); L4648: X2 = _TSCP( 0 ); X3 = x3366; L4660: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L4661; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4666; scrt1__24__car_2derror( X3 ); L4666: X4 = PAIR_CAR( X3 ); X7 = PAIR_CAR( X3 ); X6 = C_FIXED( STRING_LENGTH( X7 ) ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4670; X5 = _TSCP( IDIFFERENCE( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4671; L4670: X5 = scrt2__2d_2dtwo( X6, _TSCP( 4 ) ); L4671: if ( EQ( _S2CUINT( X5 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L4673; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X5 ) ), 3 ) ) goto L4676; X6 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( X5 ) ) ); goto L4677; L4676: X6 = scrt2__2b_2dtwo( X2, X5 ); L4677: X7 = C_CHAR( STRING_CHAR( X4, X5 ) ); STRING_CHAR( X1, X6 ) = CHAR_C( X7 ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4678; X5 = _TSCP( IDIFFERENCE( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L4671 ); L4678: X5 = scrt2__2d_2dtwo( X5, _TSCP( 4 ) ); GOBACK( L4671 ); L4673: X6 = PAIR_CAR( X3 ); X5 = C_FIXED( STRING_LENGTH( X6 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X5 ) ), 3 ) ) goto L4682; X4 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( X5 ) ) ); goto L4683; L4682: X4 = scrt2__2b_2dtwo( X2, X5 ); L4683: X3 = PAIR_CDR( X3 ); X2 = X4; GOBACK( L4660 ); L4661: POPSTACKTRACE( X1 ); } DEFTSCP( scrt3_string_2d_3elist_v ); DEFCSTRING( t4685, "STRING->LIST" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP scrt3_string_2d_3elist( x3481 ) TSCP x3481; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4685 ); if ( AND( EQ( TSCPTAG( x3481 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3481 ), STRINGTAG ) ) ) goto L4687; scdebug_error( c3484, c2670, CONS( x3481, EMPTYLIST ) ); L4687: X2 = C_FIXED( STRING_LENGTH( x3481 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4691; X1 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4692; L4691: X1 = scrt2__2d_2dtwo( X2, _TSCP( 4 ) ); L4692: X2 = EMPTYLIST; L4693: X2 = CONS( X2, EMPTYLIST ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( -4 ) ) ), 3 ) ) goto L4695; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L4699; POPSTACKTRACE( PAIR_CAR( X2 ) ); L4695: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( -4 ) ) ) ) goto L4699; POPSTACKTRACE( PAIR_CAR( X2 ) ); L4699: X4 = C_CHAR( STRING_CHAR( x3481, X1 ) ); X3 = sc_cons( X4, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X3 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4703; X3 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4704; L4703: X3 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); L4704: X2 = PAIR_CAR( X2 ); X1 = X3; GOBACK( L4693 ); } DEFTSCP( scrt3_list_2d_3estring_v ); DEFCSTRING( t4705, "LIST->STRING" ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); TSCP scrt3_list_2d_3estring( x3518 ) TSCP x3518; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4705 ); X1 = _TSCP( 0 ); X2 = x3518; X4 = scrt1_length( x3518 ); X3 = sc_make_2dstring( X4, EMPTYLIST ); L4708: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4709; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4713; scrt1__24__car_2derror( X2 ); L4713: X4 = PAIR_CAR( X2 ); if ( EQ( TSCPIMMEDIATETAG( X4 ), CHARACTERTAG ) ) goto L4716; scdebug_error( c3535, c3536, CONS( x3518, EMPTYLIST ) ); L4716: STRING_CHAR( X3, X1 ) = CHAR_C( X4 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4718; X4 = _TSCP( IPLUS( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4719; L4718: X4 = scrt2__2b_2dtwo( X1, _TSCP( 4 ) ); L4719: X5 = PAIR_CDR( X2 ); X2 = X5; X1 = X4; GOBACK( L4708 ); L4709: POPSTACKTRACE( X3 ); } DEFTSCP( scrt3_string_2dfill_21_v ); DEFCSTRING( t4721, "STRING-FILL!" ); TSCP scrt3_string_2dfill_21( s3556, c3557 ) TSCP s3556, c3557; { TSCP X2, X1; PUSHSTACKTRACE( t4721 ); if ( AND( EQ( TSCPTAG( s3556 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( s3556 ), STRINGTAG ) ) ) goto L4723; scdebug_error( c3560, c2670, CONS( s3556, EMPTYLIST ) ); L4723: if ( EQ( TSCPIMMEDIATETAG( c3557 ), CHARACTERTAG ) ) goto L4725; scdebug_error( c3560, c2714, CONS( c3557, EMPTYLIST ) ); L4725: X2 = C_FIXED( STRING_LENGTH( s3556 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4729; X1 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4730; L4729: X1 = scrt2__2d_2dtwo( X2, _TSCP( 4 ) ); L4730: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( -4 ) ) ), 3 ) ) goto L4733; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L4737; POPSTACKTRACE( s3556 ); L4733: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( -4 ) ) ) ) goto L4737; POPSTACKTRACE( s3556 ); L4737: STRING_CHAR( s3556, X1 ) = CHAR_C( c3557 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4741; X1 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L4730 ); L4741: X1 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); GOBACK( L4730 ); } void scrt1__init(); void scrt2__init(); void scdebug__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt1__init(); scrt2__init(); scdebug__init(); MAXDISPLAY( 0 ); } void scrt3__init() { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scrt3 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3815, ADR( scrt3_char_3f_v ), MAKEPROCEDURE( 1, 0, scrt3_char_3f, EMPTYLIST ) ); INITIALIZEVAR( t3817, ADR( scrt3_char_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t3822, ADR( scrt3_char_3c_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_3c_3f, EMPTYLIST ) ); INITIALIZEVAR( t3827, ADR( scrt3_char_3e_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_3e_3f, EMPTYLIST ) ); INITIALIZEVAR( t3832, ADR( scrt3_char_3c_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_3c_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t3837, ADR( scrt3_char_3e_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_3e_3d_3f, EMPTYLIST ) ); X1 = sc_make_2dvector( _TSCP( 1024 ), EMPTYLIST ); X2 = _TSCP( 0 ); L3845: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 1024 ) ) ), 3 ) ) goto L3847; if ( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 1024 ) ) ) ) goto L3851; goto L3852; L3847: if ( FALSE( scrt2__3d_2dtwo( X2, _TSCP( 1024 ) ) ) ) goto L3852; L3851: if ( EQ( TSCPIMMEDIATETAG( _TSCP( 24850 ) ), CHARACTERTAG ) ) goto L3858; scdebug_error( c2195, c2196, CONS( _TSCP( 24850 ), EMPTYLIST ) ); L3858: X4 = CHAR_FIX( _TSCP( 24850 ) ); if ( EQ( TSCPIMMEDIATETAG( _TSCP( 16658 ) ), CHARACTERTAG ) ) goto L3861; scdebug_error( c2195, c2196, CONS( _TSCP( 16658 ), EMPTYLIST ) ); L3861: X5 = CHAR_FIX( _TSCP( 16658 ) ); X6 = _TSCP( 0 ); L3863: if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 104 ) ) ), 3 ) ) goto L3865; if ( NEQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 104 ) ) ) ) goto L3869; X3 = X1; goto L3855; L3865: if ( FALSE( scrt2__3d_2dtwo( X6, _TSCP( 104 ) ) ) ) goto L3869; X3 = X1; goto L3855; L3869: X8 = BOOLEAN( NEQ( TSCPTAG( X5 ), FIXNUMTAG ) ); if ( TRUE( X8 ) ) goto L3879; if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L3880; X9 = BOOLEAN( LT( _S2CINT( X5 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L3881; L3880: X9 = scrt2__3c_2dtwo( X5, _TSCP( 0 ) ); L3881: if ( TRUE( X9 ) ) goto L3879; if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L3888; if ( GT( _S2CINT( X5 ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L3879; goto L3895; L3888: if ( FALSE( scrt2__3e_2dtwo( X5, _TSCP( 1020 ) ) ) ) goto L3895; L3879: scdebug_error( c2112, c2113, CONS( X5, EMPTYLIST ) ); L3895: X7 = FIX_CHAR( X5 ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L3897; scdebug_error( c2077, c2078, CONS( X1, EMPTYLIST ) ); L3897: if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L3899; scdebug_error( c2077, c2081, CONS( X4, EMPTYLIST ) ); L3899: if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L3901; scdebug_error( c2077, c2085, CONS( X4, EMPTYLIST ) ); L3901: SETGEN( VECTOR_ELEMENT( X1, X4 ), X7 ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3903; X7 = _TSCP( IPLUS( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3904; L3903: X7 = scrt2__2b_2dtwo( X4, _TSCP( 4 ) ); L3904: if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3905; X8 = _TSCP( IPLUS( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3906; L3905: X8 = scrt2__2b_2dtwo( X5, _TSCP( 4 ) ); L3906: if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3907; X6 = _TSCP( IPLUS( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3908; L3907: X6 = scrt2__2b_2dtwo( X6, _TSCP( 4 ) ); L3908: X5 = X8; X4 = X7; GOBACK( L3863 ); L3852: X5 = BOOLEAN( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ); if ( TRUE( X5 ) ) goto L3915; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L3916; X6 = BOOLEAN( LT( _S2CINT( X2 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L3917; L3916: X6 = scrt2__3c_2dtwo( X2, _TSCP( 0 ) ); L3917: if ( TRUE( X6 ) ) goto L3915; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L3924; if ( GT( _S2CINT( X2 ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L3915; goto L3931; L3924: if ( FALSE( scrt2__3e_2dtwo( X2, _TSCP( 1020 ) ) ) ) goto L3931; L3915: scdebug_error( c2112, c2113, CONS( X2, EMPTYLIST ) ); L3931: X4 = FIX_CHAR( X2 ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L3933; scdebug_error( c2077, c2078, CONS( X1, EMPTYLIST ) ); L3933: if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L3935; scdebug_error( c2077, c2081, CONS( X2, EMPTYLIST ) ); L3935: if ( LT( _S2CUINT( FIXED_C( X2 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L3937; scdebug_error( c2077, c2085, CONS( X2, EMPTYLIST ) ); L3937: SETGEN( VECTOR_ELEMENT( X1, X2 ), X4 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3939; X2 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L3845 ); L3939: X2 = scrt2__2b_2dtwo( X2, _TSCP( 4 ) ); GOBACK( L3845 ); L3855: INITIALIZEVAR( t3842, ADR( scrt3_char_2dupcase_2dtable_v ), X3 ); INITIALIZEVAR( t3941, ADR( scrt3_char_2dci_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_2dci_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t3966, ADR( scrt3_char_2dci_3c_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_2dci_3c_3f, EMPTYLIST ) ); INITIALIZEVAR( t3991, ADR( scrt3_char_2dci_3e_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_2dci_3e_3f, EMPTYLIST ) ); INITIALIZEVAR( t4016, ADR( scrt3_char_2dci_3c_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_2dci_3c_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t4041, ADR( scrt3_char_2dci_3e_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_char_2dci_3e_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t4066, ADR( scrt3_char_2dalphabetic_3f_v ), MAKEPROCEDURE( 1, 0, scrt3_char_2dalphabetic_3f, EMPTYLIST ) ); INITIALIZEVAR( t4091, ADR( scrt3_char_2dnumeric_3f_v ), MAKEPROCEDURE( 1, 0, scrt3_char_2dnumeric_3f, EMPTYLIST ) ); INITIALIZEVAR( t4104, ADR( scrt3_char_2dwhitespace_3f_v ), MAKEPROCEDURE( 1, 0, scrt3_char_2dwhitespace_3f, EMPTYLIST ) ); INITIALIZEVAR( t4126, ADR( scrt3_char_2dupper_2dcase_3f_v ), MAKEPROCEDURE( 1, 0, scrt3_char_2dupper_2dcase_3f, EMPTYLIST ) ); INITIALIZEVAR( t4139, ADR( scrt3_char_2dlower_2dcase_3f_v ), MAKEPROCEDURE( 1, 0, scrt3_char_2dlower_2dcase_3f, EMPTYLIST ) ); INITIALIZEVAR( t4152, ADR( scrt3_char_2dupcase_v ), MAKEPROCEDURE( 1, 0, scrt3_char_2dupcase, EMPTYLIST ) ); INITIALIZEVAR( t4164, ADR( scrt3_char_2ddowncase_v ), MAKEPROCEDURE( 1, 0, scrt3_char_2ddowncase, EMPTYLIST ) ); INITIALIZEVAR( t4198, ADR( scrt3_char_2d_3einteger_v ), MAKEPROCEDURE( 1, 0, scrt3_char_2d_3einteger, EMPTYLIST ) ); INITIALIZEVAR( t4203, ADR( scrt3_integer_2d_3echar_v ), MAKEPROCEDURE( 1, 0, scrt3_integer_2d_3echar, EMPTYLIST ) ); INITIALIZEVAR( t4227, ADR( scrt3_string_3f_v ), MAKEPROCEDURE( 1, 0, scrt3_string_3f, EMPTYLIST ) ); INITIALIZEVAR( t4229, ADR( scrt3_string_v ), MAKEPROCEDURE( 0, 1, scrt3_string, EMPTYLIST ) ); INITIALIZEVAR( t4231, ADR( scrt3_string_2dlength_v ), MAKEPROCEDURE( 1, 0, scrt3_string_2dlength, EMPTYLIST ) ); INITIALIZEVAR( t4236, ADR( scrt3_string_2dref_v ), MAKEPROCEDURE( 2, 0, scrt3_string_2dref, EMPTYLIST ) ); INITIALIZEVAR( t4259, ADR( scrt3_string_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt3_string_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t4284, ADR( scrt3_string_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t4318, ADR( scrt3_string_3c_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_3c_3f, EMPTYLIST ) ); INITIALIZEVAR( t4356, ADR( scrt3_string_3e_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_3e_3f, EMPTYLIST ) ); INITIALIZEVAR( t4394, ADR( scrt3_string_3c_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_3c_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t4398, ADR( scrt3_string_3e_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_3e_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t4402, ADR( scrt3_string_2dci_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_2dci_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t4458, ADR( scrt3_string_2dci_3c_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_2dci_3c_3f, EMPTYLIST ) ); INITIALIZEVAR( t4518, ADR( scrt3_string_2dci_3e_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_2dci_3e_3f, EMPTYLIST ) ); INITIALIZEVAR( t4578, ADR( scrt3_string_2dci_3c_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_2dci_3c_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t4582, ADR( scrt3_string_2dci_3e_3d_3f_v ), MAKEPROCEDURE( 2, 0, scrt3_string_2dci_3e_3d_3f, EMPTYLIST ) ); INITIALIZEVAR( t4586, ADR( scrt3_substring_v ), MAKEPROCEDURE( 3, 0, scrt3_substring, EMPTYLIST ) ); INITIALIZEVAR( t4640, ADR( scrt3_string_2dappend_v ), MAKEPROCEDURE( 0, 1, scrt3_string_2dappend, EMPTYLIST ) ); INITIALIZEVAR( t4685, ADR( scrt3_string_2d_3elist_v ), MAKEPROCEDURE( 1, 0, scrt3_string_2d_3elist, EMPTYLIST ) ); INITIALIZEVAR( t4705, ADR( scrt3_list_2d_3estring_v ), MAKEPROCEDURE( 1, 0, scrt3_list_2d_3estring, EMPTYLIST ) ); INITIALIZEVAR( t4721, ADR( scrt3_string_2dfill_21_v ), MAKEPROCEDURE( 2, 0, scrt3_string_2dfill_21, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/scrt3.sc000066400000000000000000000207471203736146400161530ustar00rootroot00000000000000;;; SCHEME->C Runtime Library ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scrt3 (top-level CHAR? CHAR=? CHAR? CHAR<=? CHAR>=? CHAR-CI=? CHAR-CI? CHAR-CI<=? CHAR-CI>=? CHAR-ALPHABETIC? CHAR-NUMERIC? CHAR-WHITESPACE? CHAR-UPPER-CASE? CHAR-LOWER-CASE? CHAR-UPCASE CHAR-DOWNCASE CHAR->INTEGER INTEGER->CHAR STRING? STRING STRING-LENGTH STRING-REF STRING-SET! STRING=? STRING? STRING<=? STRING>=? STRING-CI=? STRING-CI? STRING-CI<=? STRING-CI>=? SUBSTRING STRING-APPEND STRING->LIST LIST->STRING STRING-FILL!)) ;;; 6.6 Characters (define (CHAR? x) (char? x)) (define (CHAR=? x y) (char=? x y)) (define (CHAR? x y) (char>? x y)) (define (CHAR<=? x y) (not (char>? x y))) (define (CHAR>=? x y) (not (charinteger #\a) (+ i 1)) (j (char->integer #\A) (+ j 1)) (c 0 (+ c 1))) ((= c 26) v) (vector-set! v i (integer->char j)))) (vector-set! v i (integer->char i))))) (define-in-line (UPCASE char) (vector-ref char-upcase-table (char->integer char))) (define (CHAR-CI=? x y) (char=? (upcase x) (upcase y))) (define (CHAR-CI? x y) (char>? (upcase x) (upcase y))) (define (CHAR-CI<=? x y) (char<=? (upcase x) (upcase y))) (define (CHAR-CI>=? x y) (char>=? (upcase x) (upcase y))) (define (CHAR-ALPHABETIC? x) (if (not (char? x)) (error 'CHAR-ALPHABETIC? "Argument not a CHAR")) (or (and (char>=? x #\A) (char<=? x #\Z)) (and (char>=? x #\a) (char<=? x #\z)))) (define (CHAR-NUMERIC? x) (if (not (char? x)) (error 'CHAR-NUMERIC? "Argument not a CHAR")) (and (char>=? x #\0) (char<=? x #\9))) (define (CHAR-WHITESPACE? x) (if (not (char? x)) (error 'CHAR-WHITESPACE? "Argument not a CHAR")) (set! x (char->integer x)) (or (and (>= x #o11) (<= x #o15)) (= x #o40))) (define (CHAR-UPPER-CASE? letter) (if (not (char? letter)) (error 'CHAR-UPPER-CASE? "Argument not a CHAR")) (and (char>=? letter #\A) (char<=? letter #\Z))) (define (CHAR-LOWER-CASE? letter) (if (not (char? letter)) (error 'CHAR-LOWER-CASE? "Argument not a CHAR")) (and (char>=? letter #\a) (char<=? letter #\z))) (define (CHAR-UPCASE x) (if (not (char? x)) (error 'CHAR-UPCASE "Argument not a CHAR")) (upcase x)) (define (CHAR-DOWNCASE x) (if (not (char? x)) (error 'CHAR-DOWNCASE "Argument not a CHAR")) (if (and (char-alphabetic? x) (char-upper-case? x)) (integer->char (+ (char->integer x) 32)) x)) (define (CHAR->INTEGER x) (char->integer x)) (define (INTEGER->CHAR x) (integer->char x)) ;;; 6.7 Strings. (define (STRING? x) (string? x)) (define (STRING . x) (list->string x)) (define (STRING-LENGTH x) (string-length x)) (define (STRING-REF x y) (string-ref x y)) (define (STRING-SET! x y z) (string-set! x y z)) ;;; In-line definitions for use in the following routines: (define-in-line (STRING-LENGTH s) ((lap (s) (C_FIXED (STRING_LENGTH s))) s)) (define-in-line (STRING-REF s x) ((lap (s x) (C_CHAR (STRING_CHAR s x))) s x)) (define-in-line (UCSTRING-REF s x) (upcase ((lap (s x) (C_CHAR (STRING_CHAR s x))) s x))) (define-in-line (STRING-SET! s x c) ((lap (s x c) (SET (STRING_CHAR s x) (CHAR_C c)) c) s x c)) (define (STRING=? x y) (if (or (not (string? x)) (not (string? y))) (error 'STRING=? "Argument(s) not a STRING")) (let ((xl (string-length x)) (yl (string-length y))) (if (= xl yl) (do ((i 0 (+ i 1))) ((or (= i xl) (not (eq? (string-ref x i) (string-ref y i)))) (= i xl))) #f))) (define (STRING? x y) (if (or (not (string? x)) (not (string? y))) (error 'STRING>? "Argument(s) not a STRING")) (let* ((xl (string-length x)) (yl (string-length y)) (minxlyl (min xl yl))) (let test ((i 0)) (if (= i minxlyl) (> xl yl) (let ((cx (string-ref x i)) (cy (string-ref y i))) (if (eq? cx cy) (test (+ i 1)) (char>? cx cy))))))) (define (STRING<=? x y) (not (string>? x y))) (define (STRING>=? x y) (not (string? x y) (if (or (not (string? x)) (not (string? y))) (error 'STRING-CI>? "Argument(s) not a STRING")) (let* ((xl (string-length x)) (yl (string-length y)) (minxlyl (min xl yl))) (let test ((i 0)) (if (= i minxlyl) (> xl yl) (let ((cx (ucstring-ref x i)) (cy (ucstring-ref y i))) (if (eq? cx cy) (test (+ i 1)) (char>? cx cy))))))) (define (STRING-CI<=? x y) (not (string-ci>? x y))) (define (STRING-CI>=? x y) (not (string-ci z (string-length x))) (error 'SUBSTRING "Argument(s) not a STRING INDEX")) (do ((i y (+ i 1)) (j 0 (+ j 1)) (s (make-string (- z y)))) ((= i z) s) (string-set! s j (string-ref x i)))) (define (STRING-APPEND . x) (do ((new (let loop ((sl x) (len 0)) (cond ((null? sl) (make-string len)) ((string? (car sl)) (loop (cdr sl) (+ len (string-length (car sl))))) (else (error 'STRING-APPEND "Argument is not a STRING: ~s" (car sl)))))) (i 0 (+ i (string-length (car sl)))) (sl x (cdr sl))) ((null? sl) new) (do ((old (car sl)) (j (- (string-length (car sl)) 1) (- j 1))) ((eq? j -1)) (string-set! new (+ i j) (string-ref old j))))) (define (STRING->LIST x) (if (not (string? x)) (error 'STRING->LIST "Argument is not a STRING: ~s" x)) (do ((i (- (string-length x) 1) (- i 1)) (l '())) ((= i -1) l) (set! l (cons (string-ref x i) l)))) (define (LIST->STRING x) (do ((i 0 (+ i 1)) (l x (cdr l)) (s (make-string (length x)))) ((null? l) s) (let ((char (car l))) (if (not (char? char)) (error 'LIST->STRING "Argument is not a list of CHARACTERS: ~s" x)) (string-set! s i char)))) (define (STRING-FILL! s c) (if (not (string? s)) (error 'STRING-FILL! "Argument is not a STRING: ~s" s)) (if (not (char? c)) (error 'STRING-FILL! "Argument is not a CHAR: ~s" c)) (do ((i (- (string-length s) 1) (- i 1))) ((= i -1) s) (string-set! s i c))) scheme2c-2012.10.14/scrt/scrt4.c000066400000000000000000002310321203736146400157600ustar00rootroot00000000000000 /* SCHEME->C */ #include void scrt4__init(); DEFCSTRING( t3115, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c3064 ); DEFSTATICTSCP( c3063 ); DEFCSTRING( t3116, "Argument is not a valid SIGNAL HANDLER: ~s" ); DEFSTATICTSCP( c3008 ); DEFCSTRING( t3117, "Argument is not a valid SIGNAL: ~s" ); DEFSTATICTSCP( c2991 ); DEFSTATICTSCP( c2990 ); DEFCSTRING( t3118, "Argument is not a PROCEDURE: ~s" ); DEFSTATICTSCP( c2945 ); DEFSTATICTSCP( c2944 ); DEFSTATICTSCP( c2854 ); DEFSTATICTSCP( c2847 ); DEFSTATICTSCP( c2840 ); DEFSTATICTSCP( c2833 ); DEFSTATICTSCP( c2826 ); DEFSTATICTSCP( c2820 ); DEFSTATICTSCP( c2814 ); DEFCSTRING( t3119, "Structure is not a SCHEME pointer: ~s" ); DEFSTATICTSCP( c2808 ); DEFSTATICTSCP( c2807 ); DEFCSTRING( t3120, "#~" ); DEFSTATICTSCP( c2713 ); DEFSTATICTSCP( c2706 ); DEFSTATICTSCP( c2702 ); DEFSTATICTSCP( c2698 ); DEFSTATICTSCP( t3121 ); DEFSTATICTSCP( t3122 ); DEFSTATICTSCP( c2681 ); DEFSTATICTSCP( c2587 ); DEFSTATICTSCP( c2571 ); DEFCSTRING( t3123, "Argument is not a %RECORD: ~s" ); DEFSTATICTSCP( c2562 ); DEFSTATICTSCP( c2561 ); DEFCSTRING( t3124, "***** ~a " ); DEFSTATICTSCP( c2546 ); DEFCSTRING( t3125, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2470 ); DEFSTATICTSCP( c2469 ); DEFSTATICTSCP( c2170 ); DEFCSTRING( t3126, "Index is not in bounds: ~s" ); DEFSTATICTSCP( c2159 ); DEFCSTRING( t3127, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2155 ); DEFSTATICTSCP( c2152 ); DEFCSTRING( t3128, "Argument is not a VECTOR: ~s" ); DEFSTATICTSCP( c2143 ); DEFSTATICTSCP( c2142 ); static void init_constants() { c3064 = CSTRING_TSCP( t3115 ); CONSTANTEXP( ADR( c3064 ) ); c3063 = STRINGTOSYMBOL( CSTRING_TSCP( "SYSTEM" ) ); CONSTANTEXP( ADR( c3063 ) ); c3008 = CSTRING_TSCP( t3116 ); CONSTANTEXP( ADR( c3008 ) ); c2991 = CSTRING_TSCP( t3117 ); CONSTANTEXP( ADR( c2991 ) ); c2990 = STRINGTOSYMBOL( CSTRING_TSCP( "SIGNAL" ) ); CONSTANTEXP( ADR( c2990 ) ); c2945 = CSTRING_TSCP( t3118 ); CONSTANTEXP( ADR( c2945 ) ); c2944 = STRINGTOSYMBOL( CSTRING_TSCP( "WHEN-UNREFERENCED" ) ); CONSTANTEXP( ADR( c2944 ) ); c2854 = STRINGTOSYMBOL( CSTRING_TSCP( "SCHEME-S2CUINT-SET!" ) ); CONSTANTEXP( ADR( c2854 ) ); c2847 = STRINGTOSYMBOL( CSTRING_TSCP( "SCHEME-TSCP-SET!" ) ); CONSTANTEXP( ADR( c2847 ) ); c2840 = STRINGTOSYMBOL( CSTRING_TSCP( "SCHEME-INT-SET!" ) ); CONSTANTEXP( ADR( c2840 ) ); c2833 = STRINGTOSYMBOL( CSTRING_TSCP( "SCHEME-BYTE-SET!" ) ); CONSTANTEXP( ADR( c2833 ) ); c2826 = STRINGTOSYMBOL( CSTRING_TSCP( "SCHEME-S2CUINT-REF" ) ); CONSTANTEXP( ADR( c2826 ) ); c2820 = STRINGTOSYMBOL( CSTRING_TSCP( "SCHEME-TSCP-REF" ) ); CONSTANTEXP( ADR( c2820 ) ); c2814 = STRINGTOSYMBOL( CSTRING_TSCP( "SCHEME-INT-REF" ) ); CONSTANTEXP( ADR( c2814 ) ); c2808 = CSTRING_TSCP( t3119 ); CONSTANTEXP( ADR( c2808 ) ); c2807 = STRINGTOSYMBOL( CSTRING_TSCP( "SCHEME-BYTE-REF" ) ); CONSTANTEXP( ADR( c2807 ) ); c2713 = CSTRING_TSCP( t3120 ); CONSTANTEXP( ADR( c2713 ) ); c2706 = STRINGTOSYMBOL( CSTRING_TSCP( "%TO-EVAL" ) ); CONSTANTEXP( ADR( c2706 ) ); c2702 = STRINGTOSYMBOL( CSTRING_TSCP( "%TO-EQUAL?" ) ); CONSTANTEXP( ADR( c2702 ) ); c2698 = EMPTYLIST; t3121 = STRINGTOSYMBOL( CSTRING_TSCP( "%TO-DISPLAY" ) ); c2698 = CONS( t3121, c2698 ); t3122 = STRINGTOSYMBOL( CSTRING_TSCP( "%TO-WRITE" ) ); c2698 = CONS( t3122, c2698 ); CONSTANTEXP( ADR( c2698 ) ); c2681 = STRINGTOSYMBOL( CSTRING_TSCP( "%RECORD-METHODS" ) ); CONSTANTEXP( ADR( c2681 ) ); c2587 = STRINGTOSYMBOL( CSTRING_TSCP( "%RECORD-SET!" ) ); CONSTANTEXP( ADR( c2587 ) ); c2571 = STRINGTOSYMBOL( CSTRING_TSCP( "%RECORD-REF" ) ); CONSTANTEXP( ADR( c2571 ) ); c2562 = CSTRING_TSCP( t3123 ); CONSTANTEXP( ADR( c2562 ) ); c2561 = STRINGTOSYMBOL( CSTRING_TSCP( "%RECORD-LENGTH" ) ); CONSTANTEXP( ADR( c2561 ) ); c2546 = CSTRING_TSCP( t3124 ); CONSTANTEXP( ADR( c2546 ) ); c2470 = CSTRING_TSCP( t3125 ); CONSTANTEXP( ADR( c2470 ) ); c2469 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2469 ) ); c2170 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-SET!" ) ); CONSTANTEXP( ADR( c2170 ) ); c2159 = CSTRING_TSCP( t3126 ); CONSTANTEXP( ADR( c2159 ) ); c2155 = CSTRING_TSCP( t3127 ); CONSTANTEXP( ADR( c2155 ) ); c2152 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-REF" ) ); CONSTANTEXP( ADR( c2152 ) ); c2143 = CSTRING_TSCP( t3128 ); CONSTANTEXP( ADR( c2143 ) ); c2142 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-LENGTH" ) ); CONSTANTEXP( ADR( c2142 ) ); } DEFTSCP( scrt4_vector_3f_v ); DEFCSTRING( t3129, "VECTOR?" ); TSCP scrt4_vector_3f( x2131 ) TSCP x2131; { PUSHSTACKTRACE( t3129 ); POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2131 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2131 ), VECTORTAG ) ) ) ); } DEFTSCP( scrt4_vector_v ); DEFCSTRING( t3131, "VECTOR" ); EXTERNTSCPP( scrt4_list_2d_3evector, XAL1( TSCP ) ); EXTERNTSCP( scrt4_list_2d_3evector_v ); TSCP scrt4_vector( x2135 ) TSCP x2135; { PUSHSTACKTRACE( t3131 ); POPSTACKTRACE( scrt4_list_2d_3evector( x2135 ) ); } DEFTSCP( scrt4_vector_2dlength_v ); DEFCSTRING( t3133, "VECTOR-LENGTH" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP scrt4_vector_2dlength( x2137 ) TSCP x2137; { PUSHSTACKTRACE( t3133 ); if ( AND( EQ( TSCPTAG( x2137 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2137 ), VECTORTAG ) ) ) goto L3136; scdebug_error( c2142, c2143, CONS( x2137, EMPTYLIST ) ); L3136: POPSTACKTRACE( C_FIXED( VECTOR_LENGTH( x2137 ) ) ); } DEFTSCP( scrt4_vector_2dref_v ); DEFCSTRING( t3138, "VECTOR-REF" ); TSCP scrt4_vector_2dref( x2145, y2146 ) TSCP x2145, y2146; { PUSHSTACKTRACE( t3138 ); if ( AND( EQ( TSCPTAG( x2145 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2145 ), VECTORTAG ) ) ) goto L3141; scdebug_error( c2152, c2143, CONS( x2145, EMPTYLIST ) ); L3141: if ( EQ( TSCPTAG( y2146 ), FIXNUMTAG ) ) goto L3143; scdebug_error( c2152, c2155, CONS( y2146, EMPTYLIST ) ); L3143: if ( LT( _S2CUINT( FIXED_C( y2146 ) ), _S2CUINT( VECTOR_LENGTH( x2145 ) ) ) ) goto L3145; scdebug_error( c2152, c2159, CONS( y2146, EMPTYLIST ) ); L3145: POPSTACKTRACE( VECTOR_ELEMENT( x2145, y2146 ) ); } DEFTSCP( scrt4_vector_2dset_21_v ); DEFCSTRING( t3147, "VECTOR-SET!" ); TSCP scrt4_vector_2dset_21( x2161, y2162, z2163 ) TSCP x2161, y2162, z2163; { PUSHSTACKTRACE( t3147 ); if ( AND( EQ( TSCPTAG( x2161 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2161 ), VECTORTAG ) ) ) goto L3150; scdebug_error( c2170, c2143, CONS( x2161, EMPTYLIST ) ); L3150: if ( EQ( TSCPTAG( y2162 ), FIXNUMTAG ) ) goto L3152; scdebug_error( c2170, c2155, CONS( y2162, EMPTYLIST ) ); L3152: if ( LT( _S2CUINT( FIXED_C( y2162 ) ), _S2CUINT( VECTOR_LENGTH( x2161 ) ) ) ) goto L3154; scdebug_error( c2170, c2159, CONS( y2162, EMPTYLIST ) ); L3154: POPSTACKTRACE( SETGEN( VECTOR_ELEMENT( x2161, y2162 ), z2163 ) ); } DEFTSCP( scrt4_vector_2d_3elist_v ); DEFCSTRING( t3156, "VECTOR->LIST" ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP scrt4_vector_2d_3elist( x2177 ) TSCP x2177; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3156 ); if ( AND( EQ( TSCPTAG( x2177 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2177 ), VECTORTAG ) ) ) goto L3160; scdebug_error( c2142, c2143, CONS( x2177, EMPTYLIST ) ); L3160: X2 = C_FIXED( VECTOR_LENGTH( x2177 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3163; X1 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3164; L3163: X1 = scrt2__2d_2dtwo( X2, _TSCP( 4 ) ); L3164: X2 = EMPTYLIST; L3165: X2 = CONS( X2, EMPTYLIST ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( -4 ) ) ), 3 ) ) goto L3167; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L3171; POPSTACKTRACE( PAIR_CAR( X2 ) ); L3167: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( -4 ) ) ) ) goto L3171; POPSTACKTRACE( PAIR_CAR( X2 ) ); L3171: if ( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L3176; scdebug_error( c2152, c2155, CONS( X1, EMPTYLIST ) ); L3176: if ( LT( _S2CUINT( FIXED_C( X1 ) ), _S2CUINT( VECTOR_LENGTH( x2177 ) ) ) ) goto L3178; scdebug_error( c2152, c2159, CONS( X1, EMPTYLIST ) ); L3178: X4 = VECTOR_ELEMENT( x2177, X1 ); X3 = sc_cons( X4, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X3 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3180; X3 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3181; L3180: X3 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); L3181: X2 = PAIR_CAR( X2 ); X1 = X3; GOBACK( L3165 ); } DEFTSCP( scrt4_list_2d_3evector_v ); DEFCSTRING( t3182, "LIST->VECTOR" ); EXTERNTSCPP( sc_make_2dvector, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dvector_v ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); TSCP scrt4_list_2d_3evector( x2223 ) TSCP x2223; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3182 ); X2 = scrt1_length( x2223 ); X1 = sc_make_2dvector( X2, EMPTYLIST ); X2 = x2223; X3 = _TSCP( 0 ); L3185: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3186; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3190; scrt1__24__car_2derror( X2 ); L3190: X4 = PAIR_CAR( X2 ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L3193; scdebug_error( c2170, c2143, CONS( X1, EMPTYLIST ) ); L3193: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L3195; scdebug_error( c2170, c2155, CONS( X3, EMPTYLIST ) ); L3195: if ( LT( _S2CUINT( FIXED_C( X3 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L3197; scdebug_error( c2170, c2159, CONS( X3, EMPTYLIST ) ); L3197: SETGEN( VECTOR_ELEMENT( X1, X3 ), X4 ); X4 = PAIR_CDR( X2 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3200; X3 = _TSCP( IPLUS( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3201; L3200: X3 = scrt2__2b_2dtwo( X3, _TSCP( 4 ) ); L3201: X2 = X4; GOBACK( L3185 ); L3186: POPSTACKTRACE( X1 ); } DEFTSCP( scrt4_vector_2dfill_21_v ); DEFCSTRING( t3202, "VECTOR-FILL!" ); TSCP scrt4_vector_2dfill_21( v2262, x2263 ) TSCP v2262, x2263; { TSCP X2, X1; PUSHSTACKTRACE( t3202 ); if ( AND( EQ( TSCPTAG( v2262 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( v2262 ), VECTORTAG ) ) ) goto L3206; scdebug_error( c2142, c2143, CONS( v2262, EMPTYLIST ) ); L3206: X2 = C_FIXED( VECTOR_LENGTH( v2262 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3209; X1 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3210; L3209: X1 = scrt2__2d_2dtwo( X2, _TSCP( 4 ) ); L3210: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( -4 ) ) ), 3 ) ) goto L3213; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L3217; POPSTACKTRACE( v2262 ); L3213: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( -4 ) ) ) ) goto L3217; POPSTACKTRACE( v2262 ); L3217: if ( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L3222; scdebug_error( c2170, c2155, CONS( X1, EMPTYLIST ) ); L3222: if ( LT( _S2CUINT( FIXED_C( X1 ) ), _S2CUINT( VECTOR_LENGTH( v2262 ) ) ) ) goto L3224; scdebug_error( c2170, c2159, CONS( X1, EMPTYLIST ) ); L3224: SETGEN( VECTOR_ELEMENT( v2262, X1 ), x2263 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3226; X1 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L3210 ); L3226: X1 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); GOBACK( L3210 ); } DEFTSCP( scrt4_procedure_3f_v ); DEFCSTRING( t3228, "PROCEDURE?" ); TSCP scrt4_procedure_3f( x2306 ) TSCP x2306; { PUSHSTACKTRACE( t3228 ); POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2306 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2306 ), PROCEDURETAG ) ) ) ); } DEFTSCP( scrt4_apply_v ); DEFCSTRING( t3230, "APPLY" ); EXTERNTSCPP( sc_apply_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_apply_2dtwo_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt4_l2316, XAL1( TSCP ) ); TSCP scrt4_l2316( o2318 ) TSCP o2318; { TSCP X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside APPLY]" ); if ( EQ( TSCPTAG( o2318 ), PAIRTAG ) ) goto L3237; scrt1__24__cdr_2derror( o2318 ); L3237: if ( FALSE( PAIR_CDR( o2318 ) ) ) goto L3239; X1 = PAIR_CAR( o2318 ); X3 = PAIR_CDR( o2318 ); X2 = scrt4_l2316( X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L3239: POPSTACKTRACE( PAIR_CAR( o2318 ) ); } TSCP scrt4_apply( p2310, a2311, o2312 ) TSCP p2310, a2311, o2312; { TSCP X2, X1; PUSHSTACKTRACE( t3230 ); if ( FALSE( o2312 ) ) goto L3232; X2 = scrt4_l2316( o2312 ); X1 = sc_cons( a2311, X2 ); POPSTACKTRACE( sc_apply_2dtwo( p2310, X1 ) ); L3232: POPSTACKTRACE( sc_apply_2dtwo( p2310, a2311 ) ); } DEFTSCP( scrt4_map_v ); DEFCSTRING( t3244, "MAP" ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); TSCP scrt4_map( f2336, x2337, _262338 ) TSCP f2336, x2337, _262338; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3244 ); X1 = sc_cons( x2337, _262338 ); X2 = X1; X3 = EMPTYLIST; L3249: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3253; scrt1__24__car_2derror( X2 ); L3253: X4 = PAIR_CAR( X2 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3250; POPSTACKTRACE( scrt1_reverse( X3 ) ); L3250: X5 = X2; X6 = X5; X7 = EMPTYLIST; L3257: if ( NEQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L3258; X4 = scrt1_reverse( X7 ); goto L3259; L3258: if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3261; scrt1__24__cdr_2derror( X6 ); L3261: X8 = PAIR_CDR( X6 ); X10 = PAIR_CAR( X6 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3265; scrt1__24__cdr_2derror( X10 ); L3265: X9 = PAIR_CDR( X10 ); X7 = sc_cons( X9, X7 ); X6 = X8; GOBACK( L3257 ); L3259: X7 = X2; X8 = X7; X9 = EMPTYLIST; L3269: if ( NEQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L3270; X6 = scrt1_reverse( X9 ); goto L3271; L3270: if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3273; scrt1__24__cdr_2derror( X8 ); L3273: X10 = PAIR_CDR( X8 ); X12 = PAIR_CAR( X8 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L3277; scrt1__24__car_2derror( X12 ); L3277: X11 = PAIR_CAR( X12 ); X9 = sc_cons( X11, X9 ); X8 = X10; GOBACK( L3269 ); L3271: X5 = sc_apply_2dtwo( f2336, X6 ); X3 = sc_cons( X5, X3 ); X2 = X4; GOBACK( L3249 ); } DEFTSCP( scrt4_for_2deach_v ); DEFCSTRING( t3279, "FOR-EACH" ); EXTERNTSCPP( scrt1_car, XAL1( TSCP ) ); EXTERNTSCP( scrt1_car_v ); EXTERNTSCPP( scrt1_cdr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdr_v ); TSCP scrt4_for_2deach( p2418, a2419, o2420 ) TSCP p2418, a2419, o2420; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3279 ); X1 = sc_cons( a2419, o2420 ); L3282: if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3286; scrt1__24__car_2derror( X1 ); L3286: X2 = PAIR_CAR( X1 ); if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3283; X3 = X1; X4 = EMPTYLIST; X5 = EMPTYLIST; L3291: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3292; X2 = X4; goto L3299; L3292: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3295; scrt1__24__car_2derror( X3 ); L3295: X8 = PAIR_CAR( X3 ); X7 = scrt1_car( X8 ); X6 = sc_cons( X7, EMPTYLIST ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3298; X7 = PAIR_CDR( X3 ); X5 = X6; X4 = X6; X3 = X7; GOBACK( L3291 ); L3298: X7 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3303; scdebug_error( c2469, c2470, CONS( X5, EMPTYLIST ) ); L3303: X5 = SETGEN( PAIR_CDR( X5 ), X6 ); X3 = X7; GOBACK( L3291 ); L3299: sc_apply_2dtwo( p2418, X2 ); X2 = X1; X3 = EMPTYLIST; X4 = EMPTYLIST; L3307: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3308; X1 = X3; GOBACK( L3282 ); L3308: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3311; scrt1__24__car_2derror( X2 ); L3311: X7 = PAIR_CAR( X2 ); X6 = scrt1_cdr( X7 ); X5 = sc_cons( X6, EMPTYLIST ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3314; X6 = PAIR_CDR( X2 ); X4 = X5; X3 = X5; X2 = X6; GOBACK( L3307 ); L3314: X6 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3319; scdebug_error( c2469, c2470, CONS( X4, EMPTYLIST ) ); L3319: X4 = SETGEN( PAIR_CDR( X4 ), X5 ); X2 = X6; GOBACK( L3307 ); L3283: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt4_force_v ); DEFCSTRING( t3321, "FORCE" ); TSCP scrt4_force( o2522 ) TSCP o2522; { TSCP X1; PUSHSTACKTRACE( t3321 ); X1 = o2522; X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt4_make_2dpromise_v ); DEFCSTRING( t3323, "MAKE-PROMISE" ); TSCP scrt4_l2528( c3326 ) TSCP c3326; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scrt4_l2528 [inside MAKE-PROMISE]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3326, 0 ); X2 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3326, 1 ); X3 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c3326, 2 ); if ( TRUE( PAIR_CAR( DISPLAY( 2 ) ) ) ) goto L3328; X6 = DISPLAY( 0 ); X6 = UNKNOWNCALL( X6, 0 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( PROCEDURE_CLOSURE( X6 ) ); SETGEN( PAIR_CAR( DISPLAY( 1 ) ), X5 ); X5 = TRUEVALUE; SETGEN( PAIR_CAR( DISPLAY( 2 ) ), X5 ); L3328: X4 = PAIR_CAR( DISPLAY( 1 ) ); DISPLAY( 0 ) = X1; DISPLAY( 1 ) = X2; DISPLAY( 2 ) = X3; POPSTACKTRACE( X4 ); } TSCP scrt4_make_2dpromise( p2524 ) TSCP p2524; { TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( t3323 ); DISPLAY( 0 ) = p2524; DISPLAY( 1 ) = FALSEVALUE; DISPLAY( 2 ) = FALSEVALUE; DISPLAY( 2 ) = CONS( DISPLAY( 2 ), EMPTYLIST ); DISPLAY( 1 ) = CONS( DISPLAY( 1 ), EMPTYLIST ); SDVAL = MAKEPROCEDURE( 0, 0, scrt4_l2528, MAKECLOSURE( EMPTYLIST, 3, DISPLAY( 0 ), DISPLAY( 1 ), DISPLAY( 2 ) ) ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } DEFTSCP( scrt4_catch_2derror_v ); DEFCSTRING( t3331, "CATCH-ERROR" ); EXTERNTSCP( scdebug__2aerror_2dhandler_2a_v ); EXTERNTSCPP( scrt5_open_2doutput_2dstring, XAL0( ) ); EXTERNTSCP( scrt5_open_2doutput_2dstring_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt6_get_2doutput_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt6_get_2doutput_2dstring_v ); TSCP scrt4_e2539( i2541, f2542, a2543, c3337 ) TSCP i2541, f2542, a2543, c3337; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "ERROR [inside CATCH-ERROR]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3337, 0 ); X2 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c3337, 1 ); X4 = scrt5_open_2doutput_2dstring( ); scdebug__2aerror_2dhandler_2a_v = DISPLAY( 1 ); X5 = CONS( i2541, EMPTYLIST ); scrt6_format( X4, CONS( c2546, X5 ) ); X6 = CONS( a2543, EMPTYLIST ); X5 = scrt1_cons_2a( X4, CONS( f2542, X6 ) ); sc_apply_2dtwo( scrt6_format_v, X5 ); X6 = scrt6_get_2doutput_2dstring( X4 ); X5 = DISPLAY( 2 ); X5 = UNKNOWNCALL( X5, 1 ); X3 = VIA( PROCEDURE_CODE( X5 ) )( X6, PROCEDURE_CLOSURE( X5 ) ); DISPLAY( 1 ) = X1; DISPLAY( 2 ) = X2; POPSTACKTRACE( X3 ); } TSCP scrt4_l2536( r2537, c3334 ) TSCP r2537, c3334; { TSCP X7, X6, X5, X4, X3, X2, X1; TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( "scrt4_l2536 [inside CATCH-ERROR]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3334, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3334, 1 ); DISPLAY( 2 ) = r2537; X4 = _TSCP( 0 ); X4 = CONS( X4, EMPTYLIST ); X5 = MAKEPROCEDURE( 2, 1, scrt4_e2539, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 1 ), DISPLAY( 2 ) ) ); SETGEN( PAIR_CAR( X4 ), X5 ); scdebug__2aerror_2dhandler_2a_v = PAIR_CAR( X4 ); X7 = DISPLAY( 0 ); X7 = UNKNOWNCALL( X7, 0 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( PROCEDURE_CLOSURE( X7 ) ); X5 = sc_cons( X6, EMPTYLIST ); X3 = X5; DISPLAY( 1 ) = X1; DISPLAY( 0 ) = X2; SDVAL = X3; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } EXTERNTSCP( sc_ntinuation_1af38b9f_v ); TSCP scrt4_catch_2derror( p2531 ) TSCP p2531; { TSCP X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SDVAL; PUSHSTACKTRACE( t3331 ); DISPLAY( 0 ) = p2531; DISPLAY( 1 ) = scdebug__2aerror_2dhandler_2a_v; X3 = MAKEPROCEDURE( 1, 0, scrt4_l2536, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 1 ), DISPLAY( 0 ) ) ); X2 = sc_ntinuation_1af38b9f_v; X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); scdebug__2aerror_2dhandler_2a_v = DISPLAY( 1 ); SDVAL = X1; DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; POPSTACKTRACE( SDVAL ); } DEFTSCP( scrt4__25record_3f_v ); DEFCSTRING( t3342, "%RECORD?" ); TSCP scrt4__25record_3f( x2550 ) TSCP x2550; { PUSHSTACKTRACE( t3342 ); POPSTACKTRACE( BOOLEAN( AND( EQ( TSCPTAG( x2550 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2550 ), RECORDTAG ) ) ) ); } DEFTSCP( scrt4__25record_v ); DEFCSTRING( t3344, "%RECORD" ); EXTERNTSCPP( scrt4_list_2d_3e_25record, XAL1( TSCP ) ); EXTERNTSCP( scrt4_list_2d_3e_25record_v ); TSCP scrt4__25record( x2554 ) TSCP x2554; { PUSHSTACKTRACE( t3344 ); POPSTACKTRACE( scrt4_list_2d_3e_25record( x2554 ) ); } DEFTSCP( scrt4__25record_2dlength_v ); DEFCSTRING( t3346, "%RECORD-LENGTH" ); TSCP scrt4__25record_2dlength( x2556 ) TSCP x2556; { PUSHSTACKTRACE( t3346 ); if ( AND( EQ( TSCPTAG( x2556 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2556 ), RECORDTAG ) ) ) goto L3349; scdebug_error( c2561, c2562, CONS( x2556, EMPTYLIST ) ); L3349: POPSTACKTRACE( C_FIXED( RECORD_LENGTH( x2556 ) ) ); } DEFTSCP( scrt4__25record_2dref_v ); DEFCSTRING( t3351, "%RECORD-REF" ); TSCP scrt4__25record_2dref( x2564, y2565 ) TSCP x2564, y2565; { PUSHSTACKTRACE( t3351 ); if ( AND( EQ( TSCPTAG( x2564 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2564 ), RECORDTAG ) ) ) goto L3354; scdebug_error( c2571, c2562, CONS( x2564, EMPTYLIST ) ); L3354: if ( EQ( TSCPTAG( y2565 ), FIXNUMTAG ) ) goto L3356; scdebug_error( c2571, c2155, CONS( y2565, EMPTYLIST ) ); L3356: if ( LT( _S2CUINT( FIXED_C( y2565 ) ), _S2CUINT( RECORD_LENGTH( x2564 ) ) ) ) goto L3358; scdebug_error( c2571, c2159, CONS( y2565, EMPTYLIST ) ); L3358: POPSTACKTRACE( RECORD_ELEMENT( x2564, y2565 ) ); } DEFTSCP( scrt4__25record_2dset_21_v ); DEFCSTRING( t3360, "%RECORD-SET!" ); TSCP scrt4__25record_2dset_21( x2578, y2579, z2580 ) TSCP x2578, y2579, z2580; { PUSHSTACKTRACE( t3360 ); if ( AND( EQ( TSCPTAG( x2578 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2578 ), RECORDTAG ) ) ) goto L3363; scdebug_error( c2587, c2562, CONS( x2578, EMPTYLIST ) ); L3363: if ( EQ( TSCPTAG( y2579 ), FIXNUMTAG ) ) goto L3365; scdebug_error( c2587, c2155, CONS( y2579, EMPTYLIST ) ); L3365: if ( LT( _S2CUINT( FIXED_C( y2579 ) ), _S2CUINT( RECORD_LENGTH( x2578 ) ) ) ) goto L3367; scdebug_error( c2587, c2159, CONS( y2579, EMPTYLIST ) ); L3367: POPSTACKTRACE( SETGEN( RECORD_ELEMENT( x2578, y2579 ), z2580 ) ); } DEFTSCP( scrt4__25record_2d_3elist_v ); DEFCSTRING( t3369, "%RECORD->LIST" ); TSCP scrt4__25record_2d_3elist( x2594 ) TSCP x2594; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3369 ); if ( AND( EQ( TSCPTAG( x2594 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2594 ), RECORDTAG ) ) ) goto L3373; scdebug_error( c2561, c2562, CONS( x2594, EMPTYLIST ) ); L3373: X2 = C_FIXED( RECORD_LENGTH( x2594 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3376; X1 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3377; L3376: X1 = scrt2__2d_2dtwo( X2, _TSCP( 4 ) ); L3377: X2 = EMPTYLIST; L3378: X2 = CONS( X2, EMPTYLIST ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( -4 ) ) ), 3 ) ) goto L3380; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L3384; POPSTACKTRACE( PAIR_CAR( X2 ) ); L3380: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( -4 ) ) ) ) goto L3384; POPSTACKTRACE( PAIR_CAR( X2 ) ); L3384: if ( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L3389; scdebug_error( c2571, c2155, CONS( X1, EMPTYLIST ) ); L3389: if ( LT( _S2CUINT( FIXED_C( X1 ) ), _S2CUINT( RECORD_LENGTH( x2594 ) ) ) ) goto L3391; scdebug_error( c2571, c2159, CONS( X1, EMPTYLIST ) ); L3391: X4 = RECORD_ELEMENT( x2594, X1 ); X3 = sc_cons( X4, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X3 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3393; X3 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3394; L3393: X3 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); L3394: X2 = PAIR_CAR( X2 ); X1 = X3; GOBACK( L3378 ); } DEFTSCP( scrt4_list_2d_3e_25record_v ); DEFCSTRING( t3395, "LIST->%RECORD" ); EXTERNTSCPP( sc_make_2d_25record, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2d_25record_v ); TSCP scrt4_list_2d_3e_25record( x2637 ) TSCP x2637; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3395 ); X2 = scrt1_length( x2637 ); X1 = sc_make_2d_25record( X2, EMPTYLIST ); X2 = x2637; X3 = _TSCP( 0 ); L3398: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3399; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3403; scrt1__24__car_2derror( X2 ); L3403: X4 = PAIR_CAR( X2 ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), RECORDTAG ) ) ) goto L3406; scdebug_error( c2587, c2562, CONS( X1, EMPTYLIST ) ); L3406: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L3408; scdebug_error( c2587, c2155, CONS( X3, EMPTYLIST ) ); L3408: if ( LT( _S2CUINT( FIXED_C( X3 ) ), _S2CUINT( RECORD_LENGTH( X1 ) ) ) ) goto L3410; scdebug_error( c2587, c2159, CONS( X3, EMPTYLIST ) ); L3410: SETGEN( RECORD_ELEMENT( X1, X3 ), X4 ); X4 = PAIR_CDR( X2 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3413; X3 = _TSCP( IPLUS( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3414; L3413: X3 = scrt2__2b_2dtwo( X3, _TSCP( 4 ) ); L3414: X2 = X4; GOBACK( L3398 ); L3399: POPSTACKTRACE( X1 ); } DEFTSCP( scrt4__25record_2dmethods_v ); DEFCSTRING( t3415, "%RECORD-METHODS" ); TSCP scrt4__25record_2dmethods( x2676 ) TSCP x2676; { PUSHSTACKTRACE( t3415 ); if ( AND( EQ( TSCPTAG( x2676 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2676 ), RECORDTAG ) ) ) goto L3418; scdebug_error( c2681, c2562, CONS( x2676, EMPTYLIST ) ); L3418: POPSTACKTRACE( RECORD_METHODS( x2676 ) ); } DEFTSCP( scrt4_s_2dset_21_fcaf91b1_v ); DEFCSTRING( t3420, "%RECORD-METHODS-SET!" ); TSCP scrt4_s_2dset_21_fcaf91b1( x2683, y2684 ) TSCP x2683, y2684; { PUSHSTACKTRACE( t3420 ); if ( AND( EQ( TSCPTAG( x2683 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2683 ), RECORDTAG ) ) ) goto L3423; scdebug_error( c2587, c2562, CONS( x2683, EMPTYLIST ) ); L3423: POPSTACKTRACE( SETGEN( RECORD_METHODS( x2683 ), y2684 ) ); } DEFTSCP( scrt4_fix_2dchar_c117a402_v ); DEFCSTRING( t3425, "%RECORD-PREFIX-CHAR" ); DEFTSCP( scrt4__25record_2dread_v ); DEFCSTRING( t3426, "%RECORD-READ" ); DEFTSCP( scrt4_p_2dmethod_3ccf392b_v ); DEFCSTRING( t3427, "%RECORD-LOOKUP-METHOD" ); EXTERNTSCPP( scrt1_assq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assq_v ); EXTERNTSCPP( scrt1_memv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memv_v ); EXTERNTSCPP( scrt6_display, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_display_v ); EXTERNTSCPP( scrt3_string, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_v ); TSCP scrt4_l2709( r2710, p2711, i2712, c3440 ) TSCP r2710, p2711, i2712, c3440; { TSCP X2, X1; PUSHSTACKTRACE( "scrt4_l2709 [inside %RECORD-LOOKUP-METHOD]" ); if ( FALSE( scrt4_fix_2dchar_c117a402_v ) ) goto L3442; X2 = CONS( scrt4_fix_2dchar_c117a402_v, EMPTYLIST ); X1 = scrt3_string( CONS( _TSCP( 8978 ), X2 ) ); goto L3443; L3442: X1 = c2713; L3443: scrt6_display( X1, CONS( p2711, EMPTYLIST ) ); X2 = scrt4__25record_2d_3elist( r2710 ); X1 = sc_cons( X2, EMPTYLIST ); POPSTACKTRACE( X1 ); } TSCP scrt4_l2707( x2708, c3449 ) TSCP x2708, c3449; { PUSHSTACKTRACE( "scrt4_l2707 [inside %RECORD-LOOKUP-METHOD]" ); POPSTACKTRACE( x2708 ); } EXTERNTSCPP( scrt1_eq_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_eq_3f_v ); TSCP scrt4_p_2dmethod_3ccf392b( r2692, m2693 ) TSCP r2692, m2693; { TSCP X2, X1; PUSHSTACKTRACE( t3427 ); if ( AND( EQ( TSCPTAG( r2692 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( r2692 ), RECORDTAG ) ) ) goto L3430; scdebug_error( c2681, c2562, CONS( r2692, EMPTYLIST ) ); L3430: X2 = RECORD_METHODS( r2692 ); X1 = scrt1_assq( m2693, X2 ); if ( FALSE( X1 ) ) goto L3433; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3436; scrt1__24__cdr_2derror( X1 ); L3436: POPSTACKTRACE( PAIR_CDR( X1 ) ); L3433: if ( FALSE( scrt1_memv( m2693, c2698 ) ) ) goto L3438; POPSTACKTRACE( MAKEPROCEDURE( 2, 1, scrt4_l2709, EMPTYLIST ) ); L3438: if ( EQ( _S2CUINT( m2693 ), _S2CUINT( c2702 ) ) ) goto L3445; if ( NEQ( _S2CUINT( m2693 ), _S2CUINT( c2706 ) ) ) goto L3447; POPSTACKTRACE( MAKEPROCEDURE( 1, 0, scrt4_l2707, EMPTYLIST ) ); L3447: POPSTACKTRACE( FALSEVALUE ); L3445: POPSTACKTRACE( scrt1_eq_3f_v ); } DEFTSCP( scrt4_c_2dsizeof_2dshort_v ); DEFCSTRING( t3451, "C-SIZEOF-SHORT" ); DEFTSCP( scrt4_c_2dsizeof_2dint_v ); DEFCSTRING( t3452, "C-SIZEOF-INT" ); DEFTSCP( scrt4_c_2dsizeof_2dlong_v ); DEFCSTRING( t3453, "C-SIZEOF-LONG" ); DEFTSCP( scrt4_c_2dsizeof_2dfloat_v ); DEFCSTRING( t3454, "C-SIZEOF-FLOAT" ); DEFTSCP( scrt4_c_2dsizeof_2ddouble_v ); DEFCSTRING( t3455, "C-SIZEOF-DOUBLE" ); DEFTSCP( scrt4_c_2dsizeof_2dtscp_v ); DEFCSTRING( t3456, "C-SIZEOF-TSCP" ); DEFTSCP( scrt4_c_2dsizeof_2ds2cuint_v ); DEFCSTRING( t3457, "C-SIZEOF-S2CUINT" ); DEFTSCP( scrt4_c_2dbyte_2dref_v ); DEFCSTRING( t3458, "C-BYTE-REF" ); TSCP scrt4_c_2dbyte_2dref( s2726, x2727 ) TSCP s2726, x2727; { PUSHSTACKTRACE( t3458 ); POPSTACKTRACE( S2CINT_TSCP( _S2CUINT( MBYTE( TSCP_POINTER( s2726 ), TSCP_S2CINT( x2727 ) ) ) ) ); } DEFTSCP( scrt4_c_2dshortint_2dref_v ); DEFCSTRING( t3460, "C-SHORTINT-REF" ); TSCP scrt4_c_2dshortint_2dref( s2729, x2730 ) TSCP s2729, x2730; { PUSHSTACKTRACE( t3460 ); POPSTACKTRACE( S2CINT_TSCP( _S2CINT( MSINT( TSCP_POINTER( s2729 ), TSCP_S2CINT( x2730 ) ) ) ) ); } DEFTSCP( scrt4_c_2dshortunsigned_2dref_v ); DEFCSTRING( t3462, "C-SHORTUNSIGNED-REF" ); TSCP scrt4_c_2dshortunsigned_2dref( s2732, x2733 ) TSCP s2732, x2733; { PUSHSTACKTRACE( t3462 ); POPSTACKTRACE( S2CUINT_TSCP( _S2CUINT( MSUNSIGNED( TSCP_POINTER( s2732 ), TSCP_S2CINT( x2733 ) ) ) ) ); } DEFTSCP( scrt4_c_2dint_2dref_v ); DEFCSTRING( t3464, "C-INT-REF" ); TSCP scrt4_c_2dint_2dref( s2735, x2736 ) TSCP s2735, x2736; { PUSHSTACKTRACE( t3464 ); POPSTACKTRACE( S2CINT_TSCP( _S2CINT( MINT( TSCP_POINTER( s2735 ), TSCP_S2CINT( x2736 ) ) ) ) ); } DEFTSCP( scrt4_c_2dunsigned_2dref_v ); DEFCSTRING( t3466, "C-UNSIGNED-REF" ); TSCP scrt4_c_2dunsigned_2dref( s2738, x2739 ) TSCP s2738, x2739; { PUSHSTACKTRACE( t3466 ); POPSTACKTRACE( S2CUINT_TSCP( _S2CUINT( MUNSIGNED( TSCP_POINTER( s2738 ), TSCP_S2CINT( x2739 ) ) ) ) ); } DEFTSCP( scrt4_c_2dlongint_2dref_v ); DEFCSTRING( t3468, "C-LONGINT-REF" ); TSCP scrt4_c_2dlongint_2dref( s2741, x2742 ) TSCP s2741, x2742; { PUSHSTACKTRACE( t3468 ); POPSTACKTRACE( S2CINT_TSCP( _S2CINT( MLINT( TSCP_POINTER( s2741 ), TSCP_S2CINT( x2742 ) ) ) ) ); } DEFTSCP( scrt4_c_2dlongunsigned_2dref_v ); DEFCSTRING( t3470, "C-LONGUNSIGNED-REF" ); TSCP scrt4_c_2dlongunsigned_2dref( s2744, x2745 ) TSCP s2744, x2745; { PUSHSTACKTRACE( t3470 ); POPSTACKTRACE( S2CUINT_TSCP( _S2CUINT( MLUNSIGNED( TSCP_POINTER( s2744 ), TSCP_S2CINT( x2745 ) ) ) ) ); } DEFTSCP( scrt4_c_2ds2cuint_2dref_v ); DEFCSTRING( t3472, "C-S2CUINT-REF" ); TSCP scrt4_c_2ds2cuint_2dref( s2747, x2748 ) TSCP s2747, x2748; { PUSHSTACKTRACE( t3472 ); POPSTACKTRACE( S2CUINT_TSCP( MS2CUINT( TSCP_POINTER( s2747 ), TSCP_S2CINT( x2748 ) ) ) ); } DEFTSCP( scrt4_c_2dtscp_2dref_v ); DEFCSTRING( t3474, "C-TSCP-REF" ); TSCP scrt4_c_2dtscp_2dref( s2750, x2751 ) TSCP s2750, x2751; { PUSHSTACKTRACE( t3474 ); POPSTACKTRACE( MTSCP( TSCP_POINTER( s2750 ), TSCP_S2CINT( x2751 ) ) ); } DEFTSCP( scrt4_c_2dfloat_2dref_v ); DEFCSTRING( t3476, "C-FLOAT-REF" ); TSCP scrt4_c_2dfloat_2dref( s2753, x2754 ) TSCP s2753, x2754; { PUSHSTACKTRACE( t3476 ); POPSTACKTRACE( DOUBLE_TSCP( CDOUBLE( MFLOAT( TSCP_POINTER( s2753 ), TSCP_S2CINT( x2754 ) ) ) ) ); } DEFTSCP( scrt4_c_2ddouble_2dref_v ); DEFCSTRING( t3478, "C-DOUBLE-REF" ); TSCP scrt4_c_2ddouble_2dref( s2756, x2757 ) TSCP s2756, x2757; { PUSHSTACKTRACE( t3478 ); POPSTACKTRACE( DOUBLE_TSCP( MDOUBLE( TSCP_POINTER( s2756 ), TSCP_S2CINT( x2757 ) ) ) ); } DEFTSCP( scrt4_c_2dbyte_2dset_21_v ); DEFCSTRING( t3480, "C-BYTE-SET!" ); TSCP scrt4_c_2dbyte_2dset_21( s2759, x2760, v2761 ) TSCP s2759, x2760, v2761; { PUSHSTACKTRACE( t3480 ); SET( MBYTE( TSCP_POINTER( s2759 ), TSCP_S2CINT( x2760 ) ), TSCP_S2CINT( v2761 ) ); POPSTACKTRACE( v2761 ); } DEFTSCP( scrt4_c_2dshortint_2dset_21_v ); DEFCSTRING( t3482, "C-SHORTINT-SET!" ); TSCP scrt4_c_2dshortint_2dset_21( s2763, x2764, v2765 ) TSCP s2763, x2764, v2765; { PUSHSTACKTRACE( t3482 ); SET( MSINT( TSCP_POINTER( s2763 ), TSCP_S2CINT( x2764 ) ), TSCP_S2CINT( v2765 ) ); POPSTACKTRACE( v2765 ); } DEFTSCP( scrt4_d_2dset_21_828269c5_v ); DEFCSTRING( t3484, "C-SHORTUNSIGNED-SET!" ); TSCP scrt4_d_2dset_21_828269c5( s2767, x2768, v2769 ) TSCP s2767, x2768, v2769; { PUSHSTACKTRACE( t3484 ); SET( MSUNSIGNED( TSCP_POINTER( s2767 ), TSCP_S2CINT( x2768 ) ), TSCP_S2CUINT( v2769 ) ); POPSTACKTRACE( v2769 ); } DEFTSCP( scrt4_c_2dint_2dset_21_v ); DEFCSTRING( t3486, "C-INT-SET!" ); TSCP scrt4_c_2dint_2dset_21( s2771, x2772, v2773 ) TSCP s2771, x2772, v2773; { PUSHSTACKTRACE( t3486 ); SET( MINT( TSCP_POINTER( s2771 ), TSCP_S2CINT( x2772 ) ), TSCP_S2CINT( v2773 ) ); POPSTACKTRACE( v2773 ); } DEFTSCP( scrt4_c_2dunsigned_2dset_21_v ); DEFCSTRING( t3488, "C-UNSIGNED-SET!" ); TSCP scrt4_c_2dunsigned_2dset_21( s2775, x2776, v2777 ) TSCP s2775, x2776, v2777; { PUSHSTACKTRACE( t3488 ); SET( MUNSIGNED( TSCP_POINTER( s2775 ), TSCP_S2CINT( x2776 ) ), TSCP_S2CUINT( v2777 ) ); POPSTACKTRACE( v2777 ); } DEFTSCP( scrt4_c_2dlongint_2dset_21_v ); DEFCSTRING( t3490, "C-LONGINT-SET!" ); TSCP scrt4_c_2dlongint_2dset_21( s2779, x2780, v2781 ) TSCP s2779, x2780, v2781; { PUSHSTACKTRACE( t3490 ); SET( MLINT( TSCP_POINTER( s2779 ), TSCP_S2CINT( x2780 ) ), TSCP_S2CINT( v2781 ) ); POPSTACKTRACE( v2781 ); } DEFTSCP( scrt4_d_2dset_21_2e97375c_v ); DEFCSTRING( t3492, "C-LONGUNSIGNED-SET!" ); TSCP scrt4_d_2dset_21_2e97375c( s2783, x2784, v2785 ) TSCP s2783, x2784, v2785; { PUSHSTACKTRACE( t3492 ); SET( MLUNSIGNED( TSCP_POINTER( s2783 ), TSCP_S2CINT( x2784 ) ), TSCP_S2CUINT( v2785 ) ); POPSTACKTRACE( v2785 ); } DEFTSCP( scrt4_c_2ds2cuint_2dset_21_v ); DEFCSTRING( t3494, "C-S2CUINT-SET!" ); TSCP scrt4_c_2ds2cuint_2dset_21( s2787, x2788, v2789 ) TSCP s2787, x2788, v2789; { PUSHSTACKTRACE( t3494 ); SET( MS2CUINT( TSCP_POINTER( s2787 ), TSCP_S2CINT( x2788 ) ), TSCP_S2CUINT( v2789 ) ); POPSTACKTRACE( v2789 ); } DEFTSCP( scrt4_c_2dtscp_2dset_21_v ); DEFCSTRING( t3496, "C-TSCP-SET!" ); TSCP scrt4_c_2dtscp_2dset_21( s2791, x2792, v2793 ) TSCP s2791, x2792, v2793; { PUSHSTACKTRACE( t3496 ); SET( MTSCP( TSCP_POINTER( s2791 ), TSCP_S2CINT( x2792 ) ), v2793 ); POPSTACKTRACE( v2793 ); } DEFTSCP( scrt4_c_2dfloat_2dset_21_v ); DEFCSTRING( t3498, "C-FLOAT-SET!" ); TSCP scrt4_c_2dfloat_2dset_21( s2795, x2796, v2797 ) TSCP s2795, x2796, v2797; { PUSHSTACKTRACE( t3498 ); SET( MFLOAT( TSCP_POINTER( s2795 ), TSCP_S2CINT( x2796 ) ), TSCP_DOUBLE( v2797 ) ); POPSTACKTRACE( v2797 ); } DEFTSCP( scrt4_c_2ddouble_2dset_21_v ); DEFCSTRING( t3500, "C-DOUBLE-SET!" ); TSCP scrt4_c_2ddouble_2dset_21( s2799, x2800, v2801 ) TSCP s2799, x2800, v2801; { PUSHSTACKTRACE( t3500 ); SETMDOUBLE( TSCP_POINTER( s2799 ), TSCP_S2CINT( x2800 ), TSCP_DOUBLE( v2801 ) ); POPSTACKTRACE( v2801 ); } DEFTSCP( scrt4_scheme_2dbyte_2dref_v ); DEFCSTRING( t3502, "SCHEME-BYTE-REF" ); TSCP scrt4_scheme_2dbyte_2dref( s2803, x2804 ) TSCP s2803, x2804; { PUSHSTACKTRACE( t3502 ); if ( BITAND( TSCPTAG( s2803 ), 1 ) ) goto L3504; scdebug_error( c2807, c2808, CONS( s2803, EMPTYLIST ) ); L3504: POPSTACKTRACE( S2CUINT_TSCP( _S2CUINT( MBYTE( T_U( s2803 ), TSCP_S2CINT( x2804 ) ) ) ) ); } DEFTSCP( scrt4_scheme_2dint_2dref_v ); DEFCSTRING( t3506, "SCHEME-INT-REF" ); TSCP scrt4_scheme_2dint_2dref( s2810, x2811 ) TSCP s2810, x2811; { PUSHSTACKTRACE( t3506 ); if ( BITAND( TSCPTAG( s2810 ), 1 ) ) goto L3508; scdebug_error( c2814, c2808, CONS( s2810, EMPTYLIST ) ); L3508: POPSTACKTRACE( S2CINT_TSCP( _S2CINT( MINT( T_U( s2810 ), TSCP_S2CINT( x2811 ) ) ) ) ); } DEFTSCP( scrt4_scheme_2dtscp_2dref_v ); DEFCSTRING( t3510, "SCHEME-TSCP-REF" ); TSCP scrt4_scheme_2dtscp_2dref( s2816, x2817 ) TSCP s2816, x2817; { PUSHSTACKTRACE( t3510 ); if ( BITAND( TSCPTAG( s2816 ), 1 ) ) goto L3512; scdebug_error( c2820, c2808, CONS( s2816, EMPTYLIST ) ); L3512: POPSTACKTRACE( MTSCP( T_U( s2816 ), TSCP_S2CINT( x2817 ) ) ); } DEFTSCP( scrt4_scheme_2ds2cuint_2dref_v ); DEFCSTRING( t3514, "SCHEME-S2CUINT-REF" ); TSCP scrt4_scheme_2ds2cuint_2dref( s2822, x2823 ) TSCP s2822, x2823; { PUSHSTACKTRACE( t3514 ); if ( BITAND( TSCPTAG( s2822 ), 1 ) ) goto L3516; scdebug_error( c2826, c2808, CONS( s2822, EMPTYLIST ) ); L3516: POPSTACKTRACE( S2CUINT_TSCP( MS2CUINT( T_U( s2822 ), TSCP_S2CINT( x2823 ) ) ) ); } DEFTSCP( scrt4_scheme_2dbyte_2dset_21_v ); DEFCSTRING( t3518, "SCHEME-BYTE-SET!" ); TSCP scrt4_scheme_2dbyte_2dset_21( s2828, x2829, v2830 ) TSCP s2828, x2829, v2830; { PUSHSTACKTRACE( t3518 ); if ( BITAND( TSCPTAG( s2828 ), 1 ) ) goto L3520; scdebug_error( c2833, c2808, CONS( s2828, EMPTYLIST ) ); L3520: SET( MBYTE( T_U( s2828 ), TSCP_S2CINT( x2829 ) ), TSCP_S2CINT( v2830 ) ); POPSTACKTRACE( v2830 ); } DEFTSCP( scrt4_scheme_2dint_2dset_21_v ); DEFCSTRING( t3522, "SCHEME-INT-SET!" ); TSCP scrt4_scheme_2dint_2dset_21( s2835, x2836, v2837 ) TSCP s2835, x2836, v2837; { PUSHSTACKTRACE( t3522 ); if ( BITAND( TSCPTAG( s2835 ), 1 ) ) goto L3524; scdebug_error( c2840, c2808, CONS( s2835, EMPTYLIST ) ); L3524: SET( MINT( T_U( s2835 ), TSCP_S2CINT( x2836 ) ), TSCP_S2CINT( v2837 ) ); POPSTACKTRACE( v2837 ); } DEFTSCP( scrt4_scheme_2dtscp_2dset_21_v ); DEFCSTRING( t3526, "SCHEME-TSCP-SET!" ); TSCP scrt4_scheme_2dtscp_2dset_21( s2842, x2843, v2844 ) TSCP s2842, x2843, v2844; { PUSHSTACKTRACE( t3526 ); if ( BITAND( TSCPTAG( s2842 ), 1 ) ) goto L3528; scdebug_error( c2847, c2808, CONS( s2842, EMPTYLIST ) ); L3528: SETGENTL( MTSCP( T_U( s2842 ), TSCP_S2CINT( x2843 ) ), v2844 ); POPSTACKTRACE( v2844 ); } DEFTSCP( scrt4_t_2dset_21_925753db_v ); DEFCSTRING( t3530, "SCHEME-S2CUINT-SET!" ); TSCP scrt4_t_2dset_21_925753db( s2849, x2850, v2851 ) TSCP s2849, x2850, v2851; { PUSHSTACKTRACE( t3530 ); if ( BITAND( TSCPTAG( s2849 ), 1 ) ) goto L3532; scdebug_error( c2854, c2808, CONS( s2849, EMPTYLIST ) ); L3532: SET( MS2CUINT( T_U( s2849 ), TSCP_S2CINT( x2850 ) ), TSCP_S2CUINT( v2851 ) ); POPSTACKTRACE( v2851 ); } DEFTSCP( scrt4_bit_2dand_v ); DEFCSTRING( t3534, "BIT-AND" ); TSCP scrt4_bit_2dand( x2856, y2857 ) TSCP x2856, y2857; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3534 ); X1 = x2856; X2 = y2857; L3537: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3538; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3541; scrt1__24__car_2derror( X2 ); L3541: X4 = PAIR_CAR( X2 ); X3 = S2CUINT_TSCP( BITAND32( TSCP_S2CUINT( X4 ), TSCP_S2CUINT( X1 ) ) ); X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L3537 ); L3538: POPSTACKTRACE( X1 ); } DEFTSCP( scrt4_bit_2dor_v ); DEFCSTRING( t3544, "BIT-OR" ); TSCP scrt4_bit_2dor( x2880, y2881 ) TSCP x2880, y2881; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3544 ); X1 = x2880; X2 = y2881; L3547: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3548; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3551; scrt1__24__car_2derror( X2 ); L3551: X4 = PAIR_CAR( X2 ); X3 = S2CUINT_TSCP( BITOR32( TSCP_S2CUINT( X4 ), TSCP_S2CUINT( X1 ) ) ); X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L3547 ); L3548: POPSTACKTRACE( X1 ); } DEFTSCP( scrt4_bit_2dnot_v ); DEFCSTRING( t3554, "BIT-NOT" ); EXTERNTSCPP( scrt4_bit_2dxor, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2dxor_v ); TSCP scrt4_bit_2dnot( x2904 ) TSCP x2904; { PUSHSTACKTRACE( t3554 ); POPSTACKTRACE( scrt4_bit_2dxor( x2904, CONS( _TSCP( -4 ), EMPTYLIST ) ) ); } DEFTSCP( scrt4_bit_2dxor_v ); DEFCSTRING( t3556, "BIT-XOR" ); TSCP scrt4_bit_2dxor( x2906, y2907 ) TSCP x2906, y2907; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3556 ); X1 = x2906; X2 = y2907; L3559: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3560; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3563; scrt1__24__car_2derror( X2 ); L3563: X4 = PAIR_CAR( X2 ); X3 = S2CUINT_TSCP( BITXOR32( TSCP_S2CUINT( X4 ), TSCP_S2CUINT( X1 ) ) ); X2 = PAIR_CDR( X2 ); X1 = X3; GOBACK( L3559 ); L3560: POPSTACKTRACE( X1 ); } DEFTSCP( scrt4_bit_2dlsh_v ); DEFCSTRING( t3566, "BIT-LSH" ); TSCP scrt4_bit_2dlsh( x2930, y2931 ) TSCP x2930, y2931; { PUSHSTACKTRACE( t3566 ); POPSTACKTRACE( S2CUINT_TSCP( BITLSH32( TSCP_S2CUINT( x2930 ), TSCP_S2CUINT( y2931 ) ) ) ); } DEFTSCP( scrt4_bit_2drsh_v ); DEFCSTRING( t3568, "BIT-RSH" ); TSCP scrt4_bit_2drsh( x2933, y2934 ) TSCP x2933, y2934; { PUSHSTACKTRACE( t3568 ); POPSTACKTRACE( S2CUINT_TSCP( BITRSH32( TSCP_S2CUINT( x2933 ), TSCP_S2CUINT( y2934 ) ) ) ); } DEFTSCP( scrt4_when_2dunreferenced_v ); DEFCSTRING( t3570, "WHEN-UNREFERENCED" ); EXTERNTSCP( sc_whenfreed ); EXTERNTSCPP( scrt1_remq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_remq_v ); TSCP scrt4_when_2dunreferenced( o2936, p2937 ) TSCP o2936, p2937; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3570 ); if ( FALSE( p2937 ) ) goto L3574; if ( AND( EQ( TSCPTAG( p2937 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( p2937 ), PROCEDURETAG ) ) ) goto L3574; scdebug_error( c2944, c2945, CONS( p2937, EMPTYLIST ) ); L3574: X1 = scrt1_assq( o2936, sc_whenfreed ); if ( FALSE( X1 ) ) goto L3577; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3580; scrt1__24__cdr_2derror( X1 ); L3580: X2 = PAIR_CDR( X1 ); goto L3578; L3577: X2 = X1; L3578: if ( FALSE( p2937 ) ) goto L3583; if ( FALSE( X1 ) ) goto L3585; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3588; scdebug_error( c2469, c2470, CONS( X1, EMPTYLIST ) ); L3588: SETGEN( PAIR_CDR( X1 ), p2937 ); goto L3590; L3585: X3 = sc_cons( o2936, p2937 ); sc_whenfreed = sc_cons( X3, sc_whenfreed ); goto L3590; L3583: if ( FALSE( X1 ) ) goto L3590; sc_whenfreed = scrt1_remq( X1, sc_whenfreed ); L3590: POPSTACKTRACE( X2 ); } DEFTSCP( scrt4_sc__whenfreed_v ); DEFCSTRING( t3592, "SCRT4_SC_WHENFREED" ); TSCP scrt4_sc__whenfreed( ) { PUSHSTACKTRACE( t3592 ); POPSTACKTRACE( sc_whenfreed ); } DEFTSCP( scrt4_signals_v ); DEFCSTRING( t3594, "SCRT4_SIGNALS" ); DEFTSCP( scrt4_signal_v ); DEFCSTRING( t3595, "SIGNAL" ); EXTERNTSCPP( scrt2_negative_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_negative_3f_v ); EXTERNTSCPP( scrt2__3e_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_3d_2dtwo_v ); EXTERNTSCPP( sc_ossignal, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_ossignal_v ); TSCP scrt4_signal( s2968, h2969 ) TSCP s2968, h2969; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3595 ); if ( NEQ( TSCPTAG( s2968 ), FIXNUMTAG ) ) goto L3597; X1 = BOOLEAN( LT( _S2CINT( s2968 ), 0 ) ); goto L3598; L3597: X1 = scrt2_negative_3f( s2968 ); L3598: if ( TRUE( X1 ) ) goto L3603; X3 = scrt4_signals_v; if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), VECTORTAG ) ) ) goto L3605; scdebug_error( c2142, c2143, CONS( X3, EMPTYLIST ) ); L3605: X2 = C_FIXED( VECTOR_LENGTH( X3 ) ); if ( BITAND( BITOR( _S2CINT( s2968 ), _S2CINT( X2 ) ), 3 ) ) goto L3609; if ( GTE( _S2CINT( s2968 ), _S2CINT( X2 ) ) ) goto L3603; goto L3616; L3609: if ( FALSE( scrt2__3e_3d_2dtwo( s2968, X2 ) ) ) goto L3616; L3603: scdebug_error( c2990, c2991, CONS( s2968, EMPTYLIST ) ); L3616: if ( AND( EQ( TSCPTAG( h2969 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( h2969 ), PROCEDURETAG ) ) ) goto L3621; if ( EQ( TSCPTAG( h2969 ), FIXNUMTAG ) ) goto L3621; if ( AND( EQ( TSCPTAG( h2969 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( h2969 ), DOUBLEFLOATTAG ) ) ) goto L3621; scdebug_error( c2990, c3008, CONS( h2969, EMPTYLIST ) ); L3621: X2 = scrt4_signals_v; if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), VECTORTAG ) ) ) goto L3624; scdebug_error( c2152, c2143, CONS( X2, EMPTYLIST ) ); L3624: if ( EQ( TSCPTAG( s2968 ), FIXNUMTAG ) ) goto L3626; scdebug_error( c2152, c2155, CONS( s2968, EMPTYLIST ) ); L3626: if ( LT( _S2CUINT( FIXED_C( s2968 ) ), _S2CUINT( VECTOR_LENGTH( X2 ) ) ) ) goto L3628; scdebug_error( c2152, c2159, CONS( s2968, EMPTYLIST ) ); L3628: X1 = VECTOR_ELEMENT( X2, s2968 ); X2 = scrt4_signals_v; if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), VECTORTAG ) ) ) goto L3632; scdebug_error( c2170, c2143, CONS( X2, EMPTYLIST ) ); L3632: if ( LT( _S2CUINT( FIXED_C( s2968 ) ), _S2CUINT( VECTOR_LENGTH( X2 ) ) ) ) goto L3634; scdebug_error( c2170, c2159, CONS( s2968, EMPTYLIST ) ); L3634: SETGEN( VECTOR_ELEMENT( X2, s2968 ), h2969 ); if ( NEQ( TSCPTAG( h2969 ), FIXNUMTAG ) ) goto L3636; X3 = h2969; goto L3639; L3636: if ( NOT( AND( EQ( TSCPTAG( h2969 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( h2969 ), DOUBLEFLOATTAG ) ) ) ) goto L3638; X3 = h2969; goto L3639; L3638: X3 = TRUEVALUE; L3639: X2 = sc_ossignal( s2968, X3 ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), PROCEDURETAG ) ) ) goto L3641; POPSTACKTRACE( X2 ); L3641: POPSTACKTRACE( X1 ); } DEFTSCP( scrt4_callsignalhandler_v ); DEFCSTRING( t3643, "SCRT4_CALLSIGNALHANDLER" ); TSCP scrt4_callsignalhandler( s3048 ) TSCP s3048; { TSCP X2, X1; PUSHSTACKTRACE( t3643 ); X2 = scrt4_signals_v; if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), VECTORTAG ) ) ) goto L3646; scdebug_error( c2152, c2143, CONS( X2, EMPTYLIST ) ); L3646: if ( EQ( TSCPTAG( s3048 ), FIXNUMTAG ) ) goto L3648; scdebug_error( c2152, c2155, CONS( s3048, EMPTYLIST ) ); L3648: if ( LT( _S2CUINT( FIXED_C( s3048 ) ), _S2CUINT( VECTOR_LENGTH( X2 ) ) ) ) goto L3650; scdebug_error( c2152, c2159, CONS( s3048, EMPTYLIST ) ); L3650: X1 = VECTOR_ELEMENT( X2, s3048 ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( s3048, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt4_system_v ); DEFCSTRING( t3652, "SYSTEM" ); EXTERNTSCPP( sc_ossystem, XAL1( TSCP ) ); EXTERNTSCP( sc_ossystem_v ); TSCP scrt4_system( c3060 ) TSCP c3060; { PUSHSTACKTRACE( t3652 ); if ( AND( EQ( TSCPTAG( c3060 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c3060 ), STRINGTAG ) ) ) goto L3654; scdebug_error( c3063, c3064, CONS( c3060, EMPTYLIST ) ); L3654: POPSTACKTRACE( sc_ossystem( c3060 ) ); } void scrt3__init(); void scrt6__init(); void scrt5__init(); void scrt1__init(); void scrt2__init(); void scdebug__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt3__init(); scrt6__init(); scrt5__init(); scrt1__init(); scrt2__init(); scdebug__init(); MAXDISPLAY( 3 ); } void scrt4__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scrt4 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3129, ADR( scrt4_vector_3f_v ), MAKEPROCEDURE( 1, 0, scrt4_vector_3f, EMPTYLIST ) ); INITIALIZEVAR( t3131, ADR( scrt4_vector_v ), MAKEPROCEDURE( 0, 1, scrt4_vector, EMPTYLIST ) ); INITIALIZEVAR( t3133, ADR( scrt4_vector_2dlength_v ), MAKEPROCEDURE( 1, 0, scrt4_vector_2dlength, EMPTYLIST ) ); INITIALIZEVAR( t3138, ADR( scrt4_vector_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_vector_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3147, ADR( scrt4_vector_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_vector_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3156, ADR( scrt4_vector_2d_3elist_v ), MAKEPROCEDURE( 1, 0, scrt4_vector_2d_3elist, EMPTYLIST ) ); INITIALIZEVAR( t3182, ADR( scrt4_list_2d_3evector_v ), MAKEPROCEDURE( 1, 0, scrt4_list_2d_3evector, EMPTYLIST ) ); INITIALIZEVAR( t3202, ADR( scrt4_vector_2dfill_21_v ), MAKEPROCEDURE( 2, 0, scrt4_vector_2dfill_21, EMPTYLIST ) ); INITIALIZEVAR( t3228, ADR( scrt4_procedure_3f_v ), MAKEPROCEDURE( 1, 0, scrt4_procedure_3f, EMPTYLIST ) ); INITIALIZEVAR( t3230, ADR( scrt4_apply_v ), MAKEPROCEDURE( 2, 1, scrt4_apply, EMPTYLIST ) ); INITIALIZEVAR( t3244, ADR( scrt4_map_v ), MAKEPROCEDURE( 2, 1, scrt4_map, EMPTYLIST ) ); INITIALIZEVAR( t3279, ADR( scrt4_for_2deach_v ), MAKEPROCEDURE( 2, 1, scrt4_for_2deach, EMPTYLIST ) ); INITIALIZEVAR( t3321, ADR( scrt4_force_v ), MAKEPROCEDURE( 1, 0, scrt4_force, EMPTYLIST ) ); INITIALIZEVAR( t3323, ADR( scrt4_make_2dpromise_v ), MAKEPROCEDURE( 1, 0, scrt4_make_2dpromise, EMPTYLIST ) ); INITIALIZEVAR( t3331, ADR( scrt4_catch_2derror_v ), MAKEPROCEDURE( 1, 0, scrt4_catch_2derror, EMPTYLIST ) ); INITIALIZEVAR( t3342, ADR( scrt4__25record_3f_v ), MAKEPROCEDURE( 1, 0, scrt4__25record_3f, EMPTYLIST ) ); INITIALIZEVAR( t3344, ADR( scrt4__25record_v ), MAKEPROCEDURE( 0, 1, scrt4__25record, EMPTYLIST ) ); INITIALIZEVAR( t3346, ADR( scrt4__25record_2dlength_v ), MAKEPROCEDURE( 1, 0, scrt4__25record_2dlength, EMPTYLIST ) ); INITIALIZEVAR( t3351, ADR( scrt4__25record_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4__25record_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3360, ADR( scrt4__25record_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4__25record_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3369, ADR( scrt4__25record_2d_3elist_v ), MAKEPROCEDURE( 1, 0, scrt4__25record_2d_3elist, EMPTYLIST ) ); INITIALIZEVAR( t3395, ADR( scrt4_list_2d_3e_25record_v ), MAKEPROCEDURE( 1, 0, scrt4_list_2d_3e_25record, EMPTYLIST ) ); INITIALIZEVAR( t3415, ADR( scrt4__25record_2dmethods_v ), MAKEPROCEDURE( 1, 0, scrt4__25record_2dmethods, EMPTYLIST ) ); INITIALIZEVAR( t3420, ADR( scrt4_s_2dset_21_fcaf91b1_v ), MAKEPROCEDURE( 2, 0, scrt4_s_2dset_21_fcaf91b1, EMPTYLIST ) ); INITIALIZEVAR( t3425, ADR( scrt4_fix_2dchar_c117a402_v ), FALSEVALUE ); INITIALIZEVAR( t3426, ADR( scrt4__25record_2dread_v ), FALSEVALUE ); INITIALIZEVAR( t3427, ADR( scrt4_p_2dmethod_3ccf392b_v ), MAKEPROCEDURE( 2, 0, scrt4_p_2dmethod_3ccf392b, EMPTYLIST ) ); INITIALIZEVAR( t3451, ADR( scrt4_c_2dsizeof_2dshort_v ), C_FIXED( SIZEOF( short ) ) ); INITIALIZEVAR( t3452, ADR( scrt4_c_2dsizeof_2dint_v ), C_FIXED( SIZEOF( int ) ) ); INITIALIZEVAR( t3453, ADR( scrt4_c_2dsizeof_2dlong_v ), C_FIXED( SIZEOF( long ) ) ); INITIALIZEVAR( t3454, ADR( scrt4_c_2dsizeof_2dfloat_v ), C_FIXED( SIZEOF( float ) ) ); INITIALIZEVAR( t3455, ADR( scrt4_c_2dsizeof_2ddouble_v ), C_FIXED( SIZEOF( double ) ) ); INITIALIZEVAR( t3456, ADR( scrt4_c_2dsizeof_2dtscp_v ), C_FIXED( SIZEOF( TSCP ) ) ); INITIALIZEVAR( t3457, ADR( scrt4_c_2dsizeof_2ds2cuint_v ), C_FIXED( SIZEOF( S2CUINT ) ) ); INITIALIZEVAR( t3458, ADR( scrt4_c_2dbyte_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dbyte_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3460, ADR( scrt4_c_2dshortint_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dshortint_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3462, ADR( scrt4_c_2dshortunsigned_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dshortunsigned_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3464, ADR( scrt4_c_2dint_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dint_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3466, ADR( scrt4_c_2dunsigned_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dunsigned_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3468, ADR( scrt4_c_2dlongint_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dlongint_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3470, ADR( scrt4_c_2dlongunsigned_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dlongunsigned_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3472, ADR( scrt4_c_2ds2cuint_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2ds2cuint_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3474, ADR( scrt4_c_2dtscp_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dtscp_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3476, ADR( scrt4_c_2dfloat_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2dfloat_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3478, ADR( scrt4_c_2ddouble_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_c_2ddouble_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3480, ADR( scrt4_c_2dbyte_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2dbyte_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3482, ADR( scrt4_c_2dshortint_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2dshortint_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3484, ADR( scrt4_d_2dset_21_828269c5_v ), MAKEPROCEDURE( 3, 0, scrt4_d_2dset_21_828269c5, EMPTYLIST ) ); INITIALIZEVAR( t3486, ADR( scrt4_c_2dint_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2dint_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3488, ADR( scrt4_c_2dunsigned_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2dunsigned_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3490, ADR( scrt4_c_2dlongint_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2dlongint_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3492, ADR( scrt4_d_2dset_21_2e97375c_v ), MAKEPROCEDURE( 3, 0, scrt4_d_2dset_21_2e97375c, EMPTYLIST ) ); INITIALIZEVAR( t3494, ADR( scrt4_c_2ds2cuint_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2ds2cuint_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3496, ADR( scrt4_c_2dtscp_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2dtscp_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3498, ADR( scrt4_c_2dfloat_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2dfloat_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3500, ADR( scrt4_c_2ddouble_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_c_2ddouble_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3502, ADR( scrt4_scheme_2dbyte_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_scheme_2dbyte_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3506, ADR( scrt4_scheme_2dint_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_scheme_2dint_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3510, ADR( scrt4_scheme_2dtscp_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_scheme_2dtscp_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3514, ADR( scrt4_scheme_2ds2cuint_2dref_v ), MAKEPROCEDURE( 2, 0, scrt4_scheme_2ds2cuint_2dref, EMPTYLIST ) ); INITIALIZEVAR( t3518, ADR( scrt4_scheme_2dbyte_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_scheme_2dbyte_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3522, ADR( scrt4_scheme_2dint_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_scheme_2dint_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3526, ADR( scrt4_scheme_2dtscp_2dset_21_v ), MAKEPROCEDURE( 3, 0, scrt4_scheme_2dtscp_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3530, ADR( scrt4_t_2dset_21_925753db_v ), MAKEPROCEDURE( 3, 0, scrt4_t_2dset_21_925753db, EMPTYLIST ) ); INITIALIZEVAR( t3534, ADR( scrt4_bit_2dand_v ), MAKEPROCEDURE( 1, 1, scrt4_bit_2dand, EMPTYLIST ) ); INITIALIZEVAR( t3544, ADR( scrt4_bit_2dor_v ), MAKEPROCEDURE( 1, 1, scrt4_bit_2dor, EMPTYLIST ) ); INITIALIZEVAR( t3554, ADR( scrt4_bit_2dnot_v ), MAKEPROCEDURE( 1, 0, scrt4_bit_2dnot, EMPTYLIST ) ); INITIALIZEVAR( t3556, ADR( scrt4_bit_2dxor_v ), MAKEPROCEDURE( 1, 1, scrt4_bit_2dxor, EMPTYLIST ) ); INITIALIZEVAR( t3566, ADR( scrt4_bit_2dlsh_v ), MAKEPROCEDURE( 2, 0, scrt4_bit_2dlsh, EMPTYLIST ) ); INITIALIZEVAR( t3568, ADR( scrt4_bit_2drsh_v ), MAKEPROCEDURE( 2, 0, scrt4_bit_2drsh, EMPTYLIST ) ); INITIALIZEVAR( t3570, ADR( scrt4_when_2dunreferenced_v ), MAKEPROCEDURE( 2, 0, scrt4_when_2dunreferenced, EMPTYLIST ) ); INITIALIZEVAR( t3592, ADR( scrt4_sc__whenfreed_v ), MAKEPROCEDURE( 0, 0, scrt4_sc__whenfreed, EMPTYLIST ) ); INITIALIZEVAR( t3594, ADR( scrt4_signals_v ), sc_make_2dvector( _TSCP( 128 ), CONS( FALSEVALUE, EMPTYLIST ) ) ); INITIALIZEVAR( t3595, ADR( scrt4_signal_v ), MAKEPROCEDURE( 2, 0, scrt4_signal, EMPTYLIST ) ); INITIALIZEVAR( t3643, ADR( scrt4_callsignalhandler_v ), MAKEPROCEDURE( 1, 0, scrt4_callsignalhandler, EMPTYLIST ) ); INITIALIZEVAR( t3652, ADR( scrt4_system_v ), MAKEPROCEDURE( 1, 0, scrt4_system, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/scrt4.sc000066400000000000000000000345031203736146400161470ustar00rootroot00000000000000;;; SCHEME->C Runtime Library ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scrt4 (top-level VECTOR? VECTOR VECTOR-LENGTH VECTOR-REF VECTOR-SET! VECTOR->LIST LIST->VECTOR VECTOR-FILL! PROCEDURE? APPLY MAP FOR-EACH FORCE MAKE-PROMISE CATCH-ERROR %RECORD? %RECORD %RECORD-LENGTH %RECORD-REF %RECORD-SET! %RECORD->LIST LIST->%RECORD %RECORD-METHODS %RECORD-METHODS-SET! %RECORD-PREFIX-CHAR %RECORD-READ %RECORD-LOOKUP-METHOD C-SIZEOF-SHORT C-SIZEOF-INT C-SIZEOF-LONG C-SIZEOF-FLOAT C-SIZEOF-DOUBLE C-SIZEOF-TSCP C-SIZEOF-S2CUINT C-BYTE-REF C-SHORTINT-REF C-SHORTUNSIGNED-REF C-INT-REF C-UNSIGNED-REF C-LONGINT-REF C-LONGUNSIGNED-REF C-S2CUINT-REF C-TSCP-REF C-FLOAT-REF C-DOUBLE-REF C-BYTE-SET! C-SHORTINT-SET! C-SHORTUNSIGNED-SET! C-INT-SET! C-UNSIGNED-SET! C-LONGINT-SET! C-LONGUNSIGNED-SET! C-S2CUINT-SET! C-TSCP-SET! C-FLOAT-SET! C-DOUBLE-SET! SCHEME-BYTE-REF SCHEME-INT-REF SCHEME-TSCP-REF SCHEME-S2CUINT-REF SCHEME-BYTE-SET! SCHEME-INT-SET! SCHEME-TSCP-SET! SCHEME-S2CUINT-SET! BIT-AND BIT-OR BIT-NOT BIT-XOR BIT-LSH BIT-RSH WHEN-UNREFERENCED SIGNAL SYSTEM)) (include "repdef.sc") ;;; 6.8 Vectors. (define (VECTOR? x) (vector? x)) (define (VECTOR . x) (list->vector x)) (define (VECTOR-LENGTH x) (vector-length x)) (define (VECTOR-REF x y) (vector-ref x y)) (define (VECTOR-SET! x y z) (vector-set! x y z)) (define (VECTOR->LIST x) (do ((i (- (vector-length x) 1) (- i 1)) (l '())) ((= i -1) l) (set! l (cons (vector-ref x i) l)))) (define (LIST->VECTOR x) (do ((v (make-vector (length x))) (x x (cdr x)) (i 0 (+ i 1))) ((null? x) v) (vector-set! v i (car x)))) (define (VECTOR-FILL! v x) (do ((i (- (vector-length v) 1) (- i 1))) ((= i -1) v) (vector-set! v i x))) ;;; 6.9 Control features. (define (PROCEDURE? x) (procedure? x)) (define (APPLY proc args . opt) (if opt (apply-two proc (cons args (let loop ((opt opt)) (if (cdr opt) (cons (car opt) (loop (cdr opt))) (car opt))))) (apply-two proc args))) ;;; This original definition of MAP doesn't work if F is nondeterministic. ;(define (MAP proc args . opt) ; (let loop ((args (cons args opt)) (head '()) (tail '())) ; (if (not (null? (car args))) ; (let ((val (cons (apply proc (map car args)) '()))) ; (if (null? head) ; (loop (map cdr args) val val) ; (loop (map cdr args) head (set-cdr! tail val)))) ; head))) ;;; This one does. It is less efficient though. --- Qobi R6Mar97 (define (map f x . &rest) (define (map-car x) (let loop ((x x) (c '())) (if (null? x) (reverse c) (loop (cdr x) (cons (caar x) c))))) (define (map-cdr x) (let loop ((x x) (c '())) (if (null? x) (reverse c) (loop (cdr x) (cons (cdar x) c))))) (let loop ((l (cons x &rest)) (c '())) (if (null? (car l)) (reverse c) (loop (map-cdr l) (cons (apply f (map-car l)) c))))) (define (FOR-EACH proc args . opt) (do ((args (cons args opt) (map cdr args))) ((null? (car args))) (apply proc (map car args)))) (define (FORCE object) (object)) (define (MAKE-PROMISE proc) (let ((already-run? #f) (result #f)) (lambda () (unless already-run? (set! result (proc)) (set! already-run? #t)) result))) (define (CATCH-ERROR proc) (let* ((old-error-handler *error-handler*) (result (call-with-current-continuation (lambda (return) (define (ERROR id format-string . args) (let ((port (open-output-string))) (set! *error-handler* old-error-handler) (format port "***** ~a " id) (apply format port format-string args) (return (get-output-string port)))) (set! *error-handler* error) (list (proc)))))) (set! *error-handler* old-error-handler) result)) ;;; *.* Records. (define (%RECORD? x) (%record? x)) (define (%RECORD . x) (list->%record x)) (define (%RECORD-LENGTH x) (%record-length x)) (define (%RECORD-REF x y) (%record-ref x y)) (define (%RECORD-SET! x y z) (%record-set! x y z)) (define (%RECORD->LIST x) (do ((i (- (%record-length x) 1) (- i 1)) (l '())) ((= i -1) l) (set! l (cons (%record-ref x i) l)))) (define (LIST->%RECORD x) (do ((r (make-%record (length x))) (x x (cdr x)) (i 0 (+ i 1))) ((null? x) r) (%record-set! r i (car x)))) (define (%RECORD-METHODS x) (%record-methods x)) (define (%RECORD-METHODS-SET! x y) (%record-methods-set! x y)) (define %RECORD-PREFIX-CHAR #f) (define %RECORD-READ #f) (define (%RECORD-LOOKUP-METHOD record method-name) (let ((name-method (assq method-name (%record-methods record)))) (if name-method (cdr name-method) (case method-name ((%to-write %to-display) (lambda (record port . ignore) (display (if %record-prefix-char (string #\# %record-prefix-char) "#~") port) (list (%record->list record)))) ((%to-equal?) eq?) ((%to-eval) (lambda (x) x)) (else #f))))) ;;; *.* Functions to access C structures. Use at your own risk! (define C-SIZEOF-SHORT ((lap () (C_FIXED (sizeof "short"))))) (define C-SIZEOF-INT ((lap () (C_FIXED (sizeof "int"))))) (define C-SIZEOF-LONG ((lap () (C_FIXED (sizeof "long"))))) (define C-SIZEOF-FLOAT ((lap () (C_FIXED (sizeof "float"))))) (define C-SIZEOF-DOUBLE ((lap () (C_FIXED (sizeof "double"))))) (define C-SIZEOF-TSCP ((lap () (C_FIXED (sizeof "TSCP"))))) (define C-SIZEOF-S2CUINT ((lap () (C_FIXED (sizeof "S2CUINT"))))) (define (C-BYTE-REF struct x) ((lap (struct x) (S2CINT_TSCP (_S2CUINT (MBYTE (TSCP_POINTER struct) (TSCP_S2CINT x))))) struct x)) (define (C-SHORTINT-REF struct x) ((lap (struct x) (S2CINT_TSCP (_S2CINT (MSINT (TSCP_POINTER struct) (TSCP_S2CINT x))))) struct x)) (define (C-SHORTUNSIGNED-REF struct x) ((lap (struct x) (S2CUINT_TSCP (_S2CUINT (MSUNSIGNED (TSCP_POINTER struct) (TSCP_S2CINT x))))) struct x)) (define (C-INT-REF struct x) ((lap (struct x) (S2CINT_TSCP (_S2CINT (MINT (TSCP_POINTER struct) (TSCP_S2CINT x))))) struct x)) (define (C-UNSIGNED-REF struct x) ((lap (struct x) (S2CUINT_TSCP (_S2CUINT (MUNSIGNED (TSCP_POINTER struct) (TSCP_S2CINT x))))) struct x)) (define (C-LONGINT-REF struct x) ((lap (struct x) (S2CINT_TSCP (_S2CINT (MLINT (TSCP_POINTER struct) (TSCP_S2CINT x))))) struct x)) (define (C-LONGUNSIGNED-REF struct x) ((lap (struct x) (S2CUINT_TSCP (_S2CUINT (MLUNSIGNED (TSCP_POINTER struct) (TSCP_S2CINT x))))) struct x)) (define (C-S2CUINT-REF struct x) ((lap (struct x) (S2CUINT_TSCP (MS2CUINT (TSCP_POINTER struct) (TSCP_S2CINT x)))) struct x)) (define (C-TSCP-REF struct x) ((lap (struct x) (MTSCP (TSCP_POINTER struct) (TSCP_S2CINT x))) struct x)) (define (C-FLOAT-REF struct x) ((lap (struct x) (DOUBLE_TSCP (CDOUBLE (MFLOAT (TSCP_POINTER struct) (TSCP_S2CINT x))))) struct x)) (define (C-DOUBLE-REF struct x) ((lap (struct x) (DOUBLE_TSCP (MDOUBLE (TSCP_POINTER struct) (TSCP_S2CINT x)))) struct x)) (define (C-BYTE-SET! struct x v) ((lap (struct x v) (SET (MBYTE (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_S2CINT v))) struct x v) v) (define (C-SHORTINT-SET! struct x v) ((lap (struct x v) (SET (MSINT (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_S2CINT v))) struct x v) v) (define (C-SHORTUNSIGNED-SET! struct x v) ((lap (struct x v) (SET (MSUNSIGNED (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_S2CUINT v))) struct x v) v) (define (C-INT-SET! struct x v) ((lap (struct x v) (SET (MINT (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_S2CINT v))) struct x v) v) (define (C-UNSIGNED-SET! struct x v) ((lap (struct x v) (SET (MUNSIGNED (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_S2CUINT v))) struct x v) v) (define (C-LONGINT-SET! struct x v) ((lap (struct x v) (SET (MLINT (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_S2CINT v))) struct x v) v) (define (C-LONGUNSIGNED-SET! struct x v) ((lap (struct x v) (SET (MLUNSIGNED (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_S2CUINT v))) struct x v) v) (define (C-S2CUINT-SET! struct x v) ((lap (struct x v) (SET (MS2CUINT (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_S2CUINT v))) struct x v) v) (define (C-TSCP-SET! struct x v) ((lap (struct x v) (SET (MTSCP (TSCP_POINTER struct) (TSCP_S2CINT x)) v)) struct x v) v) (define (C-FLOAT-SET! struct x v) ((lap (struct x v) (SET (MFLOAT (TSCP_POINTER struct) (TSCP_S2CINT x)) (TSCP_DOUBLE v))) struct x v) v) (define (C-DOUBLE-SET! struct x v) ((lap (struct x v) (SETMDOUBLE (TSCP_POINTER struct) (TSCP_S2CINT x) (TSCP_DOUBLE v))) struct x v) v) ;;; *.* Functions to access Scheme structures. Use at your own risk! (define-in-line (SCHEME-PTR? x) ((lap (x) (BOOLEAN (BITAND (TSCPTAG x) 1))) x)) (define (SCHEME-BYTE-REF struct x) (if (not (scheme-ptr? struct)) (error 'SCHEME-BYTE-REF "Structure is not a SCHEME pointer: ~s" struct)) ((lap (struct x) (S2CUINT_TSCP (_S2CUINT (MBYTE (T_U struct) (TSCP_S2CINT x))))) struct x)) (define (SCHEME-INT-REF struct x) (if (not (scheme-ptr? struct)) (error 'SCHEME-INT-REF "Structure is not a SCHEME pointer: ~s" struct)) ((lap (struct x) (S2CINT_TSCP (_S2CINT (MINT (T_U struct) (TSCP_S2CINT x))))) struct x)) (define (SCHEME-TSCP-REF struct x) (if (not (scheme-ptr? struct)) (error 'SCHEME-TSCP-REF "Structure is not a SCHEME pointer: ~s" struct)) ((lap (struct x) (MTSCP (T_U struct) (TSCP_S2CINT x))) struct x)) (define (SCHEME-S2CUINT-REF struct x) (if (not (scheme-ptr? struct)) (error 'SCHEME-S2CUINT-REF "Structure is not a SCHEME pointer: ~s" struct)) ((lap (struct x) (S2CUINT_TSCP (MS2CUINT (T_U struct) (TSCP_S2CINT x)))) struct x)) (define (SCHEME-BYTE-SET! struct x v) (if (not (scheme-ptr? struct)) (error 'SCHEME-BYTE-SET! "Structure is not a SCHEME pointer: ~s" struct)) ((lap (struct x v) (SET (MBYTE (T_U struct) (TSCP_S2CINT x)) (TSCP_S2CINT v))) struct x v) v) (define (SCHEME-INT-SET! struct x v) (if (not (scheme-ptr? struct)) (error 'SCHEME-INT-SET! "Structure is not a SCHEME pointer: ~s" struct)) ((lap (struct x v) (SET (MINT (T_U struct) (TSCP_S2CINT x)) (TSCP_S2CINT v))) struct x v) v) (define (SCHEME-TSCP-SET! struct x v) (if (not (scheme-ptr? struct)) (error 'SCHEME-TSCP-SET! "Structure is not a SCHEME pointer: ~s" struct)) ((lap (struct x v) (SETGENTL (MTSCP (T_U struct) (TSCP_S2CINT x)) v)) struct x v) v) (define (SCHEME-S2CUINT-SET! struct x v) (if (not (scheme-ptr? struct)) (error 'SCHEME-S2CUINT-SET! "Structure is not a SCHEME pointer: ~s" struct)) ((lap (struct x v) (SET (MS2CUINT (T_U struct) (TSCP_S2CINT x)) (TSCP_S2CUINT v))) struct x v) v) ;;; *.* Bit operations on 32-bit bit masks (define (BIT-AND x . y) (let loop ((result x) (y y)) (if (null? y) result (loop ((lap (x y) (S2CUINT_TSCP (BITAND32 (TSCP_S2CUINT x) (TSCP_S2CUINT y)))) (car y) result) (cdr y))))) (define (BIT-OR x . y) (let loop ((result x) (y y)) (if (null? y) result (loop ((lap (x y) (S2CUINT_TSCP (BITOR32 (TSCP_S2CUINT x) (TSCP_S2CUINT y)))) (car y) result) (cdr y))))) (define (BIT-NOT x) (bit-xor x -1)) (define (BIT-XOR x . y) (let loop ((result x) (y y)) (if (null? y) result (loop ((lap (x y) (S2CUINT_TSCP (BITXOR32 (TSCP_S2CUINT x) (TSCP_S2CUINT y)))) (car y) result) (cdr y))))) (define (BIT-LSH x y) ((lap (x y) (S2CUINT_TSCP (BITLSH32 (TSCP_S2CUINT x) (TSCP_S2CUINT y)))) x y)) (define (BIT-RSH x y) ((lap (x y) (S2CUINT_TSCP (BITRSH32 (TSCP_S2CUINT x) (TSCP_S2CUINT y)))) x y)) ;;; *.* Garbage collection finalization for unreferenced objects. (define (WHEN-UNREFERENCED obj proc) (if (and proc (not (procedure? proc))) (error 'WHEN-UNREFERENCED "Argument is not a PROCEDURE: ~s" proc)) (let* ((found (assq obj whenfreed)) (result (and found (cdr found)))) (if proc (if found (set-cdr! found proc) (set! whenfreed (cons (cons obj proc) whenfreed))) (if found (set! whenfreed (remq found whenfreed)))) result)) (define (SC_WHENFREED) whenfreed) ;;; Operating System Dependent Extensions. N.B. Not implemented the same ;;; way on all systems. ;;; *.* Define a signal handler. (define SIGNALS (make-vector 32 #f)) (define (SIGNAL sig handler) (if (or (negative? sig) (>= sig (vector-length signals))) (error 'SIGNAL "Argument is not a valid SIGNAL: ~s" sig)) (if (and (not (procedure? handler)) (not (number? handler))) (error 'SIGNAL "Argument is not a valid SIGNAL HANDLER: ~s" handler)) (let ((prev-scheme (vector-ref signals sig))) (vector-set! signals sig handler) (let ((prev-os (ossignal sig (if (number? handler) handler #t)))) (if (procedure? prev-scheme) prev-scheme prev-os)))) (define (CALLSIGNALHANDLER sig) ((vector-ref signals sig) sig)) ;;; *.* Issue a shell command. (define (SYSTEM command) (if (not (string? command)) (error 'SYSTEM "Argument is not a STRING: ~s" command)) (ossystem command)) scheme2c-2012.10.14/scrt/scrt5.c000066400000000000000000003073151203736146400157710ustar00rootroot00000000000000 /* SCHEME->C */ #include void scrt5__init(); DEFCSTRING( t3240, "Argument is not a PORT: ~s" ); DEFSTATICTSCP( c3090 ); DEFSTATICTSCP( c3078 ); DEFCSTRING( t3241, "Argument(s) incorrect" ); DEFSTATICTSCP( c2810 ); DEFCSTRING( t3242, "Argument is not a CHAR: ~s" ); DEFSTATICTSCP( c2789 ); DEFSTATICTSCP( c2786 ); DEFSTATICTSCP( c2612 ); DEFSTATICTSCP( c2608 ); DEFSTATICTSCP( c2604 ); DEFSTATICTSCP( c2600 ); DEFSTATICTSCP( c2596 ); DEFSTATICTSCP( c2592 ); DEFSTATICTSCP( c2588 ); DEFSTATICTSCP( c2584 ); DEFSTATICTSCP( c2580 ); DEFSTATICTSCP( c2576 ); DEFSTATICTSCP( c2572 ); DEFSTATICTSCP( c2568 ); DEFSTATICTSCP( c2564 ); DEFSTATICTSCP( c2560 ); DEFSTATICTSCP( c2556 ); DEFSTATICTSCP( c2546 ); DEFSTATICTSCP( c2542 ); DEFSTATICTSCP( c2535 ); DEFSTATICTSCP( c2503 ); DEFCSTRING( t3243, "Argument is out of range: ~s" ); DEFSTATICTSCP( c2430 ); DEFSTATICTSCP( c2429 ); DEFCSTRING( t3244, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2408 ); DEFSTATICTSCP( c2407 ); DEFSTATICTSCP( c2370 ); DEFSTATICTSCP( c2330 ); DEFCSTRING( t3245, "Argument(s) not CHAR: ~s ~s" ); DEFSTATICTSCP( c2321 ); DEFSTATICTSCP( c2320 ); DEFCSTRING( t3246, ": ~s" ); DEFSTATICTSCP( c2272 ); DEFCSTRING( t3247, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c2269 ); DEFSTATICTSCP( c2268 ); DEFSTATICTSCP( c2256 ); DEFSTATICTSCP( c2247 ); DEFSTATICTSCP( c2229 ); DEFSTATICTSCP( t3248 ); DEFSTATICTSCP( t3249 ); DEFSTATICTSCP( c2228 ); DEFSTATICTSCP( c2221 ); DEFSTATICTSCP( c2187 ); DEFSTATICTSCP( c2171 ); DEFCSTRING( t3250, "w" ); DEFSTATICTSCP( c2152 ); DEFSTATICTSCP( c2147 ); DEFCSTRING( t3251, "r" ); DEFSTATICTSCP( c2141 ); DEFCSTRING( t3252, "Argument is not a PROCEDURE: ~s" ); DEFSTATICTSCP( c2136 ); DEFSTATICTSCP( c2135 ); static void init_constants() { c3090 = CSTRING_TSCP( t3240 ); CONSTANTEXP( ADR( c3090 ) ); c3078 = STRINGTOSYMBOL( CSTRING_TSCP( "GET-OUTPUT-STRING" ) ); CONSTANTEXP( ADR( c3078 ) ); c2810 = CSTRING_TSCP( t3241 ); CONSTANTEXP( ADR( c2810 ) ); c2789 = CSTRING_TSCP( t3242 ); CONSTANTEXP( ADR( c2789 ) ); c2786 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-SET!" ) ); CONSTANTEXP( ADR( c2786 ) ); c2612 = STRINGTOSYMBOL( CSTRING_TSCP( "FILE-PORT" ) ); CONSTANTEXP( ADR( c2612 ) ); c2608 = STRINGTOSYMBOL( CSTRING_TSCP( "ECHO!" ) ); CONSTANTEXP( ADR( c2608 ) ); c2604 = STRINGTOSYMBOL( CSTRING_TSCP( "ECHO" ) ); CONSTANTEXP( ADR( c2604 ) ); c2600 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-PRETTY!" ) ); CONSTANTEXP( ADR( c2600 ) ); c2596 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-PRETTY" ) ); CONSTANTEXP( ADR( c2596 ) ); c2592 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LENGTH!" ) ); CONSTANTEXP( ADR( c2592 ) ); c2588 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LENGTH" ) ); CONSTANTEXP( ADR( c2588 ) ); c2584 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LEVEL!" ) ); CONSTANTEXP( ADR( c2584 ) ); c2580 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LEVEL" ) ); CONSTANTEXP( ADR( c2580 ) ); c2576 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-CIRCLE!" ) ); CONSTANTEXP( ADR( c2576 ) ); c2572 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-CIRCLE" ) ); CONSTANTEXP( ADR( c2572 ) ); c2568 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-FLUSH" ) ); CONSTANTEXP( ADR( c2568 ) ); c2564 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-COUNT" ) ); CONSTANTEXP( ADR( c2564 ) ); c2560 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-WIDTH!" ) ); CONSTANTEXP( ADR( c2560 ) ); c2556 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-WIDTH" ) ); CONSTANTEXP( ADR( c2556 ) ); c2546 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR-READY?" ) ); CONSTANTEXP( ADR( c2546 ) ); c2542 = STRINGTOSYMBOL( CSTRING_TSCP( "PEEK-CHAR" ) ); CONSTANTEXP( ADR( c2542 ) ); c2535 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSE-PORT" ) ); CONSTANTEXP( ADR( c2535 ) ); c2503 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-TOKEN" ) ); CONSTANTEXP( ADR( c2503 ) ); c2430 = CSTRING_TSCP( t3243 ); CONSTANTEXP( ADR( c2430 ) ); c2429 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c2429 ) ); c2408 = CSTRING_TSCP( t3244 ); CONSTANTEXP( ADR( c2408 ) ); c2407 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-REF" ) ); CONSTANTEXP( ADR( c2407 ) ); c2370 = STRINGTOSYMBOL( CSTRING_TSCP( "MAKE-FILE-PORT" ) ); CONSTANTEXP( ADR( c2370 ) ); c2330 = EMPTYLIST; c2330 = CONS( _TSCP( 2578 ), c2330 ); c2330 = CONS( _TSCP( 3346 ), c2330 ); c2330 = CONS( _TSCP( 2578 ), c2330 ); CONSTANTEXP( ADR( c2330 ) ); c2321 = CSTRING_TSCP( t3245 ); CONSTANTEXP( ADR( c2321 ) ); c2320 = STRINGTOSYMBOL( CSTRING_TSCP( "CHARFILE" ) ); CONSTANTEXP( ADR( c2268 ) ); c2256 = STRINGTOSYMBOL( CSTRING_TSCP( "WITH-OUTPUT-TO-FILE" ) ); CONSTANTEXP( ADR( c2256 ) ); c2247 = STRINGTOSYMBOL( CSTRING_TSCP( "WITH-INPUT-FROM-FILE" ) ); CONSTANTEXP( ADR( c2247 ) ); c2229 = EMPTYLIST; t3248 = STRINGTOSYMBOL( CSTRING_TSCP( "INTERACTIVE" ) ); c2229 = CONS( t3248, c2229 ); t3249 = STRINGTOSYMBOL( CSTRING_TSCP( "STAND-ALONE" ) ); c2229 = CONS( t3249, c2229 ); CONSTANTEXP( ADR( c2229 ) ); c2228 = STRINGTOSYMBOL( CSTRING_TSCP( "EMBEDDED" ) ); CONSTANTEXP( ADR( c2228 ) ); c2221 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-CHAR" ) ); CONSTANTEXP( ADR( c2221 ) ); c2187 = STRINGTOSYMBOL( CSTRING_TSCP( "READ-CHAR" ) ); CONSTANTEXP( ADR( c2187 ) ); c2171 = STRINGTOSYMBOL( CSTRING_TSCP( "PORT" ) ); CONSTANTEXP( ADR( c2171 ) ); c2152 = CSTRING_TSCP( t3250 ); CONSTANTEXP( ADR( c2152 ) ); c2147 = STRINGTOSYMBOL( CSTRING_TSCP( "CALL-WITH-OUTPUT-FILE" ) ); CONSTANTEXP( ADR( c2147 ) ); c2141 = CSTRING_TSCP( t3251 ); CONSTANTEXP( ADR( c2141 ) ); c2136 = CSTRING_TSCP( t3252 ); CONSTANTEXP( ADR( c2136 ) ); c2135 = STRINGTOSYMBOL( CSTRING_TSCP( "CALL-WITH-INPUT-FILE" ) ); CONSTANTEXP( ADR( c2135 ) ); } DEFTSCP( scrt5_put_2dfile_36807e3e_v ); DEFCSTRING( t3253, "CALL-WITH-INPUT-FILE" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt5_open_2dfile, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt5_open_2dfile_v ); EXTERNTSCPP( scrt5_close_2dport, XAL1( TSCP ) ); EXTERNTSCP( scrt5_close_2dport_v ); TSCP scrt5_put_2dfile_36807e3e( f2131, p2132 ) TSCP f2131, p2132; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3253 ); if ( AND( EQ( TSCPTAG( p2132 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( p2132 ), PROCEDURETAG ) ) ) goto L3255; scdebug_error( c2135, c2136, CONS( p2132, EMPTYLIST ) ); L3255: X1 = scrt5_open_2dfile( f2131, c2141 ); X3 = p2132; X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( X1, PROCEDURE_CLOSURE( X3 ) ); scrt5_close_2dport( X1 ); POPSTACKTRACE( X2 ); } DEFTSCP( scrt5_put_2dfile_16bb0f3_v ); DEFCSTRING( t3259, "CALL-WITH-OUTPUT-FILE" ); TSCP scrt5_put_2dfile_16bb0f3( f2143, p2144 ) TSCP f2143, p2144; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3259 ); if ( AND( EQ( TSCPTAG( p2144 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( p2144 ), PROCEDURETAG ) ) ) goto L3261; scdebug_error( c2147, c2136, CONS( p2144, EMPTYLIST ) ); L3261: X1 = scrt5_open_2dfile( f2143, c2152 ); X3 = p2144; X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( X1, PROCEDURE_CLOSURE( X3 ) ); scrt5_close_2dport( X1 ); POPSTACKTRACE( X2 ); } DEFTSCP( scrt5_input_2dport_3f_v ); DEFCSTRING( t3265, "INPUT-PORT?" ); TSCP scrt5_input_2dport_3f( x2154 ) TSCP x2154; { TSCP X1; PUSHSTACKTRACE( t3265 ); if ( NEQ( TSCPTAG( x2154 ), PAIRTAG ) ) goto L3267; X1 = PAIR_CAR( x2154 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2171 ) ) ) goto L3269; X1 = PAIR_CDR( x2154 ); if ( NOT( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), PROCEDURETAG ) ) ) ) goto L3272; X1 = PAIR_CDR( x2154 ); X1 = UNKNOWNCALL( X1, 1 ); if ( TRUE( VIA( PROCEDURE_CODE( X1 ) )( c2187, PROCEDURE_CLOSURE( X1 ) ) ) ) goto L3275; POPSTACKTRACE( FALSEVALUE ); L3275: POPSTACKTRACE( TRUEVALUE ); L3272: POPSTACKTRACE( FALSEVALUE ); L3269: POPSTACKTRACE( FALSEVALUE ); L3267: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt5_output_2dport_3f_v ); DEFCSTRING( t3278, "OUTPUT-PORT?" ); TSCP scrt5_output_2dport_3f( x2189 ) TSCP x2189; { TSCP X1; PUSHSTACKTRACE( t3278 ); if ( NEQ( TSCPTAG( x2189 ), PAIRTAG ) ) goto L3280; X1 = PAIR_CAR( x2189 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2171 ) ) ) goto L3282; X1 = PAIR_CDR( x2189 ); if ( NOT( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), PROCEDURETAG ) ) ) ) goto L3285; X1 = PAIR_CDR( x2189 ); X1 = UNKNOWNCALL( X1, 1 ); if ( TRUE( VIA( PROCEDURE_CODE( X1 ) )( c2221, PROCEDURE_CLOSURE( X1 ) ) ) ) goto L3288; POPSTACKTRACE( FALSEVALUE ); L3288: POPSTACKTRACE( TRUEVALUE ); L3285: POPSTACKTRACE( FALSEVALUE ); L3282: POPSTACKTRACE( FALSEVALUE ); L3280: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt5_rt_2dvalue_e3d6f738_v ); DEFCSTRING( t3291, "SCRT5_CURRENT-INPUT-PORT-VALUE" ); DEFTSCP( scrt5_rt_2dvalue_c91906c5_v ); DEFCSTRING( t3292, "SCRT5_CURRENT-OUTPUT-PORT-VALUE" ); DEFTSCP( scrt5_stderr_2dport_v ); DEFCSTRING( t3293, "STDERR-PORT" ); EXTERNTSCPP( sc_scheme_2dmode, XAL0( ) ); EXTERNTSCP( sc_scheme_2dmode_v ); EXTERNTSCPP( scrt5_open_2dinput_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2dinput_2dstring_v ); EXTERNTSCP( sc_emptystring ); EXTERNTSCPP( scrt5_open_2doutput_2dstring, XAL0( ) ); EXTERNTSCP( scrt5_open_2doutput_2dstring_v ); EXTERNTSCPP( scrt6_set_2dwrite_2dcircle_21, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_set_2dwrite_2dcircle_21_v ); EXTERNTSCPP( scrt6_set_2dwrite_2dlevel_21, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_set_2dwrite_2dlevel_21_v ); EXTERNTSCPP( scrt6_set_2dwrite_2dlength_21, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_set_2dwrite_2dlength_21_v ); EXTERNTSCPP( scrt1_memv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memv_v ); EXTERNTSCPP( scrt5_make_2dfile_2dport, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt5_make_2dfile_2dport_v ); EXTERNTSCP( sc_stdin_v ); EXTERNTSCP( sc_stdout_v ); EXTERNTSCP( sc_stderr_v ); DEFTSCP( scrt5_stdin_2dport_v ); DEFCSTRING( t3303, "STDIN-PORT" ); DEFTSCP( scrt5_stdout_2dport_v ); DEFCSTRING( t3304, "STDOUT-PORT" ); DEFTSCP( scrt5_debug_2doutput_2dport_v ); DEFCSTRING( t3305, "DEBUG-OUTPUT-PORT" ); DEFTSCP( scrt5_trace_2doutput_2dport_v ); DEFCSTRING( t3306, "TRACE-OUTPUT-PORT" ); DEFTSCP( scrt5_current_2dinput_2dport_v ); DEFCSTRING( t3307, "CURRENT-INPUT-PORT" ); TSCP scrt5_current_2dinput_2dport( ) { PUSHSTACKTRACE( t3307 ); POPSTACKTRACE( scrt5_rt_2dvalue_e3d6f738_v ); } DEFTSCP( scrt5_current_2doutput_2dport_v ); DEFCSTRING( t3309, "CURRENT-OUTPUT-PORT" ); TSCP scrt5_current_2doutput_2dport( ) { PUSHSTACKTRACE( t3309 ); POPSTACKTRACE( scrt5_rt_2dvalue_c91906c5_v ); } DEFTSCP( scrt5_rom_2dfile_73f9e308_v ); DEFCSTRING( t3311, "WITH-INPUT-FROM-FILE" ); TSCP scrt5_rom_2dfile_73f9e308( f2240, p2241 ) TSCP f2240, p2241; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3311 ); X1 = EMPTYLIST; X2 = scrt5_current_2dinput_2dport( ); X1 = CONS( X1, EMPTYLIST ); if ( AND( EQ( TSCPTAG( p2241 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( p2241 ), PROCEDURETAG ) ) ) goto L3314; scdebug_error( c2247, c2136, CONS( p2241, EMPTYLIST ) ); L3314: scrt5_rt_2dvalue_e3d6f738_v = scrt5_open_2dfile( f2240, c2141 ); X4 = p2241; X4 = UNKNOWNCALL( X4, 0 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( PROCEDURE_CLOSURE( X4 ) ); SETGEN( PAIR_CAR( X1 ), X3 ); scrt5_close_2dport( scrt5_rt_2dvalue_e3d6f738_v ); scrt5_rt_2dvalue_e3d6f738_v = X2; POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt5_dto_2dfile_6f7edfd9_v ); DEFCSTRING( t3316, "WITH-OUTPUT-TO-FILE" ); TSCP scrt5_dto_2dfile_6f7edfd9( f2249, p2250 ) TSCP f2249, p2250; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3316 ); X1 = EMPTYLIST; X2 = scrt5_current_2doutput_2dport( ); X1 = CONS( X1, EMPTYLIST ); if ( AND( EQ( TSCPTAG( p2250 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( p2250 ), PROCEDURETAG ) ) ) goto L3319; scdebug_error( c2256, c2136, CONS( p2250, EMPTYLIST ) ); L3319: scrt5_rt_2dvalue_c91906c5_v = scrt5_open_2dfile( f2249, c2152 ); X4 = p2250; X4 = UNKNOWNCALL( X4, 0 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( PROCEDURE_CLOSURE( X4 ) ); SETGEN( PAIR_CAR( X1 ), X3 ); scrt5_close_2dport( scrt5_rt_2dvalue_c91906c5_v ); scrt5_rt_2dvalue_c91906c5_v = X2; POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( scrt5_open_2dinput_2dfile_v ); DEFCSTRING( t3321, "OPEN-INPUT-FILE" ); TSCP scrt5_open_2dinput_2dfile( f2258 ) TSCP f2258; { PUSHSTACKTRACE( t3321 ); POPSTACKTRACE( scrt5_open_2dfile( f2258, c2141 ) ); } DEFTSCP( scrt5_open_2doutput_2dfile_v ); DEFCSTRING( t3323, "OPEN-OUTPUT-FILE" ); TSCP scrt5_open_2doutput_2dfile( f2260 ) TSCP f2260; { PUSHSTACKTRACE( t3323 ); POPSTACKTRACE( scrt5_open_2dfile( f2260, c2152 ) ); } DEFTSCP( scrt5_open_2dfile_v ); DEFCSTRING( t3325, "OPEN-FILE" ); EXTERNTSCPP( sc_fopen, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_fopen_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( scrt4_when_2dunreferenced, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_when_2dunreferenced_v ); TSCP scrt5_open_2dfile( f2262, t2263 ) TSCP f2262, t2263; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3325 ); X1 = EMPTYLIST; X1 = CONS( X1, EMPTYLIST ); if ( AND( EQ( TSCPTAG( f2262 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( f2262 ), STRINGTAG ) ) ) goto L3328; scdebug_error( c2268, c2269, CONS( f2262, EMPTYLIST ) ); L3328: X2 = sc_fopen( f2262, t2263 ); SETGEN( PAIR_CAR( X1 ), X2 ); if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( X1 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( X1 ) ), STRINGTAG ) ) ) ) goto L3330; X3 = CONS( c2272, EMPTYLIST ); X2 = scrt3_string_2dappend( CONS( PAIR_CAR( X1 ), X3 ) ); scdebug_error( c2268, X2, CONS( f2262, EMPTYLIST ) ); L3330: X2 = scrt5_make_2dfile_2dport( PAIR_CAR( X1 ), t2263 ); scrt4_when_2dunreferenced( X2, scrt5_close_2dport_v ); POPSTACKTRACE( X2 ); } DEFTSCP( scrt5_make_2dfile_2dport_v ); DEFCSTRING( t3333, "MAKE-FILE-PORT" ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( scrt2_remainder, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_remainder_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( sc_fputc, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_fputc_v ); TSCP scrt5_l2312( c2313, c3336 ) TSCP c2313, c3336; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scrt5_l2312 [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 32 ); DISPLAY( 32 ) = CLOSURE_VAR( c3336, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3336, 1 ); if ( AND( EQ( TSCPIMMEDIATETAG( c2313 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 8210 ) ), CHARACTERTAG ) ) ) goto L3339; X4 = CONS( _TSCP( 8210 ), EMPTYLIST ); scdebug_error( c2320, c2321, CONS( c2313, X4 ) ); L3339: if ( GTE( _S2CINT( c2313 ), _S2CINT( _TSCP( 8210 ) ) ) ) goto L3341; if ( FALSE( scrt1_memq( c2313, c2330 ) ) ) goto L3343; X4 = _TSCP( 0 ); SETGEN( PAIR_CAR( DISPLAY( 32 ) ), X4 ); goto L3342; L3343: if ( NEQ( _S2CUINT( c2313 ), _S2CUINT( _TSCP( 2322 ) ) ) ) goto L3345; X7 = PAIR_CAR( DISPLAY( 32 ) ); X8 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( _TSCP( 32 ) ) ), 3 ) ) ); if ( FALSE( X8 ) ) goto L3354; if ( EQ( _S2CUINT( _TSCP( 32 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3354; X6 = _TSCP( REMAINDER( _S2CINT( X7 ), _S2CINT( _TSCP( 32 ) ) ) ); goto L3355; L3354: X6 = scrt2_remainder( X7, _TSCP( 32 ) ); L3355: if ( BITAND( BITOR( _S2CINT( _TSCP( 32 ) ), _S2CINT( X6 ) ), 3 ) ) goto L3357; X5 = _TSCP( IDIFFERENCE( _S2CINT( _TSCP( 32 ) ), _S2CINT( X6 ) ) ); goto L3358; L3357: X5 = scrt2__2d_2dtwo( _TSCP( 32 ), X6 ); L3358: X6 = PAIR_CAR( DISPLAY( 32 ) ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( X5 ) ), 3 ) ) goto L3360; X4 = _TSCP( IPLUS( _S2CINT( X6 ), _S2CINT( X5 ) ) ); goto L3361; L3360: X4 = scrt2__2b_2dtwo( X6, X5 ); L3361: SETGEN( PAIR_CAR( DISPLAY( 32 ) ), X4 ); goto L3342; L3345: X5 = PAIR_CAR( DISPLAY( 32 ) ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3363; X4 = _TSCP( IPLUS( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3364; L3363: X4 = scrt2__2b_2dtwo( X5, _TSCP( 4 ) ); L3364: SETGEN( PAIR_CAR( DISPLAY( 32 ) ), X4 ); goto L3342; L3341: X5 = PAIR_CAR( DISPLAY( 32 ) ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3366; X4 = _TSCP( IPLUS( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3367; L3366: X4 = scrt2__2b_2dtwo( X5, _TSCP( 4 ) ); L3367: SETGEN( PAIR_CAR( DISPLAY( 32 ) ), X4 ); L3342: X4 = sc_fputc( c2313, DISPLAY( 0 ) ); if ( FALSE( X4 ) ) goto L3369; X3 = scdebug_error( c2370, X4, EMPTYLIST ); goto L3370; L3369: X3 = FALSEVALUE; L3370: DISPLAY( 32 ) = X1; DISPLAY( 0 ) = X2; POPSTACKTRACE( X3 ); } EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt2__3e_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_3d_2dtwo_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); TSCP scrt5_w2289( t2372, c3371 ) TSCP t2372, c3371; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "WRITE-TOKEN [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 24 ); DISPLAY( 24 ) = CLOSURE_VAR( c3371, 0 ); if ( NEQ( TSCPIMMEDIATETAG( t2372 ), CHARACTERTAG ) ) goto L3373; X3 = PAIR_CAR( DISPLAY( 24 ) ); X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( t2372, PROCEDURE_CLOSURE( X3 ) ); goto L3424; L3373: X3 = BOOLEAN( EQ( TSCPTAG( t2372 ), PAIRTAG ) ); if ( TRUE( X3 ) ) goto L3379; if ( EQ( _S2CUINT( t2372 ), _S2CUINT( EMPTYLIST ) ) ) goto L3379; if ( AND( EQ( TSCPTAG( t2372 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( t2372 ), STRINGTAG ) ) ) goto L3383; scdebug_error( c2429, c2269, CONS( t2372, EMPTYLIST ) ); L3383: X4 = C_FIXED( STRING_LENGTH( t2372 ) ); X5 = _TSCP( 0 ); L3387: if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( X4 ) ), 3 ) ) goto L3389; if ( NEQ( _S2CUINT( X5 ), _S2CUINT( X4 ) ) ) goto L3393; X2 = FALSEVALUE; goto L3424; L3389: if ( FALSE( scrt2__3d_2dtwo( X5, X4 ) ) ) goto L3393; X2 = FALSEVALUE; goto L3424; L3393: if ( EQ( TSCPTAG( X5 ), FIXNUMTAG ) ) goto L3399; scdebug_error( c2407, c2408, CONS( X5, EMPTYLIST ) ); L3399: X8 = BOOLEAN( LT( _S2CINT( X5 ), 0 ) ); if ( TRUE( X8 ) ) goto L3405; X9 = C_FIXED( STRING_LENGTH( t2372 ) ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( X9 ) ), 3 ) ) goto L3409; if ( GTE( _S2CINT( X5 ), _S2CINT( X9 ) ) ) goto L3405; goto L3416; L3409: if ( FALSE( scrt2__3e_3d_2dtwo( X5, X9 ) ) ) goto L3416; L3405: scdebug_error( c2407, c2430, CONS( X5, EMPTYLIST ) ); L3416: X7 = C_CHAR( STRING_CHAR( t2372, X5 ) ); X6 = PAIR_CAR( DISPLAY( 24 ) ); X6 = UNKNOWNCALL( X6, 1 ); VIA( PROCEDURE_CODE( X6 ) )( X7, PROCEDURE_CLOSURE( X6 ) ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3417; X5 = _TSCP( IPLUS( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L3387 ); L3417: X5 = scrt2__2b_2dtwo( X5, _TSCP( 4 ) ); GOBACK( L3387 ); L3379: X3 = PAIR_CAR( DISPLAY( 24 ) ); X4 = t2372; L3422: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3423; X2 = FALSEVALUE; goto L3424; L3423: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3427; scrt1__24__car_2derror( X4 ); L3427: X6 = PAIR_CAR( X4 ); X5 = X3; X5 = UNKNOWNCALL( X5, 1 ); VIA( PROCEDURE_CODE( X5 ) )( X6, PROCEDURE_CLOSURE( X5 ) ); X4 = PAIR_CDR( X4 ); GOBACK( L3422 ); L3424: DISPLAY( 24 ) = X1; POPSTACKTRACE( X2 ); } EXTERNTSCP( scrt6_system_2dfile_2dmask_v ); EXTERNTSCPP( sc_charready, XAL1( TSCP ) ); EXTERNTSCP( sc_charready_v ); EXTERNTSCPP( scrt6_wait_2dsystem_2dfile, XAL1( TSCP ) ); EXTERNTSCP( scrt6_wait_2dsystem_2dfile_v ); EXTERNTSCPP( sc_fileno, XAL1( TSCP ) ); EXTERNTSCP( sc_fileno_v ); EXTERNTSCPP( sc_fgetc, XAL1( TSCP ) ); EXTERNTSCP( sc_fgetc_v ); TSCP scrt5_l2462( c3430 ) TSCP c3430; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scrt5_l2462 [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3430, 0 ); X2 = DISPLAY( 25 ); DISPLAY( 25 ) = CLOSURE_VAR( c3430, 1 ); if ( FALSE( PAIR_CAR( DISPLAY( 25 ) ) ) ) goto L3432; X4 = PAIR_CAR( DISPLAY( 25 ) ); X5 = FALSEVALUE; SETGEN( PAIR_CAR( DISPLAY( 25 ) ), X5 ); X3 = X4; goto L3442; L3432: if ( EQ( _S2CUINT( scrt6_system_2dfile_2dmask_v ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3438; if ( TRUE( sc_charready( DISPLAY( 0 ) ) ) ) goto L3438; X4 = sc_fileno( DISPLAY( 0 ) ); scrt6_wait_2dsystem_2dfile( X4 ); L3438: X4 = sc_fgetc( DISPLAY( 0 ) ); if ( NOT( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), STRINGTAG ) ) ) ) goto L3441; X3 = scdebug_error( c2370, X4, EMPTYLIST ); goto L3442; L3441: X3 = X4; L3442: DISPLAY( 0 ) = X1; DISPLAY( 25 ) = X2; POPSTACKTRACE( X3 ); } TSCP scrt5_p2291( c3443 ) TSCP c3443; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "PEEK-CHAR [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 22 ); DISPLAY( 22 ) = CLOSURE_VAR( c3443, 0 ); X2 = DISPLAY( 25 ); DISPLAY( 25 ) = CLOSURE_VAR( c3443, 1 ); if ( FALSE( PAIR_CAR( DISPLAY( 25 ) ) ) ) goto L3445; X3 = PAIR_CAR( DISPLAY( 25 ) ); goto L3446; L3445: X5 = PAIR_CAR( DISPLAY( 22 ) ); X5 = UNKNOWNCALL( X5, 0 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); X3 = SETGEN( PAIR_CAR( DISPLAY( 25 ) ), X4 ); L3446: DISPLAY( 22 ) = X1; DISPLAY( 25 ) = X2; POPSTACKTRACE( X3 ); } EXTERNTSCPP( scrt6_eof_2dobject_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_eof_2dobject_3f_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); TSCP scrt5_l2478( c3447 ) TSCP c3447; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scrt5_l2478 [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 22 ); DISPLAY( 22 ) = CLOSURE_VAR( c3447, 0 ); X2 = DISPLAY( 26 ); DISPLAY( 26 ) = CLOSURE_VAR( c3447, 1 ); X5 = PAIR_CAR( DISPLAY( 22 ) ); X5 = UNKNOWNCALL( X5, 0 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); if ( TRUE( scrt6_eof_2dobject_3f( X4 ) ) ) goto L3450; X7 = PAIR_CAR( DISPLAY( 26 ) ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3453; scrt1__24__cdr_2derror( X7 ); L3453: X6 = PAIR_CDR( X7 ); X6 = UNKNOWNCALL( X6, 1 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( c2221, PROCEDURE_CLOSURE( X6 ) ); X5 = UNKNOWNCALL( X5, 1 ); VIA( PROCEDURE_CODE( X5 ) )( X4, PROCEDURE_CLOSURE( X5 ) ); L3450: X3 = X4; DISPLAY( 22 ) = X1; DISPLAY( 26 ) = X2; POPSTACKTRACE( X3 ); } TSCP scrt5_c2293( c3455 ) TSCP c3455; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "CHAR-READY? [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 25 ); DISPLAY( 25 ) = CLOSURE_VAR( c3455, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3455, 1 ); X4 = PAIR_CAR( DISPLAY( 25 ) ); if ( FALSE( X4 ) ) goto L3458; X3 = X4; goto L3459; L3458: X3 = sc_charready( DISPLAY( 0 ) ); L3459: DISPLAY( 25 ) = X1; DISPLAY( 0 ) = X2; POPSTACKTRACE( X3 ); } EXTERNTSCPP( sc_fflush, XAL1( TSCP ) ); EXTERNTSCP( sc_fflush_v ); EXTERNTSCPP( sc_fclose, XAL1( TSCP ) ); EXTERNTSCP( sc_fclose_v ); TSCP scrt5_c2294( c3460 ) TSCP c3460; { TSCP X2, X1; PUSHSTACKTRACE( "CLOSE-PORT [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3460, 0 ); sc_fflush( DISPLAY( 0 ) ); X2 = sc_fclose( DISPLAY( 0 ) ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_l2491( c2492, c3462 ) TSCP c2492, c3462; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scrt5_l2491 [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 24 ); DISPLAY( 24 ) = CLOSURE_VAR( c3462, 0 ); X2 = DISPLAY( 26 ); DISPLAY( 26 ) = CLOSURE_VAR( c3462, 1 ); X4 = PAIR_CAR( DISPLAY( 24 ) ); X4 = UNKNOWNCALL( X4, 1 ); VIA( PROCEDURE_CODE( X4 ) )( c2492, PROCEDURE_CLOSURE( X4 ) ); X6 = PAIR_CAR( DISPLAY( 26 ) ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3465; scrt1__24__cdr_2derror( X6 ); L3465: X5 = PAIR_CDR( X6 ); X5 = UNKNOWNCALL( X5, 1 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( c2221, PROCEDURE_CLOSURE( X5 ) ); X4 = UNKNOWNCALL( X4, 1 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( c2492, PROCEDURE_CLOSURE( X4 ) ); DISPLAY( 24 ) = X1; DISPLAY( 26 ) = X2; POPSTACKTRACE( X3 ); } TSCP scrt5_w2296( t2498, c3467 ) TSCP t2498, c3467; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "WRITE-TOKEN-ECHO [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 23 ); DISPLAY( 23 ) = CLOSURE_VAR( c3467, 0 ); X2 = DISPLAY( 26 ); DISPLAY( 26 ) = CLOSURE_VAR( c3467, 1 ); scrt5_w2289( t2498, PROCEDURE_CLOSURE( PAIR_CAR( DISPLAY( 23 ) ) ) ); X6 = PAIR_CAR( DISPLAY( 26 ) ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3470; scrt1__24__cdr_2derror( X6 ); L3470: X5 = PAIR_CDR( X6 ); X5 = UNKNOWNCALL( X5, 1 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( c2503, PROCEDURE_CLOSURE( X5 ) ); X4 = UNKNOWNCALL( X4, 1 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( t2498, PROCEDURE_CLOSURE( X4 ) ); DISPLAY( 23 ) = X1; DISPLAY( 26 ) = X2; POPSTACKTRACE( X3 ); } TSCP scrt5_w2297( c3472 ) TSCP c3472; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-COUNT [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 32 ); DISPLAY( 32 ) = CLOSURE_VAR( c3472, 0 ); X2 = PAIR_CAR( DISPLAY( 32 ) ); DISPLAY( 32 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2298( c3474 ) TSCP c3474; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-WIDTH [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 31 ); DISPLAY( 31 ) = CLOSURE_VAR( c3474, 0 ); X2 = PAIR_CAR( DISPLAY( 31 ) ); DISPLAY( 31 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2299( w2507, c3476 ) TSCP w2507, c3476; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-WIDTH! [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 31 ); DISPLAY( 31 ) = CLOSURE_VAR( c3476, 0 ); X3 = w2507; X2 = SETGEN( PAIR_CAR( DISPLAY( 31 ) ), X3 ); DISPLAY( 31 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2300( c3478 ) TSCP c3478; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-FLUSH [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3478, 0 ); X2 = sc_fflush( DISPLAY( 0 ) ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2301( c3480 ) TSCP c3480; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-CIRCLE [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 30 ); DISPLAY( 30 ) = CLOSURE_VAR( c3480, 0 ); X2 = PAIR_CAR( DISPLAY( 30 ) ); DISPLAY( 30 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2302( c2511, c3482 ) TSCP c2511, c3482; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-CIRCLE! [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 30 ); DISPLAY( 30 ) = CLOSURE_VAR( c3482, 0 ); X3 = c2511; X2 = SETGEN( PAIR_CAR( DISPLAY( 30 ) ), X3 ); DISPLAY( 30 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2303( c3484 ) TSCP c3484; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-LEVEL [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 29 ); DISPLAY( 29 ) = CLOSURE_VAR( c3484, 0 ); X2 = PAIR_CAR( DISPLAY( 29 ) ); DISPLAY( 29 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2304( l2514, c3486 ) TSCP l2514, c3486; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-LEVEL! [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 29 ); DISPLAY( 29 ) = CLOSURE_VAR( c3486, 0 ); X3 = l2514; X2 = SETGEN( PAIR_CAR( DISPLAY( 29 ) ), X3 ); DISPLAY( 29 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2305( c3488 ) TSCP c3488; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-LENGTH [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 28 ); DISPLAY( 28 ) = CLOSURE_VAR( c3488, 0 ); X2 = PAIR_CAR( DISPLAY( 28 ) ); DISPLAY( 28 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2306( l2517, c3490 ) TSCP l2517, c3490; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-LENGTH! [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 28 ); DISPLAY( 28 ) = CLOSURE_VAR( c3490, 0 ); X3 = l2517; X2 = SETGEN( PAIR_CAR( DISPLAY( 28 ) ), X3 ); DISPLAY( 28 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2307( c3492 ) TSCP c3492; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-PRETTY [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 27 ); DISPLAY( 27 ) = CLOSURE_VAR( c3492, 0 ); X2 = PAIR_CAR( DISPLAY( 27 ) ); DISPLAY( 27 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2308( p2520, c3494 ) TSCP p2520, c3494; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-PRETTY! [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 27 ); DISPLAY( 27 ) = CLOSURE_VAR( c3494, 0 ); X3 = p2520; X2 = SETGEN( PAIR_CAR( DISPLAY( 27 ) ), X3 ); DISPLAY( 27 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_e2309( c3496 ) TSCP c3496; { TSCP X2, X1; PUSHSTACKTRACE( "ECHO [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 26 ); DISPLAY( 26 ) = CLOSURE_VAR( c3496, 0 ); X2 = PAIR_CAR( DISPLAY( 26 ) ); DISPLAY( 26 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_e2310( p2523, c3498 ) TSCP p2523, c3498; { TSCP X3, X2, X1; PUSHSTACKTRACE( "ECHO! [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 26 ); DISPLAY( 26 ) = CLOSURE_VAR( c3498, 0 ); X3 = p2523; X2 = SETGEN( PAIR_CAR( DISPLAY( 26 ) ), X3 ); DISPLAY( 26 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_f2311( c3500 ) TSCP c3500; { TSCP X2, X1; PUSHSTACKTRACE( "FILE-PORT [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3500, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP scrt5_l2528( m2529, c3509 ) TSCP m2529, c3509; { TSCP X26, X25, X24, X23, X22, X21, X20, X19, X18, X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scrt5_l2528 [inside MAKE-FILE-PORT]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3509, 0 ); X2 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c3509, 1 ); X3 = DISPLAY( 3 ); DISPLAY( 3 ) = CLOSURE_VAR( c3509, 2 ); X4 = DISPLAY( 4 ); DISPLAY( 4 ) = CLOSURE_VAR( c3509, 3 ); X5 = DISPLAY( 5 ); DISPLAY( 5 ) = CLOSURE_VAR( c3509, 4 ); X6 = DISPLAY( 6 ); DISPLAY( 6 ) = CLOSURE_VAR( c3509, 5 ); X7 = DISPLAY( 7 ); DISPLAY( 7 ) = CLOSURE_VAR( c3509, 6 ); X8 = DISPLAY( 8 ); DISPLAY( 8 ) = CLOSURE_VAR( c3509, 7 ); X9 = DISPLAY( 9 ); DISPLAY( 9 ) = CLOSURE_VAR( c3509, 8 ); X10 = DISPLAY( 10 ); DISPLAY( 10 ) = CLOSURE_VAR( c3509, 9 ); X11 = DISPLAY( 11 ); DISPLAY( 11 ) = CLOSURE_VAR( c3509, 10 ); X12 = DISPLAY( 12 ); DISPLAY( 12 ) = CLOSURE_VAR( c3509, 11 ); X13 = DISPLAY( 15 ); DISPLAY( 15 ) = CLOSURE_VAR( c3509, 12 ); X14 = DISPLAY( 13 ); DISPLAY( 13 ) = CLOSURE_VAR( c3509, 13 ); X15 = DISPLAY( 14 ); DISPLAY( 14 ) = CLOSURE_VAR( c3509, 14 ); X16 = DISPLAY( 23 ); DISPLAY( 23 ) = CLOSURE_VAR( c3509, 15 ); X17 = DISPLAY( 16 ); DISPLAY( 16 ) = CLOSURE_VAR( c3509, 16 ); X18 = DISPLAY( 24 ); DISPLAY( 24 ) = CLOSURE_VAR( c3509, 17 ); X19 = DISPLAY( 17 ); DISPLAY( 17 ) = CLOSURE_VAR( c3509, 18 ); X20 = DISPLAY( 19 ); DISPLAY( 19 ) = CLOSURE_VAR( c3509, 19 ); X21 = DISPLAY( 21 ); DISPLAY( 21 ) = CLOSURE_VAR( c3509, 20 ); X22 = DISPLAY( 22 ); DISPLAY( 22 ) = CLOSURE_VAR( c3509, 21 ); X23 = DISPLAY( 20 ); DISPLAY( 20 ) = CLOSURE_VAR( c3509, 22 ); X24 = DISPLAY( 26 ); DISPLAY( 26 ) = CLOSURE_VAR( c3509, 23 ); X25 = DISPLAY( 18 ); DISPLAY( 18 ) = CLOSURE_VAR( c3509, 24 ); if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2535 ) ) ) goto L3511; X26 = PAIR_CAR( DISPLAY( 18 ) ); goto L3558; L3511: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2187 ) ) ) goto L3513; if ( FALSE( PAIR_CAR( DISPLAY( 26 ) ) ) ) goto L3515; X26 = PAIR_CAR( DISPLAY( 20 ) ); goto L3558; L3515: X26 = PAIR_CAR( DISPLAY( 22 ) ); goto L3558; L3513: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2542 ) ) ) goto L3517; X26 = PAIR_CAR( DISPLAY( 21 ) ); goto L3558; L3517: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2546 ) ) ) goto L3519; X26 = PAIR_CAR( DISPLAY( 19 ) ); goto L3558; L3519: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2221 ) ) ) goto L3521; if ( FALSE( PAIR_CAR( DISPLAY( 26 ) ) ) ) goto L3523; X26 = PAIR_CAR( DISPLAY( 17 ) ); goto L3558; L3523: X26 = PAIR_CAR( DISPLAY( 24 ) ); goto L3558; L3521: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2503 ) ) ) goto L3525; if ( FALSE( PAIR_CAR( DISPLAY( 26 ) ) ) ) goto L3527; X26 = PAIR_CAR( DISPLAY( 16 ) ); goto L3558; L3527: X26 = PAIR_CAR( DISPLAY( 23 ) ); goto L3558; L3525: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2556 ) ) ) goto L3529; X26 = PAIR_CAR( DISPLAY( 14 ) ); goto L3558; L3529: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2560 ) ) ) goto L3531; X26 = PAIR_CAR( DISPLAY( 13 ) ); goto L3558; L3531: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2564 ) ) ) goto L3533; X26 = PAIR_CAR( DISPLAY( 15 ) ); goto L3558; L3533: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2568 ) ) ) goto L3535; X26 = PAIR_CAR( DISPLAY( 12 ) ); goto L3558; L3535: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2572 ) ) ) goto L3537; X26 = PAIR_CAR( DISPLAY( 11 ) ); goto L3558; L3537: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2576 ) ) ) goto L3539; X26 = PAIR_CAR( DISPLAY( 10 ) ); goto L3558; L3539: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2580 ) ) ) goto L3541; X26 = PAIR_CAR( DISPLAY( 9 ) ); goto L3558; L3541: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2584 ) ) ) goto L3543; X26 = PAIR_CAR( DISPLAY( 8 ) ); goto L3558; L3543: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2588 ) ) ) goto L3545; X26 = PAIR_CAR( DISPLAY( 7 ) ); goto L3558; L3545: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2592 ) ) ) goto L3547; X26 = PAIR_CAR( DISPLAY( 6 ) ); goto L3558; L3547: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2596 ) ) ) goto L3549; X26 = PAIR_CAR( DISPLAY( 5 ) ); goto L3558; L3549: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2600 ) ) ) goto L3551; X26 = PAIR_CAR( DISPLAY( 4 ) ); goto L3558; L3551: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2604 ) ) ) goto L3553; X26 = PAIR_CAR( DISPLAY( 3 ) ); goto L3558; L3553: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2608 ) ) ) goto L3555; X26 = PAIR_CAR( DISPLAY( 2 ) ); goto L3558; L3555: if ( NEQ( _S2CUINT( m2529 ), _S2CUINT( c2612 ) ) ) goto L3557; X26 = PAIR_CAR( DISPLAY( 1 ) ); goto L3558; L3557: X26 = FALSEVALUE; L3558: DISPLAY( 1 ) = X1; DISPLAY( 2 ) = X2; DISPLAY( 3 ) = X3; DISPLAY( 4 ) = X4; DISPLAY( 5 ) = X5; DISPLAY( 6 ) = X6; DISPLAY( 7 ) = X7; DISPLAY( 8 ) = X8; DISPLAY( 9 ) = X9; DISPLAY( 10 ) = X10; DISPLAY( 11 ) = X11; DISPLAY( 12 ) = X12; DISPLAY( 15 ) = X13; DISPLAY( 13 ) = X14; DISPLAY( 14 ) = X15; DISPLAY( 23 ) = X16; DISPLAY( 16 ) = X17; DISPLAY( 24 ) = X18; DISPLAY( 17 ) = X19; DISPLAY( 19 ) = X20; DISPLAY( 21 ) = X21; DISPLAY( 22 ) = X22; DISPLAY( 20 ) = X23; DISPLAY( 26 ) = X24; DISPLAY( 18 ) = X25; POPSTACKTRACE( X26 ); } TSCP scrt5_make_2dfile_2dport( f2277, t2278 ) TSCP f2277, t2278; { TSCP X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SD3 = DISPLAY( 3 ); TSCP SD4 = DISPLAY( 4 ); TSCP SD5 = DISPLAY( 5 ); TSCP SD6 = DISPLAY( 6 ); TSCP SD7 = DISPLAY( 7 ); TSCP SD8 = DISPLAY( 8 ); TSCP SD9 = DISPLAY( 9 ); TSCP SD10 = DISPLAY( 10 ); TSCP SD11 = DISPLAY( 11 ); TSCP SD12 = DISPLAY( 12 ); TSCP SD13 = DISPLAY( 13 ); TSCP SD14 = DISPLAY( 14 ); TSCP SD15 = DISPLAY( 15 ); TSCP SD16 = DISPLAY( 16 ); TSCP SD17 = DISPLAY( 17 ); TSCP SD18 = DISPLAY( 18 ); TSCP SD19 = DISPLAY( 19 ); TSCP SD20 = DISPLAY( 20 ); TSCP SD21 = DISPLAY( 21 ); TSCP SD22 = DISPLAY( 22 ); TSCP SD23 = DISPLAY( 23 ); TSCP SD24 = DISPLAY( 24 ); TSCP SD25 = DISPLAY( 25 ); TSCP SD26 = DISPLAY( 26 ); TSCP SD27 = DISPLAY( 27 ); TSCP SD28 = DISPLAY( 28 ); TSCP SD29 = DISPLAY( 29 ); TSCP SD30 = DISPLAY( 30 ); TSCP SD31 = DISPLAY( 31 ); TSCP SD32 = DISPLAY( 32 ); TSCP SDVAL; PUSHSTACKTRACE( t3333 ); DISPLAY( 0 ) = f2277; DISPLAY( 1 ) = _TSCP( 0 ); DISPLAY( 2 ) = _TSCP( 0 ); DISPLAY( 3 ) = _TSCP( 0 ); DISPLAY( 4 ) = _TSCP( 0 ); DISPLAY( 5 ) = _TSCP( 0 ); DISPLAY( 6 ) = _TSCP( 0 ); DISPLAY( 7 ) = _TSCP( 0 ); DISPLAY( 8 ) = _TSCP( 0 ); DISPLAY( 9 ) = _TSCP( 0 ); DISPLAY( 10 ) = _TSCP( 0 ); DISPLAY( 11 ) = _TSCP( 0 ); DISPLAY( 12 ) = _TSCP( 0 ); DISPLAY( 13 ) = _TSCP( 0 ); DISPLAY( 14 ) = _TSCP( 0 ); DISPLAY( 15 ) = _TSCP( 0 ); DISPLAY( 16 ) = _TSCP( 0 ); DISPLAY( 17 ) = _TSCP( 0 ); DISPLAY( 18 ) = _TSCP( 0 ); DISPLAY( 19 ) = _TSCP( 0 ); DISPLAY( 20 ) = _TSCP( 0 ); DISPLAY( 21 ) = _TSCP( 0 ); DISPLAY( 22 ) = _TSCP( 0 ); DISPLAY( 23 ) = _TSCP( 0 ); DISPLAY( 24 ) = _TSCP( 0 ); DISPLAY( 25 ) = FALSEVALUE; DISPLAY( 26 ) = FALSEVALUE; DISPLAY( 27 ) = FALSEVALUE; DISPLAY( 28 ) = FALSEVALUE; DISPLAY( 29 ) = FALSEVALUE; DISPLAY( 30 ) = FALSEVALUE; DISPLAY( 31 ) = _TSCP( 320 ); DISPLAY( 32 ) = _TSCP( 0 ); DISPLAY( 32 ) = CONS( DISPLAY( 32 ), EMPTYLIST ); DISPLAY( 31 ) = CONS( DISPLAY( 31 ), EMPTYLIST ); DISPLAY( 30 ) = CONS( DISPLAY( 30 ), EMPTYLIST ); DISPLAY( 29 ) = CONS( DISPLAY( 29 ), EMPTYLIST ); DISPLAY( 28 ) = CONS( DISPLAY( 28 ), EMPTYLIST ); DISPLAY( 27 ) = CONS( DISPLAY( 27 ), EMPTYLIST ); DISPLAY( 26 ) = CONS( DISPLAY( 26 ), EMPTYLIST ); DISPLAY( 25 ) = CONS( DISPLAY( 25 ), EMPTYLIST ); DISPLAY( 24 ) = CONS( DISPLAY( 24 ), EMPTYLIST ); DISPLAY( 23 ) = CONS( DISPLAY( 23 ), EMPTYLIST ); DISPLAY( 22 ) = CONS( DISPLAY( 22 ), EMPTYLIST ); DISPLAY( 21 ) = CONS( DISPLAY( 21 ), EMPTYLIST ); DISPLAY( 20 ) = CONS( DISPLAY( 20 ), EMPTYLIST ); DISPLAY( 19 ) = CONS( DISPLAY( 19 ), EMPTYLIST ); DISPLAY( 18 ) = CONS( DISPLAY( 18 ), EMPTYLIST ); DISPLAY( 17 ) = CONS( DISPLAY( 17 ), EMPTYLIST ); DISPLAY( 16 ) = CONS( DISPLAY( 16 ), EMPTYLIST ); DISPLAY( 15 ) = CONS( DISPLAY( 15 ), EMPTYLIST ); DISPLAY( 14 ) = CONS( DISPLAY( 14 ), EMPTYLIST ); DISPLAY( 13 ) = CONS( DISPLAY( 13 ), EMPTYLIST ); DISPLAY( 12 ) = CONS( DISPLAY( 12 ), EMPTYLIST ); DISPLAY( 11 ) = CONS( DISPLAY( 11 ), EMPTYLIST ); DISPLAY( 10 ) = CONS( DISPLAY( 10 ), EMPTYLIST ); DISPLAY( 9 ) = CONS( DISPLAY( 9 ), EMPTYLIST ); DISPLAY( 8 ) = CONS( DISPLAY( 8 ), EMPTYLIST ); DISPLAY( 7 ) = CONS( DISPLAY( 7 ), EMPTYLIST ); DISPLAY( 6 ) = CONS( DISPLAY( 6 ), EMPTYLIST ); DISPLAY( 5 ) = CONS( DISPLAY( 5 ), EMPTYLIST ); DISPLAY( 4 ) = CONS( DISPLAY( 4 ), EMPTYLIST ); DISPLAY( 3 ) = CONS( DISPLAY( 3 ), EMPTYLIST ); DISPLAY( 2 ) = CONS( DISPLAY( 2 ), EMPTYLIST ); DISPLAY( 1 ) = CONS( DISPLAY( 1 ), EMPTYLIST ); X1 = MAKEPROCEDURE( 1, 0, scrt5_l2312, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 32 ), DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 24 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2289, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 24 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 23 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_l2462, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 0 ), DISPLAY( 25 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 22 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_p2291, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 22 ), DISPLAY( 25 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 21 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_l2478, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 22 ), DISPLAY( 26 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 20 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_c2293, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 25 ), DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 19 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_c2294, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 18 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_l2491, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 24 ), DISPLAY( 26 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 17 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2296, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 23 ), DISPLAY( 26 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 16 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2297, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 32 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 15 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2298, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 31 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 14 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2299, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 31 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 13 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2300, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 12 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2301, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 30 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 11 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2302, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 30 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 10 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2303, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 29 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 9 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2304, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 29 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 8 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2305, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 28 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 7 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2306, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 28 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 6 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2307, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 27 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 5 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2308, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 27 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 4 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_e2309, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 26 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 3 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_e2310, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 26 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 2 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_f2311, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 1 ) ), X1 ); if ( FALSE( scrt1_equal_3f( t2278, c2141 ) ) ) goto L3503; X1 = FALSEVALUE; SETGEN( PAIR_CAR( DISPLAY( 17 ) ), X1 ); X1 = FALSEVALUE; SETGEN( PAIR_CAR( DISPLAY( 24 ) ), X1 ); goto L3506; L3503: if ( FALSE( scrt1_equal_3f( t2278, c2152 ) ) ) goto L3506; X1 = FALSEVALUE; SETGEN( PAIR_CAR( DISPLAY( 20 ) ), X1 ); X1 = FALSEVALUE; SETGEN( PAIR_CAR( DISPLAY( 22 ) ), X1 ); L3506: X1 = MAKEPROCEDURE( 1, 0, scrt5_l2528, MAKECLOSURE( EMPTYLIST, 25, DISPLAY( 1 ), DISPLAY( 2 ), DISPLAY( 3 ), DISPLAY( 4 ), DISPLAY( 5 ), DISPLAY( 6 ), DISPLAY( 7 ), DISPLAY( 8 ), DISPLAY( 9 ), DISPLAY( 10 ), DISPLAY( 11 ), DISPLAY( 12 ), DISPLAY( 15 ), DISPLAY( 13 ), DISPLAY( 14 ), DISPLAY( 23 ), DISPLAY( 16 ), DISPLAY( 24 ), DISPLAY( 17 ), DISPLAY( 19 ), DISPLAY( 21 ), DISPLAY( 22 ), DISPLAY( 20 ), DISPLAY( 26 ), DISPLAY( 18 ) ) ); SDVAL = sc_cons( c2171, X1 ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; DISPLAY( 3 ) = SD3; DISPLAY( 4 ) = SD4; DISPLAY( 5 ) = SD5; DISPLAY( 6 ) = SD6; DISPLAY( 7 ) = SD7; DISPLAY( 8 ) = SD8; DISPLAY( 9 ) = SD9; DISPLAY( 10 ) = SD10; DISPLAY( 11 ) = SD11; DISPLAY( 12 ) = SD12; DISPLAY( 13 ) = SD13; DISPLAY( 14 ) = SD14; DISPLAY( 15 ) = SD15; DISPLAY( 16 ) = SD16; DISPLAY( 17 ) = SD17; DISPLAY( 18 ) = SD18; DISPLAY( 19 ) = SD19; DISPLAY( 20 ) = SD20; DISPLAY( 21 ) = SD21; DISPLAY( 22 ) = SD22; DISPLAY( 23 ) = SD23; DISPLAY( 24 ) = SD24; DISPLAY( 25 ) = SD25; DISPLAY( 26 ) = SD26; DISPLAY( 27 ) = SD27; DISPLAY( 28 ) = SD28; DISPLAY( 29 ) = SD29; DISPLAY( 30 ) = SD30; DISPLAY( 31 ) = SD31; DISPLAY( 32 ) = SD32; POPSTACKTRACE( SDVAL ); } DEFTSCP( scrt5_open_2dinput_2dstring_v ); DEFCSTRING( t3559, "OPEN-INPUT-STRING" ); EXTERNTSCP( sc_eofobject ); TSCP scrt5_r2620( c3565 ) TSCP c3565; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "READ-CHAR [inside OPEN-INPUT-STRING]" ); X1 = DISPLAY( 4 ); DISPLAY( 4 ) = CLOSURE_VAR( c3565, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3565, 1 ); X3 = DISPLAY( 5 ); DISPLAY( 5 ) = CLOSURE_VAR( c3565, 2 ); X5 = PAIR_CAR( DISPLAY( 4 ) ); X6 = PAIR_CAR( DISPLAY( 5 ) ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( X5 ) ), 3 ) ) goto L3569; if ( NEQ( _S2CUINT( X6 ), _S2CUINT( X5 ) ) ) goto L3573; X4 = sc_eofobject; goto L3576; L3569: if ( FALSE( scrt2__3d_2dtwo( X6, X5 ) ) ) goto L3573; X4 = sc_eofobject; goto L3576; L3573: X6 = DISPLAY( 0 ); X7 = PAIR_CAR( DISPLAY( 5 ) ); if ( EQ( TSCPTAG( X7 ), FIXNUMTAG ) ) goto L3578; scdebug_error( c2407, c2408, CONS( X7, EMPTYLIST ) ); L3578: X8 = BOOLEAN( LT( _S2CINT( X7 ), 0 ) ); if ( TRUE( X8 ) ) goto L3584; if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), STRINGTAG ) ) ) goto L3586; scdebug_error( c2429, c2269, CONS( X6, EMPTYLIST ) ); L3586: X9 = C_FIXED( STRING_LENGTH( X6 ) ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( X9 ) ), 3 ) ) goto L3590; if ( GTE( _S2CINT( X7 ), _S2CINT( X9 ) ) ) goto L3584; goto L3597; L3590: if ( FALSE( scrt2__3e_3d_2dtwo( X7, X9 ) ) ) goto L3597; L3584: scdebug_error( c2407, c2430, CONS( X7, EMPTYLIST ) ); L3597: X5 = C_CHAR( STRING_CHAR( X6, X7 ) ); X7 = PAIR_CAR( DISPLAY( 5 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X7 ) ), 3 ) ) goto L3600; X6 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X7 ) ) ); goto L3601; L3600: X6 = scrt2__2b_2dtwo( _TSCP( 4 ), X7 ); L3601: SETGEN( PAIR_CAR( DISPLAY( 5 ) ), X6 ); X4 = X5; L3576: DISPLAY( 4 ) = X1; DISPLAY( 0 ) = X2; DISPLAY( 5 ) = X3; POPSTACKTRACE( X4 ); } TSCP scrt5_p2621( c3602 ) TSCP c3602; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "PEEK-CHAR [inside OPEN-INPUT-STRING]" ); X1 = DISPLAY( 4 ); DISPLAY( 4 ) = CLOSURE_VAR( c3602, 0 ); X2 = DISPLAY( 5 ); DISPLAY( 5 ) = CLOSURE_VAR( c3602, 1 ); X3 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3602, 2 ); X5 = PAIR_CAR( DISPLAY( 4 ) ); X6 = PAIR_CAR( DISPLAY( 5 ) ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( X5 ) ), 3 ) ) goto L3606; if ( NEQ( _S2CUINT( X6 ), _S2CUINT( X5 ) ) ) goto L3610; X4 = sc_eofobject; goto L3613; L3606: if ( FALSE( scrt2__3d_2dtwo( X6, X5 ) ) ) goto L3610; X4 = sc_eofobject; goto L3613; L3610: X5 = DISPLAY( 0 ); X6 = PAIR_CAR( DISPLAY( 5 ) ); if ( EQ( TSCPTAG( X6 ), FIXNUMTAG ) ) goto L3615; scdebug_error( c2407, c2408, CONS( X6, EMPTYLIST ) ); L3615: X7 = BOOLEAN( LT( _S2CINT( X6 ), 0 ) ); if ( TRUE( X7 ) ) goto L3621; if ( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), STRINGTAG ) ) ) goto L3623; scdebug_error( c2429, c2269, CONS( X5, EMPTYLIST ) ); L3623: X8 = C_FIXED( STRING_LENGTH( X5 ) ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( X8 ) ), 3 ) ) goto L3627; if ( GTE( _S2CINT( X6 ), _S2CINT( X8 ) ) ) goto L3621; goto L3634; L3627: if ( FALSE( scrt2__3e_3d_2dtwo( X6, X8 ) ) ) goto L3634; L3621: scdebug_error( c2407, c2430, CONS( X6, EMPTYLIST ) ); L3634: X4 = C_CHAR( STRING_CHAR( X5, X6 ) ); L3613: DISPLAY( 4 ) = X1; DISPLAY( 5 ) = X2; DISPLAY( 0 ) = X3; POPSTACKTRACE( X4 ); } TSCP scrt5_t2622( c3635 ) TSCP c3635; { PUSHSTACKTRACE( "TRUE [inside OPEN-INPUT-STRING]" ); POPSTACKTRACE( TRUEVALUE ); } TSCP scrt5_l2706( m2707, c3637 ) TSCP m2707, c3637; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "scrt5_l2706 [inside OPEN-INPUT-STRING]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3637, 0 ); X2 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c3637, 1 ); X3 = DISPLAY( 3 ); DISPLAY( 3 ) = CLOSURE_VAR( c3637, 2 ); if ( NEQ( _S2CUINT( m2707 ), _S2CUINT( c2187 ) ) ) goto L3639; X4 = PAIR_CAR( DISPLAY( 3 ) ); goto L3646; L3639: if ( NEQ( _S2CUINT( m2707 ), _S2CUINT( c2542 ) ) ) goto L3641; X4 = PAIR_CAR( DISPLAY( 2 ) ); goto L3646; L3641: if ( NEQ( _S2CUINT( m2707 ), _S2CUINT( c2546 ) ) ) goto L3643; X4 = PAIR_CAR( DISPLAY( 1 ) ); goto L3646; L3643: if ( NEQ( _S2CUINT( m2707 ), _S2CUINT( c2535 ) ) ) goto L3645; X4 = PAIR_CAR( DISPLAY( 1 ) ); goto L3646; L3645: X4 = FALSEVALUE; L3646: DISPLAY( 1 ) = X1; DISPLAY( 2 ) = X2; DISPLAY( 3 ) = X3; POPSTACKTRACE( X4 ); } TSCP scrt5_open_2dinput_2dstring( s2616 ) TSCP s2616; { TSCP X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SD3 = DISPLAY( 3 ); TSCP SD4 = DISPLAY( 4 ); TSCP SD5 = DISPLAY( 5 ); TSCP SDVAL; PUSHSTACKTRACE( t3559 ); DISPLAY( 0 ) = s2616; DISPLAY( 1 ) = _TSCP( 0 ); DISPLAY( 2 ) = _TSCP( 0 ); DISPLAY( 3 ) = _TSCP( 0 ); DISPLAY( 4 ) = _TSCP( 0 ); DISPLAY( 5 ) = _TSCP( 0 ); DISPLAY( 5 ) = CONS( DISPLAY( 5 ), EMPTYLIST ); DISPLAY( 4 ) = CONS( DISPLAY( 4 ), EMPTYLIST ); DISPLAY( 3 ) = CONS( DISPLAY( 3 ), EMPTYLIST ); DISPLAY( 2 ) = CONS( DISPLAY( 2 ), EMPTYLIST ); DISPLAY( 1 ) = CONS( DISPLAY( 1 ), EMPTYLIST ); X2 = DISPLAY( 0 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) goto L3563; scdebug_error( c2429, c2269, CONS( X2, EMPTYLIST ) ); L3563: X1 = C_FIXED( STRING_LENGTH( X2 ) ); SETGEN( PAIR_CAR( DISPLAY( 4 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_r2620, MAKECLOSURE( EMPTYLIST, 3, DISPLAY( 4 ), DISPLAY( 0 ), DISPLAY( 5 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 3 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_p2621, MAKECLOSURE( EMPTYLIST, 3, DISPLAY( 4 ), DISPLAY( 5 ), DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 2 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_t2622, EMPTYLIST ); SETGEN( PAIR_CAR( DISPLAY( 1 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_l2706, MAKECLOSURE( EMPTYLIST, 3, DISPLAY( 1 ), DISPLAY( 2 ), DISPLAY( 3 ) ) ); SDVAL = sc_cons( c2171, X1 ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; DISPLAY( 3 ) = SD3; DISPLAY( 4 ) = SD4; DISPLAY( 5 ) = SD5; POPSTACKTRACE( SDVAL ); } DEFTSCP( scrt5_open_2doutput_2dstring_v ); DEFCSTRING( t3647, "OPEN-OUTPUT-STRING" ); EXTERNTSCPP( scrt3_string_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2d_3elist_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); TSCP scrt5_w2731( t2746, c3650 ) TSCP t2746, c3650; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "WRITE-TOKEN [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 13 ); DISPLAY( 13 ) = CLOSURE_VAR( c3650, 0 ); X2 = DISPLAY( 19 ); DISPLAY( 19 ) = CLOSURE_VAR( c3650, 1 ); L3651: if ( NEQ( TSCPIMMEDIATETAG( t2746 ), CHARACTERTAG ) ) goto L3652; X4 = sc_cons( t2746, PAIR_CAR( DISPLAY( 19 ) ) ); X3 = SETGEN( PAIR_CAR( DISPLAY( 19 ) ), X4 ); goto L3661; L3652: X4 = BOOLEAN( EQ( TSCPTAG( t2746 ), PAIRTAG ) ); if ( TRUE( X4 ) ) goto L3658; if ( EQ( _S2CUINT( t2746 ), _S2CUINT( EMPTYLIST ) ) ) goto L3658; t2746 = scrt3_string_2d_3elist( t2746 ); GOBACK( L3651 ); L3658: X5 = scrt1_reverse( t2746 ); X4 = scrt1_append_2dtwo( X5, PAIR_CAR( DISPLAY( 19 ) ) ); X3 = SETGEN( PAIR_CAR( DISPLAY( 19 ) ), X4 ); L3661: DISPLAY( 13 ) = X1; DISPLAY( 19 ) = X2; POPSTACKTRACE( X3 ); } EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); EXTERNTSCPP( sc_make_2dstring, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dstring_v ); EXTERNTSCPP( scrt2_min_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_min_2dtwo_v ); TSCP scrt5_g2732( c3662 ) TSCP c3662; { TSCP X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "GET-OUTPUT-STRING [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 19 ); DISPLAY( 19 ) = CLOSURE_VAR( c3662, 0 ); X3 = PAIR_CAR( DISPLAY( 19 ) ); X4 = C_FIXED( MAXSTRINGSIZE ); X5 = scrt1_length( X3 ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( X4 ) ), 3 ) ) goto L3667; X6 = BOOLEAN( GT( _S2CINT( X5 ), _S2CINT( X4 ) ) ); goto L3668; L3667: X6 = scrt2__3e_2dtwo( X5, X4 ); L3668: X7 = EMPTYLIST; SETGEN( PAIR_CAR( DISPLAY( 19 ) ), X7 ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( X4 ) ), 3 ) ) goto L3671; if ( GTE( _S2CINT( X5 ), _S2CINT( X4 ) ) ) goto L3673; X8 = X5; goto L3672; L3673: X8 = X4; goto L3672; L3671: X8 = scrt2_min_2dtwo( X5, X4 ); L3672: X7 = sc_make_2dstring( X8, EMPTYLIST ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( X4 ) ), 3 ) ) goto L3675; if ( GTE( _S2CINT( X5 ), _S2CINT( X4 ) ) ) goto L3677; X9 = X5; goto L3676; L3677: X9 = X4; goto L3676; L3675: X9 = scrt2_min_2dtwo( X5, X4 ); L3676: if ( BITAND( BITOR( _S2CINT( X9 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3680; X8 = _TSCP( IDIFFERENCE( _S2CINT( X9 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3681; L3680: X8 = scrt2__2d_2dtwo( X9, _TSCP( 4 ) ); L3681: if ( FALSE( X6 ) ) goto L3682; X9 = _TSCP( 8 ); goto L3683; L3682: X9 = _TSCP( -4 ); L3683: X10 = X3; L3684: if ( NEQ( _S2CUINT( X8 ), _S2CUINT( X9 ) ) ) goto L3685; if ( FALSE( X6 ) ) goto L3688; if ( EQ( TSCPTAG( _TSCP( 0 ) ), FIXNUMTAG ) ) goto L3692; scdebug_error( c2786, c2408, CONS( _TSCP( 0 ), EMPTYLIST ) ); L3692: if ( EQ( TSCPIMMEDIATETAG( _TSCP( 11794 ) ), CHARACTERTAG ) ) goto L3694; scdebug_error( c2786, c2789, CONS( _TSCP( 11794 ), EMPTYLIST ) ); L3694: X11 = BOOLEAN( LT( _S2CINT( _TSCP( 0 ) ), 0 ) ); if ( TRUE( X11 ) ) goto L3700; if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), STRINGTAG ) ) ) goto L3702; scdebug_error( c2429, c2269, CONS( X7, EMPTYLIST ) ); L3702: X12 = C_FIXED( STRING_LENGTH( X7 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( X12 ) ), 3 ) ) goto L3706; if ( GTE( _S2CINT( _TSCP( 0 ) ), _S2CINT( X12 ) ) ) goto L3700; goto L3713; L3706: if ( FALSE( scrt2__3e_3d_2dtwo( _TSCP( 0 ), X12 ) ) ) goto L3713; L3700: scdebug_error( c2786, c2810, EMPTYLIST ); L3713: STRING_CHAR( X7, _TSCP( 0 ) ) = CHAR_C( _TSCP( 11794 ) ); if ( EQ( TSCPTAG( _TSCP( 4 ) ), FIXNUMTAG ) ) goto L3715; scdebug_error( c2786, c2408, CONS( _TSCP( 4 ), EMPTYLIST ) ); L3715: X11 = BOOLEAN( LT( _S2CINT( _TSCP( 4 ) ), 0 ) ); if ( TRUE( X11 ) ) goto L3721; if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), STRINGTAG ) ) ) goto L3723; scdebug_error( c2429, c2269, CONS( X7, EMPTYLIST ) ); L3723: X12 = C_FIXED( STRING_LENGTH( X7 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X12 ) ), 3 ) ) goto L3727; if ( GTE( _S2CINT( _TSCP( 4 ) ), _S2CINT( X12 ) ) ) goto L3721; goto L3734; L3727: if ( FALSE( scrt2__3e_3d_2dtwo( _TSCP( 4 ), X12 ) ) ) goto L3734; L3721: scdebug_error( c2786, c2810, EMPTYLIST ); L3734: STRING_CHAR( X7, _TSCP( 4 ) ) = CHAR_C( _TSCP( 11794 ) ); if ( EQ( TSCPTAG( _TSCP( 8 ) ), FIXNUMTAG ) ) goto L3736; scdebug_error( c2786, c2408, CONS( _TSCP( 8 ), EMPTYLIST ) ); L3736: X11 = BOOLEAN( LT( _S2CINT( _TSCP( 8 ) ), 0 ) ); if ( TRUE( X11 ) ) goto L3742; if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), STRINGTAG ) ) ) goto L3744; scdebug_error( c2429, c2269, CONS( X7, EMPTYLIST ) ); L3744: X12 = C_FIXED( STRING_LENGTH( X7 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 8 ) ), _S2CINT( X12 ) ), 3 ) ) goto L3748; if ( GTE( _S2CINT( _TSCP( 8 ) ), _S2CINT( X12 ) ) ) goto L3742; goto L3755; L3748: if ( FALSE( scrt2__3e_3d_2dtwo( _TSCP( 8 ), X12 ) ) ) goto L3755; L3742: scdebug_error( c2786, c2810, EMPTYLIST ); L3755: STRING_CHAR( X7, _TSCP( 8 ) ) = CHAR_C( _TSCP( 11794 ) ); L3688: X2 = X7; goto L3686; L3685: if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3758; scrt1__24__car_2derror( X10 ); L3758: X11 = PAIR_CAR( X10 ); if ( EQ( TSCPTAG( X8 ), FIXNUMTAG ) ) goto L3761; scdebug_error( c2786, c2408, CONS( X8, EMPTYLIST ) ); L3761: if ( EQ( TSCPIMMEDIATETAG( X11 ), CHARACTERTAG ) ) goto L3763; scdebug_error( c2786, c2789, CONS( X11, EMPTYLIST ) ); L3763: X12 = BOOLEAN( LT( _S2CINT( X8 ), 0 ) ); if ( TRUE( X12 ) ) goto L3769; if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), STRINGTAG ) ) ) goto L3771; scdebug_error( c2429, c2269, CONS( X7, EMPTYLIST ) ); L3771: X13 = C_FIXED( STRING_LENGTH( X7 ) ); if ( BITAND( BITOR( _S2CINT( X8 ), _S2CINT( X13 ) ), 3 ) ) goto L3775; if ( GTE( _S2CINT( X8 ), _S2CINT( X13 ) ) ) goto L3769; goto L3782; L3775: if ( FALSE( scrt2__3e_3d_2dtwo( X8, X13 ) ) ) goto L3782; L3769: scdebug_error( c2786, c2810, EMPTYLIST ); L3782: STRING_CHAR( X7, X8 ) = CHAR_C( X11 ); if ( BITAND( BITOR( _S2CINT( X8 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3783; X11 = _TSCP( IDIFFERENCE( _S2CINT( X8 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3784; L3783: X11 = scrt2__2d_2dtwo( X8, _TSCP( 4 ) ); L3784: X10 = PAIR_CDR( X10 ); X8 = X11; GOBACK( L3684 ); L3686: DISPLAY( 19 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2733( c2939, c3786 ) TSCP c2939, c3786; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-CHAR [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 19 ); DISPLAY( 19 ) = CLOSURE_VAR( c3786, 0 ); X3 = sc_cons( c2939, PAIR_CAR( DISPLAY( 19 ) ) ); X2 = SETGEN( PAIR_CAR( DISPLAY( 19 ) ), X3 ); DISPLAY( 19 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2734( c3788 ) TSCP c3788; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-WIDTH [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 18 ); DISPLAY( 18 ) = CLOSURE_VAR( c3788, 0 ); X2 = PAIR_CAR( DISPLAY( 18 ) ); DISPLAY( 18 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2735( w2942, c3790 ) TSCP w2942, c3790; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-WIDTH! [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 18 ); DISPLAY( 18 ) = CLOSURE_VAR( c3790, 0 ); X3 = w2942; X2 = SETGEN( PAIR_CAR( DISPLAY( 18 ) ), X3 ); DISPLAY( 18 ) = X1; POPSTACKTRACE( X2 ); } EXTERNTSCPP( scrt5_l2949, XAL1( TSCP ) ); TSCP scrt5_l2949( c2951 ) TSCP c2951; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside OPEN-OUTPUT-STRING]" ); if ( EQ( _S2CUINT( c2951 ), _S2CUINT( EMPTYLIST ) ) ) goto L3798; if ( EQ( TSCPTAG( c2951 ), PAIRTAG ) ) goto L3801; scrt1__24__car_2derror( c2951 ); L3801: X2 = PAIR_CAR( c2951 ); X1 = scrt1_memq( X2, c2330 ); if ( TRUE( X1 ) ) goto L3804; X2 = PAIR_CAR( c2951 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 2322 ) ) ) ) goto L3806; X2 = PAIR_CDR( c2951 ); scrt5_l2949( X2 ); X5 = PAIR_CAR( DISPLAY( 20 ) ); X6 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 32 ) ) ), 3 ) ) ); if ( FALSE( X6 ) ) goto L3818; if ( EQ( _S2CUINT( _TSCP( 32 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3818; X4 = _TSCP( REMAINDER( _S2CINT( X5 ), _S2CINT( _TSCP( 32 ) ) ) ); goto L3819; L3818: X4 = scrt2_remainder( X5, _TSCP( 32 ) ); L3819: if ( BITAND( BITOR( _S2CINT( _TSCP( 32 ) ), _S2CINT( X4 ) ), 3 ) ) goto L3821; X3 = _TSCP( IDIFFERENCE( _S2CINT( _TSCP( 32 ) ), _S2CINT( X4 ) ) ); goto L3822; L3821: X3 = scrt2__2d_2dtwo( _TSCP( 32 ), X4 ); L3822: X4 = PAIR_CAR( DISPLAY( 20 ) ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( X3 ) ), 3 ) ) goto L3824; X2 = _TSCP( IPLUS( _S2CINT( X4 ), _S2CINT( X3 ) ) ); goto L3825; L3824: X2 = scrt2__2b_2dtwo( X4, X3 ); L3825: POPSTACKTRACE( SETGEN( PAIR_CAR( DISPLAY( 20 ) ), X2 ) ); L3806: X2 = PAIR_CDR( c2951 ); scrt5_l2949( X2 ); X3 = PAIR_CAR( DISPLAY( 20 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X3 ) ), 3 ) ) goto L3829; X2 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X3 ) ) ); goto L3830; L3829: X2 = scrt2__2b_2dtwo( _TSCP( 4 ), X3 ); L3830: POPSTACKTRACE( SETGEN( PAIR_CAR( DISPLAY( 20 ) ), X2 ) ); L3804: POPSTACKTRACE( X1 ); L3798: POPSTACKTRACE( TRUEVALUE ); } TSCP scrt5_w2736( c3792 ) TSCP c3792; { TSCP X3, X2, X1; TSCP SD20 = DISPLAY( 20 ); TSCP SDVAL; PUSHSTACKTRACE( "WRITE-COUNT [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 19 ); DISPLAY( 19 ) = CLOSURE_VAR( c3792, 0 ); DISPLAY( 20 ) = _TSCP( 0 ); DISPLAY( 20 ) = CONS( DISPLAY( 20 ), EMPTYLIST ); X3 = PAIR_CAR( DISPLAY( 19 ) ); scrt5_l2949( X3 ); X2 = PAIR_CAR( DISPLAY( 20 ) ); DISPLAY( 19 ) = X1; SDVAL = X2; DISPLAY( 20 ) = SD20; POPSTACKTRACE( SDVAL ); } TSCP scrt5_w2737( c3831 ) TSCP c3831; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-CIRCLE [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 17 ); DISPLAY( 17 ) = CLOSURE_VAR( c3831, 0 ); X2 = PAIR_CAR( DISPLAY( 17 ) ); DISPLAY( 17 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2738( c3019, c3833 ) TSCP c3019, c3833; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-CIRCLE! [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 17 ); DISPLAY( 17 ) = CLOSURE_VAR( c3833, 0 ); X3 = c3019; X2 = SETGEN( PAIR_CAR( DISPLAY( 17 ) ), X3 ); DISPLAY( 17 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2739( c3835 ) TSCP c3835; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-LEVEL [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 16 ); DISPLAY( 16 ) = CLOSURE_VAR( c3835, 0 ); X2 = PAIR_CAR( DISPLAY( 16 ) ); DISPLAY( 16 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2740( l3022, c3837 ) TSCP l3022, c3837; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-LEVEL! [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 16 ); DISPLAY( 16 ) = CLOSURE_VAR( c3837, 0 ); X3 = l3022; X2 = SETGEN( PAIR_CAR( DISPLAY( 16 ) ), X3 ); DISPLAY( 16 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2741( c3839 ) TSCP c3839; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-LENGTH [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 15 ); DISPLAY( 15 ) = CLOSURE_VAR( c3839, 0 ); X2 = PAIR_CAR( DISPLAY( 15 ) ); DISPLAY( 15 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2742( l3025, c3841 ) TSCP l3025, c3841; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-LENGTH! [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 15 ); DISPLAY( 15 ) = CLOSURE_VAR( c3841, 0 ); X3 = l3025; X2 = SETGEN( PAIR_CAR( DISPLAY( 15 ) ), X3 ); DISPLAY( 15 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2743( c3843 ) TSCP c3843; { TSCP X2, X1; PUSHSTACKTRACE( "WRITE-PRETTY [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 14 ); DISPLAY( 14 ) = CLOSURE_VAR( c3843, 0 ); X2 = PAIR_CAR( DISPLAY( 14 ) ); DISPLAY( 14 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_w2744( p3028, c3845 ) TSCP p3028, c3845; { TSCP X3, X2, X1; PUSHSTACKTRACE( "WRITE-PRETTY! [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 14 ); DISPLAY( 14 ) = CLOSURE_VAR( c3845, 0 ); X3 = p3028; X2 = SETGEN( PAIR_CAR( DISPLAY( 14 ) ), X3 ); DISPLAY( 14 ) = X1; POPSTACKTRACE( X2 ); } TSCP scrt5_l3079( c3861 ) TSCP c3861; { PUSHSTACKTRACE( "scrt5_l3079 [inside OPEN-OUTPUT-STRING]" ); POPSTACKTRACE( TRUEVALUE ); } TSCP scrt5_l3029( m3030, c3847 ) TSCP m3030, c3847; { TSCP X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "scrt5_l3029 [inside OPEN-OUTPUT-STRING]" ); X1 = DISPLAY( 12 ); DISPLAY( 12 ) = CLOSURE_VAR( c3847, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3847, 1 ); X3 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3847, 2 ); X4 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c3847, 3 ); X5 = DISPLAY( 3 ); DISPLAY( 3 ) = CLOSURE_VAR( c3847, 4 ); X6 = DISPLAY( 4 ); DISPLAY( 4 ) = CLOSURE_VAR( c3847, 5 ); X7 = DISPLAY( 5 ); DISPLAY( 5 ) = CLOSURE_VAR( c3847, 6 ); X8 = DISPLAY( 6 ); DISPLAY( 6 ) = CLOSURE_VAR( c3847, 7 ); X9 = DISPLAY( 7 ); DISPLAY( 7 ) = CLOSURE_VAR( c3847, 8 ); X10 = DISPLAY( 8 ); DISPLAY( 8 ) = CLOSURE_VAR( c3847, 9 ); X11 = DISPLAY( 9 ); DISPLAY( 9 ) = CLOSURE_VAR( c3847, 10 ); X12 = DISPLAY( 10 ); DISPLAY( 10 ) = CLOSURE_VAR( c3847, 11 ); X13 = DISPLAY( 11 ); DISPLAY( 11 ) = CLOSURE_VAR( c3847, 12 ); X14 = DISPLAY( 13 ); DISPLAY( 13 ) = CLOSURE_VAR( c3847, 13 ); if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2503 ) ) ) goto L3849; X15 = PAIR_CAR( DISPLAY( 13 ) ); goto L3880; L3849: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2221 ) ) ) goto L3851; X15 = PAIR_CAR( DISPLAY( 11 ) ); goto L3880; L3851: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2556 ) ) ) goto L3853; X15 = PAIR_CAR( DISPLAY( 10 ) ); goto L3880; L3853: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2560 ) ) ) goto L3855; X15 = PAIR_CAR( DISPLAY( 9 ) ); goto L3880; L3855: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2564 ) ) ) goto L3857; X15 = PAIR_CAR( DISPLAY( 8 ) ); goto L3880; L3857: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2568 ) ) ) goto L3859; X15 = MAKEPROCEDURE( 0, 0, scrt5_l3079, EMPTYLIST ); goto L3880; L3859: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2572 ) ) ) goto L3863; X15 = PAIR_CAR( DISPLAY( 7 ) ); goto L3880; L3863: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2576 ) ) ) goto L3865; X15 = PAIR_CAR( DISPLAY( 6 ) ); goto L3880; L3865: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2580 ) ) ) goto L3867; X15 = PAIR_CAR( DISPLAY( 5 ) ); goto L3880; L3867: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2584 ) ) ) goto L3869; X15 = PAIR_CAR( DISPLAY( 4 ) ); goto L3880; L3869: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2588 ) ) ) goto L3871; X15 = PAIR_CAR( DISPLAY( 3 ) ); goto L3880; L3871: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2592 ) ) ) goto L3873; X15 = PAIR_CAR( DISPLAY( 2 ) ); goto L3880; L3873: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2596 ) ) ) goto L3875; X15 = PAIR_CAR( DISPLAY( 1 ) ); goto L3880; L3875: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c2600 ) ) ) goto L3877; X15 = PAIR_CAR( DISPLAY( 0 ) ); goto L3880; L3877: if ( NEQ( _S2CUINT( m3030 ), _S2CUINT( c3078 ) ) ) goto L3879; X15 = PAIR_CAR( DISPLAY( 12 ) ); goto L3880; L3879: X15 = FALSEVALUE; L3880: DISPLAY( 12 ) = X1; DISPLAY( 0 ) = X2; DISPLAY( 1 ) = X3; DISPLAY( 2 ) = X4; DISPLAY( 3 ) = X5; DISPLAY( 4 ) = X6; DISPLAY( 5 ) = X7; DISPLAY( 6 ) = X8; DISPLAY( 7 ) = X9; DISPLAY( 8 ) = X10; DISPLAY( 9 ) = X11; DISPLAY( 10 ) = X12; DISPLAY( 11 ) = X13; DISPLAY( 13 ) = X14; POPSTACKTRACE( X15 ); } TSCP scrt5_open_2doutput_2dstring( ) { TSCP X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SD3 = DISPLAY( 3 ); TSCP SD4 = DISPLAY( 4 ); TSCP SD5 = DISPLAY( 5 ); TSCP SD6 = DISPLAY( 6 ); TSCP SD7 = DISPLAY( 7 ); TSCP SD8 = DISPLAY( 8 ); TSCP SD9 = DISPLAY( 9 ); TSCP SD10 = DISPLAY( 10 ); TSCP SD11 = DISPLAY( 11 ); TSCP SD12 = DISPLAY( 12 ); TSCP SD13 = DISPLAY( 13 ); TSCP SD14 = DISPLAY( 14 ); TSCP SD15 = DISPLAY( 15 ); TSCP SD16 = DISPLAY( 16 ); TSCP SD17 = DISPLAY( 17 ); TSCP SD18 = DISPLAY( 18 ); TSCP SD19 = DISPLAY( 19 ); TSCP SDVAL; PUSHSTACKTRACE( t3647 ); DISPLAY( 0 ) = _TSCP( 0 ); DISPLAY( 1 ) = _TSCP( 0 ); DISPLAY( 2 ) = _TSCP( 0 ); DISPLAY( 3 ) = _TSCP( 0 ); DISPLAY( 4 ) = _TSCP( 0 ); DISPLAY( 5 ) = _TSCP( 0 ); DISPLAY( 6 ) = _TSCP( 0 ); DISPLAY( 7 ) = _TSCP( 0 ); DISPLAY( 8 ) = _TSCP( 0 ); DISPLAY( 9 ) = _TSCP( 0 ); DISPLAY( 10 ) = _TSCP( 0 ); DISPLAY( 11 ) = _TSCP( 0 ); DISPLAY( 12 ) = _TSCP( 0 ); DISPLAY( 13 ) = _TSCP( 0 ); DISPLAY( 14 ) = FALSEVALUE; DISPLAY( 15 ) = FALSEVALUE; DISPLAY( 16 ) = FALSEVALUE; DISPLAY( 17 ) = TRUEVALUE; DISPLAY( 18 ) = _TSCP( 320 ); DISPLAY( 19 ) = EMPTYLIST; DISPLAY( 19 ) = CONS( DISPLAY( 19 ), EMPTYLIST ); DISPLAY( 18 ) = CONS( DISPLAY( 18 ), EMPTYLIST ); DISPLAY( 17 ) = CONS( DISPLAY( 17 ), EMPTYLIST ); DISPLAY( 16 ) = CONS( DISPLAY( 16 ), EMPTYLIST ); DISPLAY( 15 ) = CONS( DISPLAY( 15 ), EMPTYLIST ); DISPLAY( 14 ) = CONS( DISPLAY( 14 ), EMPTYLIST ); DISPLAY( 13 ) = CONS( DISPLAY( 13 ), EMPTYLIST ); DISPLAY( 12 ) = CONS( DISPLAY( 12 ), EMPTYLIST ); DISPLAY( 11 ) = CONS( DISPLAY( 11 ), EMPTYLIST ); DISPLAY( 10 ) = CONS( DISPLAY( 10 ), EMPTYLIST ); DISPLAY( 9 ) = CONS( DISPLAY( 9 ), EMPTYLIST ); DISPLAY( 8 ) = CONS( DISPLAY( 8 ), EMPTYLIST ); DISPLAY( 7 ) = CONS( DISPLAY( 7 ), EMPTYLIST ); DISPLAY( 6 ) = CONS( DISPLAY( 6 ), EMPTYLIST ); DISPLAY( 5 ) = CONS( DISPLAY( 5 ), EMPTYLIST ); DISPLAY( 4 ) = CONS( DISPLAY( 4 ), EMPTYLIST ); DISPLAY( 3 ) = CONS( DISPLAY( 3 ), EMPTYLIST ); DISPLAY( 2 ) = CONS( DISPLAY( 2 ), EMPTYLIST ); DISPLAY( 1 ) = CONS( DISPLAY( 1 ), EMPTYLIST ); DISPLAY( 0 ) = CONS( DISPLAY( 0 ), EMPTYLIST ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2731, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 13 ), DISPLAY( 19 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 13 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_g2732, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 19 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 12 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2733, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 19 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 11 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2734, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 18 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 10 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2735, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 18 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 9 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2736, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 19 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 8 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2737, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 17 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 7 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2738, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 17 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 6 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2739, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 16 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 5 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2740, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 16 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 4 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2741, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 15 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 3 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2742, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 15 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 2 ) ), X1 ); X1 = MAKEPROCEDURE( 0, 0, scrt5_w2743, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 14 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 1 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_w2744, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 14 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 0 ) ), X1 ); X1 = MAKEPROCEDURE( 1, 0, scrt5_l3029, MAKECLOSURE( EMPTYLIST, 14, DISPLAY( 12 ), DISPLAY( 0 ), DISPLAY( 1 ), DISPLAY( 2 ), DISPLAY( 3 ), DISPLAY( 4 ), DISPLAY( 5 ), DISPLAY( 6 ), DISPLAY( 7 ), DISPLAY( 8 ), DISPLAY( 9 ), DISPLAY( 10 ), DISPLAY( 11 ), DISPLAY( 13 ) ) ); SDVAL = sc_cons( c2171, X1 ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; DISPLAY( 3 ) = SD3; DISPLAY( 4 ) = SD4; DISPLAY( 5 ) = SD5; DISPLAY( 6 ) = SD6; DISPLAY( 7 ) = SD7; DISPLAY( 8 ) = SD8; DISPLAY( 9 ) = SD9; DISPLAY( 10 ) = SD10; DISPLAY( 11 ) = SD11; DISPLAY( 12 ) = SD12; DISPLAY( 13 ) = SD13; DISPLAY( 14 ) = SD14; DISPLAY( 15 ) = SD15; DISPLAY( 16 ) = SD16; DISPLAY( 17 ) = SD17; DISPLAY( 18 ) = SD18; DISPLAY( 19 ) = SD19; POPSTACKTRACE( SDVAL ); } DEFTSCP( scrt5_close_2dinput_2dport_v ); DEFCSTRING( t3881, "CLOSE-INPUT-PORT" ); TSCP scrt5_close_2dinput_2dport( p3081 ) TSCP p3081; { PUSHSTACKTRACE( t3881 ); POPSTACKTRACE( scrt5_close_2dport( p3081 ) ); } DEFTSCP( scrt5_close_2doutput_2dport_v ); DEFCSTRING( t3883, "CLOSE-OUTPUT-PORT" ); TSCP scrt5_close_2doutput_2dport( p3083 ) TSCP p3083; { PUSHSTACKTRACE( t3883 ); POPSTACKTRACE( scrt5_close_2dport( p3083 ) ); } DEFTSCP( scrt5_close_2dport_v ); DEFCSTRING( t3885, "CLOSE-PORT" ); TSCP scrt5_close_2dport( p3085 ) TSCP p3085; { TSCP X2, X1; PUSHSTACKTRACE( t3885 ); if ( TRUE( scrt5_input_2dport_3f( p3085 ) ) ) goto L3889; if ( TRUE( scrt5_output_2dport_3f( p3085 ) ) ) goto L3889; scdebug_error( c2535, c3090, CONS( p3085, EMPTYLIST ) ); L3889: scrt4_when_2dunreferenced( p3085, FALSEVALUE ); if ( EQ( TSCPTAG( p3085 ), PAIRTAG ) ) goto L3892; scrt1__24__cdr_2derror( p3085 ); L3892: X2 = PAIR_CDR( p3085 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2535, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } void scrt2__init(); void scrt4__init(); void scrt3__init(); void scrt1__init(); void scrt6__init(); void scdebug__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt2__init(); scrt4__init(); scrt3__init(); scrt1__init(); scrt6__init(); scdebug__init(); MAXDISPLAY( 33 ); } void scrt5__init() { TSCP X2, X1; static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scrt5 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3253, ADR( scrt5_put_2dfile_36807e3e_v ), MAKEPROCEDURE( 2, 0, scrt5_put_2dfile_36807e3e, EMPTYLIST ) ); INITIALIZEVAR( t3259, ADR( scrt5_put_2dfile_16bb0f3_v ), MAKEPROCEDURE( 2, 0, scrt5_put_2dfile_16bb0f3, EMPTYLIST ) ); INITIALIZEVAR( t3265, ADR( scrt5_input_2dport_3f_v ), MAKEPROCEDURE( 1, 0, scrt5_input_2dport_3f, EMPTYLIST ) ); INITIALIZEVAR( t3278, ADR( scrt5_output_2dport_3f_v ), MAKEPROCEDURE( 1, 0, scrt5_output_2dport_3f, EMPTYLIST ) ); INITIALIZEVAR( t3291, ADR( scrt5_rt_2dvalue_e3d6f738_v ), FALSEVALUE ); INITIALIZEVAR( t3292, ADR( scrt5_rt_2dvalue_c91906c5_v ), FALSEVALUE ); INITIALIZEVAR( t3293, ADR( scrt5_stderr_2dport_v ), FALSEVALUE ); X1 = sc_scheme_2dmode( ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2228 ) ) ) goto L3295; scrt5_rt_2dvalue_e3d6f738_v = scrt5_open_2dinput_2dstring( sc_emptystring ); scrt5_rt_2dvalue_c91906c5_v = scrt5_open_2doutput_2dstring( ); X2 = scrt5_open_2doutput_2dstring( ); scrt6_set_2dwrite_2dcircle_21( TRUEVALUE, CONS( X2, EMPTYLIST ) ); scrt6_set_2dwrite_2dlevel_21( _TSCP( 160 ), CONS( X2, EMPTYLIST ) ); scrt6_set_2dwrite_2dlength_21( _TSCP( 160 ), CONS( X2, EMPTYLIST ) ); scrt5_stderr_2dport_v = X2; goto L3299; L3295: if ( FALSE( scrt1_memv( X1, c2229 ) ) ) goto L3299; scrt5_rt_2dvalue_e3d6f738_v = scrt5_make_2dfile_2dport( sc_stdin_v, c2141 ); scrt5_rt_2dvalue_c91906c5_v = scrt5_make_2dfile_2dport( sc_stdout_v, c2152 ); X2 = scrt5_make_2dfile_2dport( sc_stderr_v, c2152 ); scrt6_set_2dwrite_2dcircle_21( TRUEVALUE, CONS( X2, EMPTYLIST ) ); scrt6_set_2dwrite_2dlevel_21( _TSCP( 160 ), CONS( X2, EMPTYLIST ) ); scrt6_set_2dwrite_2dlength_21( _TSCP( 160 ), CONS( X2, EMPTYLIST ) ); scrt5_stderr_2dport_v = X2; L3299: INITIALIZEVAR( t3303, ADR( scrt5_stdin_2dport_v ), scrt5_rt_2dvalue_e3d6f738_v ); INITIALIZEVAR( t3304, ADR( scrt5_stdout_2dport_v ), scrt5_rt_2dvalue_c91906c5_v ); INITIALIZEVAR( t3305, ADR( scrt5_debug_2doutput_2dport_v ), scrt5_stderr_2dport_v ); INITIALIZEVAR( t3306, ADR( scrt5_trace_2doutput_2dport_v ), scrt5_stdout_2dport_v ); INITIALIZEVAR( t3307, ADR( scrt5_current_2dinput_2dport_v ), MAKEPROCEDURE( 0, 0, scrt5_current_2dinput_2dport, EMPTYLIST ) ); INITIALIZEVAR( t3309, ADR( scrt5_current_2doutput_2dport_v ), MAKEPROCEDURE( 0, 0, scrt5_current_2doutput_2dport, EMPTYLIST ) ); INITIALIZEVAR( t3311, ADR( scrt5_rom_2dfile_73f9e308_v ), MAKEPROCEDURE( 2, 0, scrt5_rom_2dfile_73f9e308, EMPTYLIST ) ); INITIALIZEVAR( t3316, ADR( scrt5_dto_2dfile_6f7edfd9_v ), MAKEPROCEDURE( 2, 0, scrt5_dto_2dfile_6f7edfd9, EMPTYLIST ) ); INITIALIZEVAR( t3321, ADR( scrt5_open_2dinput_2dfile_v ), MAKEPROCEDURE( 1, 0, scrt5_open_2dinput_2dfile, EMPTYLIST ) ); INITIALIZEVAR( t3323, ADR( scrt5_open_2doutput_2dfile_v ), MAKEPROCEDURE( 1, 0, scrt5_open_2doutput_2dfile, EMPTYLIST ) ); INITIALIZEVAR( t3325, ADR( scrt5_open_2dfile_v ), MAKEPROCEDURE( 2, 0, scrt5_open_2dfile, EMPTYLIST ) ); INITIALIZEVAR( t3333, ADR( scrt5_make_2dfile_2dport_v ), MAKEPROCEDURE( 2, 0, scrt5_make_2dfile_2dport, EMPTYLIST ) ); INITIALIZEVAR( t3559, ADR( scrt5_open_2dinput_2dstring_v ), MAKEPROCEDURE( 1, 0, scrt5_open_2dinput_2dstring, EMPTYLIST ) ); INITIALIZEVAR( t3647, ADR( scrt5_open_2doutput_2dstring_v ), MAKEPROCEDURE( 0, 0, scrt5_open_2doutput_2dstring, EMPTYLIST ) ); INITIALIZEVAR( t3881, ADR( scrt5_close_2dinput_2dport_v ), MAKEPROCEDURE( 1, 0, scrt5_close_2dinput_2dport, EMPTYLIST ) ); INITIALIZEVAR( t3883, ADR( scrt5_close_2doutput_2dport_v ), MAKEPROCEDURE( 1, 0, scrt5_close_2doutput_2dport, EMPTYLIST ) ); INITIALIZEVAR( t3885, ADR( scrt5_close_2dport_v ), MAKEPROCEDURE( 1, 0, scrt5_close_2dport, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/scrt5.sc000066400000000000000000000401771203736146400161540ustar00rootroot00000000000000;;; SCHEME->C Runtime Library ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scrt5 (top-level STDIN-PORT STDOUT-PORT STDERR-PORT DEBUG-OUTPUT-PORT TRACE-OUTPUT-PORT CALL-WITH-INPUT-FILE CALL-WITH-OUTPUT-FILE INPUT-PORT? OUTPUT-PORT? CURRENT-INPUT-PORT CURRENT-OUTPUT-PORT WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE OPEN-INPUT-FILE OPEN-OUTPUT-FILE OPEN-FILE MAKE-FILE-PORT OPEN-INPUT-STRING OPEN-OUTPUT-STRING CLOSE-INPUT-PORT CLOSE-OUTPUT-PORT CLOSE-PORT)) (include "repdef.sc") ;;; 6.10. Input and Output ;;; ;;; All I/O is done to and from "ports", where a port is an object that can ;;; read and write characters. A port is represented as (PORT . proc) ;;; where the symbol "PORT" identifies the object, and the procedure "proc" ;;; implements the operations. This is but one example where closures provide ;;; an elegant, simple solution. Needless to say, if a more general object ;;; based system is later implemented, the I/O system should be rewritten ;;; using it. ;;; ;;; The function MAKE-STRING-PORT makes a port which allows expressions to be ;;; read from a string, and MAKE-FILE-PORT makes a port which allows ;;; expressions to be read from a file. Each time an I/O operation is done, ;;; the port's procedure is invoked. It is called with a symbol which is the ;;; method needed and a procedure which performs that method is returned. That ;;; procedure is then called with the appropriate arguments to perform the ;;; operation and return the result. If the desired method does not exist, ;;; then #F should be returned. The required methods for all ports are: ;;; ;;; METHOD ARGUMENTS OPERATION & RESULT ;;; ;;; CLOSE-PORT - close port for all I/O, result is unspecified ;;; ;;; If the port supports input, then it must provide the following methods: ;;; ;;; READ-CHAR - next input character or EOF-OBJECT ;;; PEEK-CHAR - "peek" at the next character, or EOF-OBJECT ;;; CHAR-READY? - boolean indicating that an input character is ;;; available. N.B. if platform does not support ;;; this for a port, then #T is always returned. ;;; ;;; Ports which support output must provide the following methods: ;;; ;;; WRITE-CHAR character output the character, result is unspecified ;;; WRITE-TOKEN token output the token (character, string, or list ;;; of characters) ;;; WRITE-WIDTH - number of characters per line for pretty print ;;; WRITE-WIDTH! number sets the number of characters per line for ;;; pretty print, result is unspecified ;;; WRITE-COUNT - number of characters on current line ;;; WRITE-FLUSH - flush buffers, result is unspecified ;;; WRITE-CIRCLE - boolean controlling circular printing ;;; WRITE-CIRCLE! #F/#T #F for normal printing, #T to detect circles ;;; WRITE-LEVEL - depth for printing lists and arrays ;;; WRITE-LEVEL! number/#F sets depth for printing lists and arrays ;;; WRITE-LENGTH - length for printing lists and arrays ;;; WRITE-LENGTH! number/#f sets length for printing lists and arrays ;;; WRITE-PRETTY - selects normal or pretty-print ;;; WRITE-PRETTY! #F/#T #F for normal printing, #T for pretty-printing ;;; ;;; Some ports support the following additional methods: ;;; ;;; ECHO - port that I/O is echoed to (or #f) ;;; ECHO! port/#F sets I/O echo port ;;; FILE-PORT - system dependent FILE for the port ;;; 6.10.1 Ports (define (CALL-WITH-INPUT-FILE filename proc) (if (not (procedure? proc)) (error 'CALL-WITH-INPUT-FILE "Argument is not a PROCEDURE: ~s" proc)) (let* ((port (open-file filename "r")) (result (proc port))) (close-port port) result)) (define (CALL-WITH-OUTPUT-FILE filename proc) (if (not (procedure? proc)) (error 'CALL-WITH-OUTPUT-FILE "Argument is not a PROCEDURE: ~s" proc)) (let* ((port (open-file filename "w")) (result (proc port))) (close-port port) result)) (define (INPUT-PORT? x) (if (and (pair? x) (eq? (car x) 'port) (procedure? (cdr x)) ((cdr x) 'read-char)) #t #f)) (define (OUTPUT-PORT? x) (if (and (pair? x) (eq? (car x) 'port) (procedure? (cdr x)) ((cdr x) 'write-char)) #t #f)) ;;; The current input and output ports are kept in the following two cells. ;;; Initially the input port uses stdin and the output port uses stdout. (define CURRENT-INPUT-PORT-VALUE #f) (define CURRENT-OUTPUT-PORT-VALUE #f) (define STDERR-PORT #f) (case (scheme-mode) ((embedded) (set! current-input-port-value (open-input-string "")) (set! current-output-port-value (open-output-string)) (set! stderr-port (let ((port (open-output-string))) (set-write-circle! #t port) (set-write-level! 40 port) (set-write-length! 40 port) port))) ((stand-alone interactive) (set! current-input-port-value (make-file-port stdin "r")) (set! current-output-port-value (make-file-port stdout "w")) (set! stderr-port (let ((port (make-file-port stderr "w"))) (set-write-circle! #t port) (set-write-level! 40 port) (set-write-length! 40 port) port)))) (define STDIN-PORT current-input-port-value) (define STDOUT-PORT current-output-port-value) ;;; Interactive users may wish to set DEBUG-OUTPUT-PORT to STDOUT-PORT rather ;;; than the default STDERR-PORT for improved performance. (define DEBUG-OUTPUT-PORT stderr-port) ;;; Interactive users may wish to set TRACE-OUTPUT-PORT to something other than ;;; the default STDOUT-PORT. (define TRACE-OUTPUT-PORT stdout-port) (define (CURRENT-INPUT-PORT) current-input-port-value) (define (CURRENT-OUTPUT-PORT) current-output-port-value) (define (WITH-INPUT-FROM-FILE filename proc) (let ((old-input-port (current-input-port)) (result '())) (if (not (procedure? proc)) (error 'WITH-INPUT-FROM-FILE "Argument is not a PROCEDURE: ~s" proc)) (set! current-input-port-value (open-file filename "r")) (set! result (proc)) (close-port current-input-port-value) (set! current-input-port-value old-input-port) result)) (define (WITH-OUTPUT-TO-FILE filename proc) (let ((old-output-port (current-output-port)) (result '())) (if (not (procedure? proc)) (error 'WITH-OUTPUT-TO-FILE "Argument is not a PROCEDURE: ~s" proc)) (set! current-output-port-value (open-file filename "w")) (set! result (proc)) (close-port current-output-port-value) (set! current-output-port-value old-output-port) result)) (define (OPEN-INPUT-FILE filename) (open-file filename "r")) (define (OPEN-OUTPUT-FILE filename) (open-file filename "w")) ;;; The following function does the actual file opening. It uses the OS ;;; independent fopen implemented in cio.c. The open types supported are ;;; "r" and "w" as well as anything that is OS dependent. The filename and ;;; type are expected to be strings and the return value of the function is ;;; a port. (define (OPEN-FILE filename type) (let ((file '())) (if (not (string? filename)) (error 'FILENAME->FILE "Argument is not a STRING: ~s" filename)) (set! file (fopen filename type)) (if (string? file) (error 'FILENAME->FILE (string-append file ": ~s") filename)) (let ((port (make-file-port file type))) (when-unreferenced port close-port) port))) ;;; The following function is used to make a port which is does I/O to a UNIX ;;; file or process. It takes a file-number returned by fopen and the type ;;; string that was used to initially fopen the file. (define (MAKE-FILE-PORT file type) (letrec ((charcnt 0) (width 80) (circle #f) (level #f) (wlength #f) (pretty #f) (echo-port #f) (nextchar #f) (write-char (lambda (char) (if (charlist token)))))) (get-output-string (lambda () (let* ((cl chars) (maxstring ((lap () (C_FIXED MAXSTRINGSIZE)))) (len (length cl)) (overflow (> len maxstring))) (set! chars '()) (do ((s (make-string (min len maxstring))) (i (- (min len maxstring) 1) (- i 1)) (end (if overflow 2 -1)) (cl cl (cdr cl))) ((eq? i end) (when overflow (string-set! s 0 #\.) (string-set! s 1 #\.) (string-set! s 2 #\.)) s) (string-set! s i (car cl)))))) (write-char (lambda (char) (set! chars (cons char chars)))) (write-width (lambda () width)) (write-width! (lambda (w) (set! width w))) (write-count (lambda () (let ((count 0)) (let loop ((cl chars)) (cond ((null? cl)) ((memq (car cl) '(#\linefeed #\return #\newline))) ((eq? (car cl) #\tab) (loop (cdr cl)) (set! count (+ count (- 8 (remainder count 8))))) (else (loop (cdr cl)) (set! count (+ 1 count))))) count))) (write-circle (lambda () circle)) (write-circle! (lambda (c) (set! circle c))) (write-level (lambda () level)) (write-level! (lambda (l) (set! level l))) (write-length (lambda () wlength)) (write-length! (lambda (l) (set! wlength l))) (write-pretty (lambda () pretty)) (write-pretty! (lambda (p) (set! pretty p)))) (cons 'port (lambda (method) (case method ((write-token) write-token) ((write-char) write-char) ((write-width) write-width) ((write-width!) write-width!) ((write-count) write-count) ((write-flush) (lambda () #t)) ((write-circle) write-circle) ((write-circle!) write-circle!) ((write-level) write-level) ((write-level!) write-level!) ((write-length) write-length) ((write-length!) write-length!) ((write-pretty) write-pretty) ((write-pretty!) write-pretty!) ((get-output-string) get-output-string) (else #f)))))) (define (CLOSE-INPUT-PORT port) (close-port port)) (define (CLOSE-OUTPUT-PORT port) (close-port port)) (define (CLOSE-PORT port) (if (and (not (input-port? port)) (not (output-port? port))) (error 'CLOSE-PORT "Argument is not a PORT: ~s" port)) (when-unreferenced port #f) (((cdr port) 'close-port))) scheme2c-2012.10.14/scrt/scrt6.c000066400000000000000000002175271203736146400157770ustar00rootroot00000000000000 /* SCHEME->C */ #include void scrt6__init(); DEFSTATICTSCP( c2947 ); DEFSTATICTSCP( c2815 ); DEFCSTRING( t3098, "Index is not in bounds: ~s" ); DEFSTATICTSCP( c2784 ); DEFCSTRING( t3099, "Argument is not a VECTOR: ~s" ); DEFSTATICTSCP( c2778 ); DEFSTATICTSCP( c2777 ); DEFCSTRING( t3100, ": ~s ~s" ); DEFSTATICTSCP( c2759 ); DEFSTATICTSCP( c2754 ); DEFCSTRING( t3101, ": ~s" ); DEFSTATICTSCP( c2748 ); DEFSTATICTSCP( c2745 ); DEFCSTRING( t3102, ")" ); DEFSTATICTSCP( c2630 ); DEFCSTRING( t3103, ". " ); DEFSTATICTSCP( c2629 ); DEFCSTRING( t3104, "(" ); DEFSTATICTSCP( c2606 ); DEFCSTRING( t3105, "#" ); DEFSTATICTSCP( c2604 ); DEFCSTRING( t3106, "Too few ARGUMENTS for ~s" ); DEFSTATICTSCP( c2552 ); DEFCSTRING( t3107, "Too many ARGUMENTS for ~s" ); DEFSTATICTSCP( c2545 ); DEFCSTRING( t3108, "FORM ends with a ~~: ~s" ); DEFSTATICTSCP( c2544 ); DEFCSTRING( t3109, "Unrecognized OUTPUT DESCRIPTOR in ~s" ); DEFSTATICTSCP( c2535 ); DEFSTATICTSCP( c2534 ); DEFSTATICTSCP( c2533 ); DEFSTATICTSCP( c2532 ); DEFCSTRING( t3110, "Argument is out of range: ~s" ); DEFSTATICTSCP( c2517 ); DEFCSTRING( t3111, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2496 ); DEFSTATICTSCP( c2495 ); DEFCSTRING( t3112, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c2488 ); DEFSTATICTSCP( c2487 ); DEFCSTRING( t3113, "Illegal arguments: ~s" ); DEFSTATICTSCP( c2439 ); DEFSTATICTSCP( c2438 ); DEFSTATICTSCP( c2401 ); DEFSTATICTSCP( c2394 ); DEFCSTRING( t3114, "A TRANSCRIPT is not in progress" ); DEFSTATICTSCP( c2387 ); DEFSTATICTSCP( c2386 ); DEFCSTRING( t3115, "w" ); DEFSTATICTSCP( c2381 ); DEFCSTRING( t3116, "A TRANSCRIPT is already in progress" ); DEFSTATICTSCP( c2378 ); DEFSTATICTSCP( c2377 ); DEFSTATICTSCP( c2366 ); DEFCSTRING( t3117, "PORT cannot be echoed to itself: ~s" ); DEFSTATICTSCP( c2361 ); DEFCSTRING( t3118, "Argument is not an OUTPUT PORT or #F: ~s" ); DEFSTATICTSCP( c2360 ); DEFCSTRING( t3119, "Port does not support ECHO: ~s" ); DEFSTATICTSCP( c2349 ); DEFCSTRING( t3120, "Argument is not a port: ~s" ); DEFSTATICTSCP( c2344 ); DEFSTATICTSCP( c2343 ); DEFSTATICTSCP( c2335 ); DEFSTATICTSCP( c2334 ); DEFSTATICTSCP( c2330 ); DEFSTATICTSCP( c2327 ); DEFSTATICTSCP( c2326 ); DEFSTATICTSCP( c2303 ); DEFSTATICTSCP( c2300 ); DEFCSTRING( t3121, "Argument is not #F or a NON-NEGATIVE INTEGER: ~s" ); DEFSTATICTSCP( c2299 ); DEFSTATICTSCP( c2298 ); DEFSTATICTSCP( c2275 ); DEFSTATICTSCP( c2272 ); DEFCSTRING( t3122, "Argument is not a BOOLEAN: ~s" ); DEFSTATICTSCP( c2271 ); DEFSTATICTSCP( c2270 ); DEFSTATICTSCP( c2266 ); DEFSTATICTSCP( c2263 ); DEFCSTRING( t3123, "Argument is not a POSITIVE INTEGER: ~s" ); DEFSTATICTSCP( c2262 ); DEFSTATICTSCP( c2261 ); DEFSTATICTSCP( c2244 ); DEFSTATICTSCP( c2241 ); DEFCSTRING( t3124, "Argument is not an OUTPUT STRING PORT: ~s" ); DEFSTATICTSCP( c2230 ); DEFSTATICTSCP( c2229 ); DEFSTATICTSCP( c2224 ); DEFSTATICTSCP( c2220 ); DEFCSTRING( t3125, "Argument is not a CHARACTER: ~s" ); DEFSTATICTSCP( c2217 ); DEFSTATICTSCP( c2216 ); DEFSTATICTSCP( c2210 ); DEFSTATICTSCP( c2206 ); DEFCSTRING( t3126, "Argument is not an OUTPUT-PORT: ~s" ); DEFSTATICTSCP( c2198 ); DEFSTATICTSCP( c2191 ); DEFSTATICTSCP( c2166 ); DEFSTATICTSCP( c2163 ); DEFSTATICTSCP( c2160 ); DEFSTATICTSCP( c2157 ); DEFCSTRING( t3127, "Argument is not an INPUT-PORT: ~s" ); DEFSTATICTSCP( c2150 ); static void init_constants() { c2947 = STRINGTOSYMBOL( CSTRING_TSCP( "WAIT" ) ); CONSTANTEXP( ADR( c2947 ) ); c2815 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-REF" ) ); CONSTANTEXP( ADR( c2815 ) ); c2784 = CSTRING_TSCP( t3098 ); CONSTANTEXP( ADR( c2784 ) ); c2778 = CSTRING_TSCP( t3099 ); CONSTANTEXP( ADR( c2778 ) ); c2777 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-SET!" ) ); CONSTANTEXP( ADR( c2777 ) ); c2759 = CSTRING_TSCP( t3100 ); CONSTANTEXP( ADR( c2759 ) ); c2754 = STRINGTOSYMBOL( CSTRING_TSCP( "RENAME-FILE" ) ); CONSTANTEXP( ADR( c2754 ) ); c2748 = CSTRING_TSCP( t3101 ); CONSTANTEXP( ADR( c2748 ) ); c2745 = STRINGTOSYMBOL( CSTRING_TSCP( "REMOVE-FILE" ) ); CONSTANTEXP( ADR( c2745 ) ); c2630 = CSTRING_TSCP( t3102 ); CONSTANTEXP( ADR( c2630 ) ); c2629 = CSTRING_TSCP( t3103 ); CONSTANTEXP( ADR( c2629 ) ); c2606 = CSTRING_TSCP( t3104 ); CONSTANTEXP( ADR( c2606 ) ); c2604 = CSTRING_TSCP( t3105 ); CONSTANTEXP( ADR( c2604 ) ); c2552 = CSTRING_TSCP( t3106 ); CONSTANTEXP( ADR( c2552 ) ); c2545 = CSTRING_TSCP( t3107 ); CONSTANTEXP( ADR( c2545 ) ); c2544 = CSTRING_TSCP( t3108 ); CONSTANTEXP( ADR( c2544 ) ); c2535 = CSTRING_TSCP( t3109 ); CONSTANTEXP( ADR( c2535 ) ); c2534 = EMPTYLIST; c2534 = CONS( _TSCP( 17170 ), c2534 ); c2534 = CONS( _TSCP( 25362 ), c2534 ); CONSTANTEXP( ADR( c2534 ) ); c2533 = EMPTYLIST; c2533 = CONS( _TSCP( 16658 ), c2533 ); c2533 = CONS( _TSCP( 24850 ), c2533 ); CONSTANTEXP( ADR( c2533 ) ); c2532 = EMPTYLIST; c2532 = CONS( _TSCP( 21266 ), c2532 ); c2532 = CONS( _TSCP( 29458 ), c2532 ); CONSTANTEXP( ADR( c2532 ) ); c2517 = CSTRING_TSCP( t3110 ); CONSTANTEXP( ADR( c2517 ) ); c2496 = CSTRING_TSCP( t3111 ); CONSTANTEXP( ADR( c2496 ) ); c2495 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-REF" ) ); CONSTANTEXP( ADR( c2495 ) ); c2488 = CSTRING_TSCP( t3112 ); CONSTANTEXP( ADR( c2488 ) ); c2487 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c2487 ) ); c2439 = CSTRING_TSCP( t3113 ); CONSTANTEXP( ADR( c2439 ) ); c2438 = STRINGTOSYMBOL( CSTRING_TSCP( "FORMAT" ) ); CONSTANTEXP( ADR( c2438 ) ); c2401 = STRINGTOSYMBOL( CSTRING_TSCP( "FILE-PORT" ) ); CONSTANTEXP( ADR( c2401 ) ); c2394 = STRINGTOSYMBOL( CSTRING_TSCP( "PORT->STDIO-FILE" ) ); CONSTANTEXP( ADR( c2394 ) ); c2387 = CSTRING_TSCP( t3114 ); CONSTANTEXP( ADR( c2387 ) ); c2386 = STRINGTOSYMBOL( CSTRING_TSCP( "TRANSCRIPT-OFF" ) ); CONSTANTEXP( ADR( c2386 ) ); c2381 = CSTRING_TSCP( t3115 ); CONSTANTEXP( ADR( c2381 ) ); c2378 = CSTRING_TSCP( t3116 ); CONSTANTEXP( ADR( c2378 ) ); c2377 = STRINGTOSYMBOL( CSTRING_TSCP( "TRANSCRIPT-ON" ) ); CONSTANTEXP( ADR( c2377 ) ); c2366 = STRINGTOSYMBOL( CSTRING_TSCP( "ECHO!" ) ); CONSTANTEXP( ADR( c2366 ) ); c2361 = CSTRING_TSCP( t3117 ); CONSTANTEXP( ADR( c2361 ) ); c2360 = CSTRING_TSCP( t3118 ); CONSTANTEXP( ADR( c2360 ) ); c2349 = CSTRING_TSCP( t3119 ); CONSTANTEXP( ADR( c2349 ) ); c2344 = CSTRING_TSCP( t3120 ); CONSTANTEXP( ADR( c2344 ) ); c2343 = STRINGTOSYMBOL( CSTRING_TSCP( "ECHO" ) ); CONSTANTEXP( ADR( c2343 ) ); c2335 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-PRETTY!" ) ); CONSTANTEXP( ADR( c2335 ) ); c2334 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-WRITE-PRETTY!" ) ); CONSTANTEXP( ADR( c2334 ) ); c2330 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-PRETTY" ) ); CONSTANTEXP( ADR( c2330 ) ); c2327 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LENGTH!" ) ); CONSTANTEXP( ADR( c2327 ) ); c2326 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-WRITE-LENGTH!" ) ); CONSTANTEXP( ADR( c2326 ) ); c2303 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LENGTH" ) ); CONSTANTEXP( ADR( c2303 ) ); c2300 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LEVEL!" ) ); CONSTANTEXP( ADR( c2300 ) ); c2299 = CSTRING_TSCP( t3121 ); CONSTANTEXP( ADR( c2299 ) ); c2298 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-WRITE-LEVEL!" ) ); CONSTANTEXP( ADR( c2298 ) ); c2275 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LEVEL" ) ); CONSTANTEXP( ADR( c2275 ) ); c2272 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-CIRCLE!" ) ); CONSTANTEXP( ADR( c2272 ) ); c2271 = CSTRING_TSCP( t3122 ); CONSTANTEXP( ADR( c2271 ) ); c2270 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-WRITE-CIRCLE!" ) ); CONSTANTEXP( ADR( c2270 ) ); c2266 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-CIRCLE" ) ); CONSTANTEXP( ADR( c2266 ) ); c2263 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-WIDTH!" ) ); CONSTANTEXP( ADR( c2263 ) ); c2262 = CSTRING_TSCP( t3123 ); CONSTANTEXP( ADR( c2262 ) ); c2261 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-WRITE-WIDTH!" ) ); CONSTANTEXP( ADR( c2261 ) ); c2244 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-WIDTH" ) ); CONSTANTEXP( ADR( c2244 ) ); c2241 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-COUNT" ) ); CONSTANTEXP( ADR( c2241 ) ); c2230 = CSTRING_TSCP( t3124 ); CONSTANTEXP( ADR( c2230 ) ); c2229 = STRINGTOSYMBOL( CSTRING_TSCP( "GET-OUTPUT-STRING" ) ); CONSTANTEXP( ADR( c2229 ) ); c2224 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-FLUSH" ) ); CONSTANTEXP( ADR( c2224 ) ); c2220 = STRINGTOSYMBOL( CSTRING_TSCP( "NEWLINE" ) ); CONSTANTEXP( ADR( c2220 ) ); c2217 = CSTRING_TSCP( t3125 ); CONSTANTEXP( ADR( c2217 ) ); c2216 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-CHAR" ) ); CONSTANTEXP( ADR( c2216 ) ); c2210 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY" ) ); CONSTANTEXP( ADR( c2210 ) ); c2206 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE" ) ); CONSTANTEXP( ADR( c2206 ) ); c2198 = CSTRING_TSCP( t3126 ); CONSTANTEXP( ADR( c2198 ) ); c2191 = STRINGTOSYMBOL( CSTRING_TSCP( "FLUSH-BUFFER" ) ); CONSTANTEXP( ADR( c2191 ) ); c2166 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR-READY?" ) ); CONSTANTEXP( ADR( c2166 ) ); c2163 = STRINGTOSYMBOL( CSTRING_TSCP( "PEEK-CHAR" ) ); CONSTANTEXP( ADR( c2163 ) ); c2160 = STRINGTOSYMBOL( CSTRING_TSCP( "READ-CHAR" ) ); CONSTANTEXP( ADR( c2160 ) ); c2157 = STRINGTOSYMBOL( CSTRING_TSCP( "READ" ) ); CONSTANTEXP( ADR( c2157 ) ); c2150 = CSTRING_TSCP( t3127 ); CONSTANTEXP( ADR( c2150 ) ); } DEFTSCP( scrt6_pending_2dstdout_v ); DEFCSTRING( t3128, "SCRT6_PENDING-STDOUT" ); DEFTSCP( scrt6_input_2dport_v ); DEFCSTRING( t3129, "SCRT6_INPUT-PORT" ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt5_input_2dport_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt5_input_2dport_3f_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt5_current_2dinput_2dport, XAL0( ) ); EXTERNTSCP( scrt5_current_2dinput_2dport_v ); EXTERNTSCP( scrt5_stdin_2dport_v ); EXTERNTSCPP( scrt6_flush_2dbuffer, XAL1( TSCP ) ); EXTERNTSCP( scrt6_flush_2dbuffer_v ); EXTERNTSCP( scrt5_stdout_2dport_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); TSCP scrt6_input_2dport( f2133, p2134 ) TSCP f2133, p2134; { TSCP X2, X1; PUSHSTACKTRACE( t3129 ); if ( FALSE( p2134 ) ) goto L3131; if ( EQ( TSCPTAG( p2134 ), PAIRTAG ) ) goto L3134; scrt1__24__car_2derror( p2134 ); L3134: X2 = PAIR_CAR( p2134 ); if ( FALSE( scrt5_input_2dport_3f( X2 ) ) ) goto L3137; X1 = X2; goto L3132; L3137: X1 = scdebug_error( f2133, c2150, CONS( X2, EMPTYLIST ) ); goto L3132; L3131: X1 = scrt5_current_2dinput_2dport( ); L3132: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( scrt5_stdin_2dport_v ) ) ) goto L3142; if ( FALSE( scrt6_pending_2dstdout_v ) ) goto L3142; scrt6_flush_2dbuffer( CONS( scrt5_stdout_2dport_v, EMPTYLIST ) ); L3142: if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3145; scrt1__24__cdr_2derror( X1 ); L3145: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt6_read_v ); DEFCSTRING( t3147, "READ" ); EXTERNTSCPP( scrt7_read_2ddatum, XAL1( TSCP ) ); EXTERNTSCP( scrt7_read_2ddatum_v ); TSCP scrt6_read( p2156 ) TSCP p2156; { TSCP X1; PUSHSTACKTRACE( t3147 ); X1 = scrt6_input_2dport( c2157, p2156 ); POPSTACKTRACE( scrt7_read_2ddatum( X1 ) ); } DEFTSCP( scrt6_read_2dchar_v ); DEFCSTRING( t3149, "READ-CHAR" ); TSCP scrt6_read_2dchar( p2159 ) TSCP p2159; { TSCP X2, X1; PUSHSTACKTRACE( t3149 ); X2 = scrt6_input_2dport( c2160, p2159 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2160, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_peek_2dchar_v ); DEFCSTRING( t3151, "PEEK-CHAR" ); TSCP scrt6_peek_2dchar( p2162 ) TSCP p2162; { TSCP X2, X1; PUSHSTACKTRACE( t3151 ); X2 = scrt6_input_2dport( c2163, p2162 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2163, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_char_2dready_3f_v ); DEFCSTRING( t3153, "CHAR-READY?" ); TSCP scrt6_char_2dready_3f( p2165 ) TSCP p2165; { TSCP X2, X1; PUSHSTACKTRACE( t3153 ); X2 = scrt6_input_2dport( c2166, p2165 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2166, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_eof_2dobject_3f_v ); DEFCSTRING( t3155, "EOF-OBJECT?" ); EXTERNTSCP( sc_eofobject ); TSCP scrt6_eof_2dobject_3f( o2168 ) TSCP o2168; { PUSHSTACKTRACE( t3155 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( o2168 ), _S2CUINT( sc_eofobject ) ) ) ); } DEFTSCP( scrt6_output_2dport_v ); DEFCSTRING( t3157, "SCRT6_OUTPUT-PORT" ); EXTERNTSCPP( scrt5_output_2dport_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt5_output_2dport_3f_v ); EXTERNTSCPP( scrt5_current_2doutput_2dport, XAL0( ) ); EXTERNTSCP( scrt5_current_2doutput_2dport_v ); EXTERNTSCP( scrt5_stderr_2dport_v ); TSCP scrt6_output_2dport( f2174, p2175 ) TSCP f2174, p2175; { TSCP X2, X1; PUSHSTACKTRACE( t3157 ); if ( FALSE( p2175 ) ) goto L3159; if ( EQ( TSCPTAG( p2175 ), PAIRTAG ) ) goto L3162; scrt1__24__car_2derror( p2175 ); L3162: X2 = PAIR_CAR( p2175 ); if ( FALSE( scrt5_output_2dport_3f( X2 ) ) ) goto L3165; X1 = X2; goto L3160; L3165: X1 = scdebug_error( f2174, c2198, CONS( X2, EMPTYLIST ) ); goto L3160; L3159: X1 = scrt5_current_2doutput_2dport( ); L3160: X2 = BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( scrt5_stderr_2dport_v ) ) ); if ( FALSE( X2 ) ) goto L3174; if ( FALSE( scrt6_pending_2dstdout_v ) ) goto L3174; scrt6_flush_2dbuffer( CONS( scrt5_stdout_2dport_v, EMPTYLIST ) ); goto L3176; L3174: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( scrt5_stdout_2dport_v ) ) ) goto L3176; scrt6_pending_2dstdout_v = BOOLEAN( NEQ( _S2CUINT( f2174 ), _S2CUINT( c2191 ) ) ); L3176: if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3179; scrt1__24__cdr_2derror( X1 ); L3179: POPSTACKTRACE( PAIR_CDR( X1 ) ); } DEFTSCP( scrt6_write_v ); DEFCSTRING( t3181, "WRITE" ); EXTERNTSCPP( scrt7_write_2fdisplay, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt7_write_2fdisplay_v ); TSCP scrt6_write( o2204, p2205 ) TSCP o2204, p2205; { TSCP X1; PUSHSTACKTRACE( t3181 ); X1 = scrt6_output_2dport( c2206, p2205 ); POPSTACKTRACE( scrt7_write_2fdisplay( o2204, TRUEVALUE, X1 ) ); } DEFTSCP( scrt6_display_v ); DEFCSTRING( t3183, "DISPLAY" ); TSCP scrt6_display( o2208, p2209 ) TSCP o2208, p2209; { TSCP X1; PUSHSTACKTRACE( t3183 ); X1 = scrt6_output_2dport( c2210, p2209 ); POPSTACKTRACE( scrt7_write_2fdisplay( o2208, FALSEVALUE, X1 ) ); } DEFTSCP( scrt6_write_2dchar_v ); DEFCSTRING( t3185, "WRITE-CHAR" ); TSCP scrt6_write_2dchar( c2212, p2213 ) TSCP c2212, p2213; { TSCP X2, X1; PUSHSTACKTRACE( t3185 ); if ( EQ( TSCPIMMEDIATETAG( c2212 ), CHARACTERTAG ) ) goto L3187; scdebug_error( c2216, c2217, CONS( c2212, EMPTYLIST ) ); L3187: X2 = scrt6_output_2dport( c2216, p2213 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2216, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2212, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_newline_v ); DEFCSTRING( t3189, "NEWLINE" ); TSCP scrt6_newline( p2219 ) TSCP p2219; { TSCP X2, X1; PUSHSTACKTRACE( t3189 ); X2 = scrt6_output_2dport( c2220, p2219 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2216, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( _TSCP( 2578 ), PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_flush_2dbuffer_v ); DEFCSTRING( t3191, "FLUSH-BUFFER" ); TSCP scrt6_flush_2dbuffer( p2223 ) TSCP p2223; { TSCP X2, X1; PUSHSTACKTRACE( t3191 ); X2 = scrt6_output_2dport( c2191, p2223 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2224, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_get_2doutput_2dstring_v ); DEFCSTRING( t3193, "GET-OUTPUT-STRING" ); TSCP scrt6_get_2doutput_2dstring( p2226 ) TSCP p2226; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3193 ); X2 = scrt5_output_2dport_3f( p2226 ); if ( FALSE( X2 ) ) goto L3196; if ( EQ( TSCPTAG( p2226 ), PAIRTAG ) ) goto L3199; scrt1__24__cdr_2derror( p2226 ); L3199: X4 = PAIR_CDR( p2226 ); X4 = UNKNOWNCALL( X4, 1 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( c2229, PROCEDURE_CLOSURE( X4 ) ); X3 = UNKNOWNCALL( X3, 0 ); X1 = VIA( PROCEDURE_CODE( X3 ) )( PROCEDURE_CLOSURE( X3 ) ); goto L3197; L3196: X1 = X2; L3197: if ( TRUE( X1 ) ) goto L3202; POPSTACKTRACE( scdebug_error( c2229, c2230, CONS( p2226, EMPTYLIST ) ) ); L3202: POPSTACKTRACE( X1 ); } DEFTSCP( scrt6_write_2dcount_v ); DEFCSTRING( t3204, "WRITE-COUNT" ); TSCP scrt6_write_2dcount( p2240 ) TSCP p2240; { TSCP X2, X1; PUSHSTACKTRACE( t3204 ); X2 = scrt6_output_2dport( c2241, p2240 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2241, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_write_2dwidth_v ); DEFCSTRING( t3206, "WRITE-WIDTH" ); TSCP scrt6_write_2dwidth( p2243 ) TSCP p2243; { TSCP X2, X1; PUSHSTACKTRACE( t3206 ); X2 = scrt6_output_2dport( c2244, p2243 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2244, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_set_2dwrite_2dwidth_21_v ); DEFCSTRING( t3208, "SET-WRITE-WIDTH!" ); EXTERNTSCPP( scrt2__3c_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_3d_2dtwo_v ); TSCP scrt6_set_2dwrite_2dwidth_21( w2246, p2247 ) TSCP w2246, p2247; { TSCP X2, X1; PUSHSTACKTRACE( t3208 ); X1 = BOOLEAN( NEQ( TSCPTAG( w2246 ), FIXNUMTAG ) ); if ( TRUE( X1 ) ) goto L3214; if ( BITAND( BITOR( _S2CINT( w2246 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L3216; if ( LTE( _S2CINT( w2246 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L3214; goto L3223; L3216: if ( FALSE( scrt2__3c_3d_2dtwo( w2246, _TSCP( 0 ) ) ) ) goto L3223; L3214: scdebug_error( c2261, c2262, CONS( w2246, EMPTYLIST ) ); L3223: X2 = scrt6_output_2dport( c2261, p2247 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2263, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( w2246, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_write_2dcircle_v ); DEFCSTRING( t3224, "WRITE-CIRCLE" ); TSCP scrt6_write_2dcircle( p2265 ) TSCP p2265; { TSCP X2, X1; PUSHSTACKTRACE( t3224 ); X2 = scrt6_output_2dport( c2266, p2265 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2266, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_set_2dwrite_2dcircle_21_v ); DEFCSTRING( t3226, "SET-WRITE-CIRCLE!" ); EXTERNTSCPP( scrt1_boolean_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt1_boolean_3f_v ); TSCP scrt6_set_2dwrite_2dcircle_21( f2268, p2269 ) TSCP f2268, p2269; { TSCP X2, X1; PUSHSTACKTRACE( t3226 ); if ( TRUE( scrt1_boolean_3f( f2268 ) ) ) goto L3228; scdebug_error( c2270, c2271, CONS( f2268, EMPTYLIST ) ); L3228: X2 = scrt6_output_2dport( c2270, p2269 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2272, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( f2268, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_write_2dlevel_v ); DEFCSTRING( t3230, "WRITE-LEVEL" ); TSCP scrt6_write_2dlevel( p2274 ) TSCP p2274; { TSCP X2, X1; PUSHSTACKTRACE( t3230 ); X2 = scrt6_output_2dport( c2275, p2274 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2275, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_set_2dwrite_2dlevel_21_v ); DEFCSTRING( t3232, "SET-WRITE-LEVEL!" ); EXTERNTSCPP( scrt2__3e_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_3d_2dtwo_v ); TSCP scrt6_set_2dwrite_2dlevel_21( l2277, p2278 ) TSCP l2277, p2278; { TSCP X2, X1; PUSHSTACKTRACE( t3232 ); if ( EQ( _S2CUINT( l2277 ), _S2CUINT( FALSEVALUE ) ) ) goto L3248; if ( NEQ( TSCPTAG( l2277 ), FIXNUMTAG ) ) goto L3247; if ( BITAND( BITOR( _S2CINT( l2277 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L3240; if ( LT( _S2CINT( l2277 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L3247; goto L3248; L3240: if ( TRUE( scrt2__3e_3d_2dtwo( l2277, _TSCP( 0 ) ) ) ) goto L3248; L3247: scdebug_error( c2298, c2299, CONS( l2277, EMPTYLIST ) ); L3248: X2 = scrt6_output_2dport( c2298, p2278 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2300, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( l2277, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_write_2dlength_v ); DEFCSTRING( t3249, "WRITE-LENGTH" ); TSCP scrt6_write_2dlength( p2302 ) TSCP p2302; { TSCP X2, X1; PUSHSTACKTRACE( t3249 ); X2 = scrt6_output_2dport( c2303, p2302 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2303, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_set_2dwrite_2dlength_21_v ); DEFCSTRING( t3251, "SET-WRITE-LENGTH!" ); TSCP scrt6_set_2dwrite_2dlength_21( l2305, p2306 ) TSCP l2305, p2306; { TSCP X2, X1; PUSHSTACKTRACE( t3251 ); if ( EQ( _S2CUINT( l2305 ), _S2CUINT( FALSEVALUE ) ) ) goto L3267; if ( NEQ( TSCPTAG( l2305 ), FIXNUMTAG ) ) goto L3266; if ( BITAND( BITOR( _S2CINT( l2305 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L3259; if ( LT( _S2CINT( l2305 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L3266; goto L3267; L3259: if ( TRUE( scrt2__3e_3d_2dtwo( l2305, _TSCP( 0 ) ) ) ) goto L3267; L3266: scdebug_error( c2326, c2299, CONS( l2305, EMPTYLIST ) ); L3267: X2 = scrt6_output_2dport( c2326, p2306 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2327, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( l2305, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_write_2dpretty_v ); DEFCSTRING( t3268, "WRITE-PRETTY" ); TSCP scrt6_write_2dpretty( p2329 ) TSCP p2329; { TSCP X2, X1; PUSHSTACKTRACE( t3268 ); X2 = scrt6_output_2dport( c2330, p2329 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2330, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_set_2dwrite_2dpretty_21_v ); DEFCSTRING( t3270, "SET-WRITE-PRETTY!" ); TSCP scrt6_set_2dwrite_2dpretty_21( f2332, p2333 ) TSCP f2332, p2333; { TSCP X2, X1; PUSHSTACKTRACE( t3270 ); if ( TRUE( scrt1_boolean_3f( f2332 ) ) ) goto L3272; scdebug_error( c2334, c2271, CONS( f2332, EMPTYLIST ) ); L3272: X2 = scrt6_output_2dport( c2334, p2333 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2335, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( f2332, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_echo_v ); DEFCSTRING( t3274, "ECHO" ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); TSCP scrt6_echo( p2337, a2338 ) TSCP p2337, a2338; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3274 ); if ( TRUE( scrt5_input_2dport_3f( p2337 ) ) ) goto L3278; if ( TRUE( scrt5_output_2dport_3f( p2337 ) ) ) goto L3278; scdebug_error( c2343, c2344, CONS( p2337, EMPTYLIST ) ); L3278: if ( EQ( TSCPTAG( p2337 ), PAIRTAG ) ) goto L3283; scrt1__24__cdr_2derror( p2337 ); L3283: X1 = PAIR_CDR( p2337 ); X1 = UNKNOWNCALL( X1, 1 ); if ( TRUE( VIA( PROCEDURE_CODE( X1 ) )( c2343, PROCEDURE_CLOSURE( X1 ) ) ) ) goto L3280; scdebug_error( c2343, c2349, CONS( p2337, EMPTYLIST ) ); L3280: if ( FALSE( a2338 ) ) goto L3285; if ( EQ( TSCPTAG( a2338 ), PAIRTAG ) ) goto L3288; scrt1__24__car_2derror( a2338 ); L3288: X1 = PAIR_CAR( a2338 ); if ( FALSE( X1 ) ) goto L3293; if ( TRUE( scrt5_output_2dport_3f( X1 ) ) ) goto L3293; scdebug_error( c2343, c2360, CONS( X1, EMPTYLIST ) ); L3293: if ( FALSE( scrt1_equal_3f( p2337, X1 ) ) ) goto L3295; scdebug_error( c2343, c2361, CONS( X1, EMPTYLIST ) ); L3295: if ( EQ( TSCPTAG( p2337 ), PAIRTAG ) ) goto L3298; scrt1__24__cdr_2derror( p2337 ); L3298: X3 = PAIR_CDR( p2337 ); X3 = UNKNOWNCALL( X3, 1 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( c2366, PROCEDURE_CLOSURE( X3 ) ); X2 = UNKNOWNCALL( X2, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( X1, PROCEDURE_CLOSURE( X2 ) ) ); L3285: if ( EQ( TSCPTAG( p2337 ), PAIRTAG ) ) goto L3301; scrt1__24__cdr_2derror( p2337 ); L3301: X2 = PAIR_CDR( p2337 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2343, PROCEDURE_CLOSURE( X2 ) ); X1 = UNKNOWNCALL( X1, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( scrt6_transcript_2don_v ); DEFCSTRING( t3303, "TRANSCRIPT-ON" ); EXTERNTSCPP( scrt5_open_2dfile, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt5_open_2dfile_v ); TSCP scrt6_transcript_2don( f2372 ) TSCP f2372; { TSCP X1; PUSHSTACKTRACE( t3303 ); X1 = scrt6_echo( scrt5_stdin_2dport_v, EMPTYLIST ); if ( TRUE( X1 ) ) goto L3309; if ( FALSE( scrt6_echo( scrt5_stdout_2dport_v, EMPTYLIST ) ) ) goto L3312; L3309: scdebug_error( c2377, c2378, EMPTYLIST ); L3312: X1 = scrt5_open_2dfile( f2372, c2381 ); scrt6_echo( scrt5_stdin_2dport_v, CONS( X1, EMPTYLIST ) ); scrt6_echo( scrt5_stdout_2dport_v, CONS( X1, EMPTYLIST ) ); POPSTACKTRACE( c2377 ); } DEFTSCP( scrt6_transcript_2doff_v ); DEFCSTRING( t3314, "TRANSCRIPT-OFF" ); EXTERNTSCPP( scrt5_close_2dport, XAL1( TSCP ) ); EXTERNTSCP( scrt5_close_2dport_v ); TSCP scrt6_transcript_2doff( ) { TSCP X2, X1; PUSHSTACKTRACE( t3314 ); X1 = scrt6_echo( scrt5_stdin_2dport_v, EMPTYLIST ); X2 = scrt6_echo( scrt5_stdout_2dport_v, EMPTYLIST ); if ( TRUE( scrt1_equal_3f( X1, X2 ) ) ) goto L3317; scdebug_error( c2386, c2387, EMPTYLIST ); L3317: scrt6_echo( scrt5_stdin_2dport_v, CONS( FALSEVALUE, EMPTYLIST ) ); scrt6_echo( scrt5_stdout_2dport_v, CONS( FALSEVALUE, EMPTYLIST ) ); POPSTACKTRACE( scrt5_close_2dport( X1 ) ); } DEFTSCP( scrt6_port_2d_3estdio_2dfile_v ); DEFCSTRING( t3319, "PORT->STDIO-FILE" ); TSCP scrt6_port_2d_3estdio_2dfile( p2389 ) TSCP p2389; { TSCP X2, X1; PUSHSTACKTRACE( t3319 ); X1 = scrt5_input_2dport_3f( p2389 ); if ( TRUE( X1 ) ) goto L3325; if ( TRUE( scrt5_output_2dport_3f( p2389 ) ) ) goto L3325; POPSTACKTRACE( scdebug_error( c2394, c2344, CONS( p2389, EMPTYLIST ) ) ); L3325: if ( EQ( TSCPTAG( p2389 ), PAIRTAG ) ) goto L3329; scrt1__24__cdr_2derror( p2389 ); L3329: X2 = PAIR_CDR( p2389 ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2401, PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3332; X2 = X1; X2 = UNKNOWNCALL( X2, 0 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( PROCEDURE_CLOSURE( X2 ) ) ); L3332: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt6_format_v ); DEFCSTRING( t3334, "FORMAT" ); EXTERNTSCPP( scrt5_open_2doutput_2dstring, XAL0( ) ); EXTERNTSCP( scrt5_open_2doutput_2dstring_v ); EXTERNTSCPP( scrt6_formatx, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt6_formatx_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP scrt6_format( f2403, a2404 ) TSCP f2403, a2404; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3334 ); f2403 = CONS( f2403, EMPTYLIST ); if ( NEQ( _S2CUINT( PAIR_CAR( f2403 ) ), _S2CUINT( TRUEVALUE ) ) ) goto L3336; X1 = scrt5_current_2doutput_2dport( ); SETGEN( PAIR_CAR( f2403 ), X1 ); L3336: if ( FALSE( PAIR_CAR( f2403 ) ) ) goto L3338; X1 = FALSEVALUE; goto L3339; L3338: X1 = TRUEVALUE; L3339: if ( FALSE( X1 ) ) goto L3356; if ( FALSE( a2404 ) ) goto L3356; if ( EQ( TSCPTAG( a2404 ), PAIRTAG ) ) goto L3350; scrt1__24__car_2derror( a2404 ); L3350: X2 = PAIR_CAR( a2404 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) ) goto L3356; X2 = scrt5_open_2doutput_2dstring( ); X3 = PAIR_CAR( a2404 ); X4 = PAIR_CDR( a2404 ); scrt6_formatx( X2, X3, X4 ); POPSTACKTRACE( scrt6_get_2doutput_2dstring( X2 ) ); L3356: if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( f2403 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( f2403 ) ), STRINGTAG ) ) ) ) goto L3357; X1 = scrt5_open_2doutput_2dstring( ); scrt6_formatx( X1, PAIR_CAR( f2403 ), a2404 ); POPSTACKTRACE( scrt6_get_2doutput_2dstring( X1 ) ); L3357: X1 = scrt5_output_2dport_3f( PAIR_CAR( f2403 ) ); if ( FALSE( X1 ) ) goto L3375; if ( FALSE( a2404 ) ) goto L3375; if ( EQ( TSCPTAG( a2404 ), PAIRTAG ) ) goto L3370; scrt1__24__car_2derror( a2404 ); L3370: X2 = PAIR_CAR( a2404 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) ) goto L3375; X2 = PAIR_CAR( a2404 ); X3 = PAIR_CDR( a2404 ); POPSTACKTRACE( scrt6_formatx( PAIR_CAR( f2403 ), X2, X3 ) ); L3375: POPSTACKTRACE( scdebug_error( c2438, c2439, CONS( sc_cons( PAIR_CAR( f2403 ), a2404 ), EMPTYLIST ) ) ); } DEFTSCP( scrt6_formatx_v ); DEFCSTRING( t3376, "SCRT6_FORMATX" ); TSCP scrt6_a2467( ) { TSCP X3, X2, X1; PUSHSTACKTRACE( "ARG [inside FORMATX]" ); if ( NEQ( _S2CUINT( PAIR_CAR( DISPLAY( 1 ) ) ), _S2CUINT( EMPTYLIST ) ) ) goto L3379; scdebug_error( c2438, c2552, CONS( DISPLAY( 0 ), EMPTYLIST ) ); L3379: X2 = PAIR_CAR( DISPLAY( 1 ) ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3382; scrt1__24__car_2derror( X2 ); L3382: X1 = PAIR_CAR( X2 ); X3 = PAIR_CAR( DISPLAY( 1 ) ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3386; scrt1__24__cdr_2derror( X3 ); L3386: X2 = PAIR_CDR( X3 ); SETGEN( PAIR_CAR( DISPLAY( 1 ) ), X2 ); POPSTACKTRACE( X1 ); } EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt1_memv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memv_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); TSCP scrt6_formatx( p2463, f2464, a2465 ) TSCP p2463, f2464, a2465; { TSCP X6, X5, X4, X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SDVAL; PUSHSTACKTRACE( t3376 ); DISPLAY( 0 ) = f2464; DISPLAY( 1 ) = a2465; DISPLAY( 1 ) = CONS( DISPLAY( 1 ), EMPTYLIST ); X1 = _TSCP( 0 ); X2 = FALSEVALUE; X3 = FALSEVALUE; L3390: X3 = CONS( X3, EMPTYLIST ); X2 = CONS( X2, EMPTYLIST ); if ( AND( EQ( TSCPTAG( DISPLAY( 0 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( DISPLAY( 0 ) ), STRINGTAG ) ) ) goto L3392; scdebug_error( c2487, c2488, CONS( DISPLAY( 0 ), EMPTYLIST ) ); L3392: X4 = C_FIXED( STRING_LENGTH( DISPLAY( 0 ) ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X4 ) ), 3 ) ) goto L3396; if ( EQ( _S2CUINT( X1 ), _S2CUINT( X4 ) ) ) goto L3400; goto L3401; L3396: if ( FALSE( scrt2__3d_2dtwo( X1, X4 ) ) ) goto L3401; L3400: if ( FALSE( PAIR_CAR( X2 ) ) ) goto L3405; scdebug_error( c2438, c2544, CONS( DISPLAY( 0 ), EMPTYLIST ) ); L3405: if ( FALSE( PAIR_CAR( DISPLAY( 1 ) ) ) ) goto L3407; SDVAL = scdebug_error( c2438, c2545, CONS( DISPLAY( 0 ), EMPTYLIST ) ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; POPSTACKTRACE( SDVAL ); L3407: SDVAL = FALSEVALUE; DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; POPSTACKTRACE( SDVAL ); L3401: if ( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L3411; scdebug_error( c2495, c2496, CONS( X1, EMPTYLIST ) ); L3411: X5 = BOOLEAN( LT( _S2CINT( X1 ), 0 ) ); if ( TRUE( X5 ) ) goto L3417; X6 = C_FIXED( STRING_LENGTH( DISPLAY( 0 ) ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X6 ) ), 3 ) ) goto L3421; if ( GTE( _S2CINT( X1 ), _S2CINT( X6 ) ) ) goto L3417; goto L3428; L3421: if ( FALSE( scrt2__3e_3d_2dtwo( X1, X6 ) ) ) goto L3428; L3417: scdebug_error( c2495, c2517, CONS( X1, EMPTYLIST ) ); L3428: X4 = C_CHAR( STRING_CHAR( DISPLAY( 0 ), X1 ) ); SETGEN( PAIR_CAR( X3 ), X4 ); if ( FALSE( PAIR_CAR( X2 ) ) ) goto L3429; X4 = FALSEVALUE; SETGEN( PAIR_CAR( X2 ), X4 ); X4 = PAIR_CAR( X3 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 32274 ) ) ) ) goto L3433; scrt6_display( PAIR_CAR( X3 ), CONS( p2463, EMPTYLIST ) ); goto L3444; L3433: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 9490 ) ) ) ) goto L3435; scrt6_newline( CONS( p2463, EMPTYLIST ) ); goto L3444; L3435: if ( FALSE( scrt1_memv( X4, c2532 ) ) ) goto L3437; X5 = scrt6_a2467( ); scrt6_write( X5, CONS( p2463, EMPTYLIST ) ); goto L3444; L3437: if ( FALSE( scrt1_memv( X4, c2533 ) ) ) goto L3439; X5 = scrt6_a2467( ); scrt6_display( X5, CONS( p2463, EMPTYLIST ) ); goto L3444; L3439: if ( FALSE( scrt1_memv( X4, c2534 ) ) ) goto L3441; X5 = scrt6_a2467( ); scrt6_write_2dchar( X5, CONS( p2463, EMPTYLIST ) ); goto L3444; L3441: scdebug_error( c2438, c2535, CONS( DISPLAY( 0 ), EMPTYLIST ) ); goto L3444; L3429: if ( NEQ( _S2CUINT( PAIR_CAR( X3 ) ), _S2CUINT( _TSCP( 32274 ) ) ) ) goto L3443; X4 = TRUEVALUE; SETGEN( PAIR_CAR( X2 ), X4 ); goto L3444; L3443: scrt6_write_2dchar( PAIR_CAR( X3 ), CONS( p2463, EMPTYLIST ) ); L3444: if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X1 ) ), 3 ) ) goto L3445; X4 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X1 ) ) ); goto L3446; L3445: X4 = scrt2__2b_2dtwo( _TSCP( 4 ), X1 ); L3446: X3 = PAIR_CAR( X3 ); X2 = PAIR_CAR( X2 ); X1 = X4; GOBACK( L3390 ); } DEFTSCP( scrt6_pp_v ); DEFCSTRING( t3447, "PP" ); EXTERNTSCPP( scrt6_pp1, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_pp1_v ); EXTERNTSCPP( scrt5_open_2doutput_2dfile, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2doutput_2dfile_v ); EXTERNTSCPP( scrt5_close_2doutput_2dport, XAL1( TSCP ) ); EXTERNTSCP( scrt5_close_2doutput_2dport_v ); TSCP scrt6_pp( f2564, o2565 ) TSCP f2564, o2565; { TSCP X2, X1; PUSHSTACKTRACE( t3447 ); if ( NEQ( _S2CUINT( o2565 ), _S2CUINT( EMPTYLIST ) ) ) goto L3449; X1 = scrt5_current_2doutput_2dport( ); scrt6_pp1( f2564, X1 ); goto L3452; L3449: if ( EQ( TSCPTAG( o2565 ), PAIRTAG ) ) goto L3454; scrt1__24__car_2derror( o2565 ); L3454: X1 = PAIR_CAR( o2565 ); if ( FALSE( scrt5_output_2dport_3f( X1 ) ) ) goto L3451; X1 = PAIR_CAR( o2565 ); scrt6_pp1( f2564, X1 ); goto L3452; L3451: if ( EQ( TSCPTAG( o2565 ), PAIRTAG ) ) goto L3458; scrt1__24__car_2derror( o2565 ); L3458: X2 = PAIR_CAR( o2565 ); X1 = scrt5_open_2doutput_2dfile( X2 ); scrt6_pp1( f2564, X1 ); scrt5_close_2doutput_2dport( X1 ); L3452: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( scrt6_pp1_v ); DEFCSTRING( t3461, "SCRT6_PP1" ); EXTERNTSCPP( scrt6_print_2din, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_print_2din_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( scrt2_negative_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_negative_3f_v ); EXTERNTSCPP( sc_make_2dstring, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dstring_v ); EXTERNTSCPP( scrt4_vector_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt4_vector_2d_3elist_v ); TSCP scrt6_pp1( f2587, p2588 ) TSCP f2587, p2588; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3461 ); L3462: X1 = scrt6_write_2dcount( CONS( p2588, EMPTYLIST ) ); X4 = scrt6_write_2dwidth( CONS( p2588, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( X1 ) ), 3 ) ) goto L3465; X3 = _TSCP( IDIFFERENCE( _S2CINT( X4 ), _S2CINT( X1 ) ) ); goto L3466; L3465: X3 = scrt2__2d_2dtwo( X4, X1 ); L3466: X2 = scrt6_print_2din( f2587, X3 ); if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L3469; if ( LT( _S2CINT( X2 ), 0 ) ) goto L3473; goto L3474; L3469: if ( FALSE( scrt2_negative_3f( X2 ) ) ) goto L3474; L3473: if ( NEQ( TSCPTAG( f2587 ), PAIRTAG ) ) goto L3477; scrt6_display( c2606, CONS( p2588, EMPTYLIST ) ); X2 = PAIR_CAR( f2587 ); scrt6_pp1( X2, p2588 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L3482; X3 = _TSCP( IPLUS( _S2CINT( X1 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L3483; L3482: X3 = scrt2__2b_2dtwo( X1, _TSCP( 8 ) ); L3483: X2 = sc_make_2dstring( X3, CONS( _TSCP( 8210 ), EMPTYLIST ) ); X3 = PAIR_CDR( f2587 ); L3485: if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3486; scrt6_newline( CONS( p2588, EMPTYLIST ) ); scrt6_display( X2, CONS( p2588, EMPTYLIST ) ); X4 = PAIR_CAR( X3 ); scrt6_pp1( X4, p2588 ); X3 = PAIR_CDR( X3 ); GOBACK( L3485 ); L3486: if ( FALSE( X3 ) ) goto L3492; scrt6_newline( CONS( p2588, EMPTYLIST ) ); scrt6_display( X2, CONS( p2588, EMPTYLIST ) ); scrt6_display( c2629, CONS( p2588, EMPTYLIST ) ); scrt6_pp1( X3, p2588 ); L3492: POPSTACKTRACE( scrt6_display( c2630, CONS( p2588, EMPTYLIST ) ) ); L3477: if ( NOT( AND( EQ( TSCPTAG( f2587 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( f2587 ), VECTORTAG ) ) ) ) goto L3495; scrt6_display( c2604, CONS( p2588, EMPTYLIST ) ); X2 = scrt4_vector_2d_3elist( f2587 ); f2587 = X2; GOBACK( L3462 ); L3495: POPSTACKTRACE( scrt6_write( f2587, CONS( p2588, EMPTYLIST ) ) ); L3474: POPSTACKTRACE( scrt6_write( f2587, CONS( p2588, EMPTYLIST ) ) ); } DEFTSCP( scrt6_print_2din_v ); DEFCSTRING( t3498, "SCRT6_PRINT-IN" ); TSCP scrt6_print_2din( f2651, l2652 ) TSCP f2651, l2652; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3498 ); L3499: if ( NEQ( TSCPTAG( l2652 ), FIXNUMTAG ) ) goto L3501; if ( GTE( _S2CINT( l2652 ), 0 ) ) goto L3505; POPSTACKTRACE( l2652 ); L3501: if ( FALSE( scrt2_negative_3f( l2652 ) ) ) goto L3505; POPSTACKTRACE( l2652 ); L3505: if ( NEQ( TSCPTAG( f2651 ), PAIRTAG ) ) goto L3508; X1 = PAIR_CDR( f2651 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3510; X2 = PAIR_CAR( f2651 ); if ( BITAND( BITOR( _S2CINT( l2652 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3514; X3 = _TSCP( IDIFFERENCE( _S2CINT( l2652 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3515; L3514: X3 = scrt2__2d_2dtwo( l2652, _TSCP( 4 ) ); L3515: X1 = scrt6_print_2din( X2, X3 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3517; POPSTACKTRACE( _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ) ); L3517: POPSTACKTRACE( scrt2__2d_2dtwo( X1, _TSCP( 4 ) ) ); L3510: X1 = PAIR_CDR( f2651 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3519; X1 = PAIR_CDR( f2651 ); X2 = PAIR_CAR( f2651 ); if ( BITAND( BITOR( _S2CINT( l2652 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3524; X3 = _TSCP( IDIFFERENCE( _S2CINT( l2652 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3525; L3524: X3 = scrt2__2d_2dtwo( l2652, _TSCP( 4 ) ); L3525: l2652 = scrt6_print_2din( X2, X3 ); f2651 = X1; GOBACK( L3499 ); L3519: X1 = PAIR_CDR( f2651 ); X2 = PAIR_CAR( f2651 ); if ( BITAND( BITOR( _S2CINT( l2652 ), _S2CINT( _TSCP( 20 ) ) ), 3 ) ) goto L3528; X3 = _TSCP( IDIFFERENCE( _S2CINT( l2652 ), _S2CINT( _TSCP( 20 ) ) ) ); goto L3529; L3528: X3 = scrt2__2d_2dtwo( l2652, _TSCP( 20 ) ); L3529: l2652 = scrt6_print_2din( X2, X3 ); f2651 = X1; GOBACK( L3499 ); L3508: if ( NOT( AND( EQ( TSCPTAG( f2651 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( f2651 ), VECTORTAG ) ) ) ) goto L3530; X1 = scrt4_vector_2d_3elist( f2651 ); if ( BITAND( BITOR( _S2CINT( l2652 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3532; l2652 = _TSCP( IDIFFERENCE( _S2CINT( l2652 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3533; L3532: l2652 = scrt2__2d_2dtwo( l2652, _TSCP( 4 ) ); L3533: f2651 = X1; GOBACK( L3499 ); L3530: X1 = scrt5_open_2doutput_2dstring( ); scrt6_write( f2651, CONS( X1, EMPTYLIST ) ); X3 = scrt6_get_2doutput_2dstring( X1 ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), STRINGTAG ) ) ) goto L3536; scdebug_error( c2487, c2488, CONS( X3, EMPTYLIST ) ); L3536: X2 = C_FIXED( STRING_LENGTH( X3 ) ); if ( BITAND( BITOR( _S2CINT( l2652 ), _S2CINT( X2 ) ), 3 ) ) goto L3539; POPSTACKTRACE( _TSCP( IDIFFERENCE( _S2CINT( l2652 ), _S2CINT( X2 ) ) ) ); L3539: POPSTACKTRACE( scrt2__2d_2dtwo( l2652, X2 ) ); } DEFTSCP( scrt6_remove_2dfile_v ); DEFCSTRING( t3541, "REMOVE-FILE" ); EXTERNTSCPP( sc_removefile, XAL1( TSCP ) ); EXTERNTSCP( sc_removefile_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); TSCP scrt6_remove_2dfile( f2742 ) TSCP f2742; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3541 ); if ( AND( EQ( TSCPTAG( f2742 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( f2742 ), STRINGTAG ) ) ) goto L3543; scdebug_error( c2745, c2488, CONS( f2742, EMPTYLIST ) ); L3543: X1 = sc_removefile( f2742 ); if ( FALSE( X1 ) ) goto L3546; X3 = CONS( c2748, EMPTYLIST ); X2 = scrt3_string_2dappend( CONS( X1, X3 ) ); POPSTACKTRACE( scdebug_error( c2745, X2, CONS( f2742, EMPTYLIST ) ) ); L3546: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt6_rename_2dfile_v ); DEFCSTRING( t3548, "RENAME-FILE" ); EXTERNTSCPP( sc_rename, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_rename_v ); TSCP scrt6_rename_2dfile( o2750, n2751 ) TSCP o2750, n2751; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3548 ); if ( AND( EQ( TSCPTAG( o2750 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o2750 ), STRINGTAG ) ) ) goto L3550; scdebug_error( c2754, c2488, CONS( o2750, EMPTYLIST ) ); L3550: if ( AND( EQ( TSCPTAG( n2751 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( n2751 ), STRINGTAG ) ) ) goto L3552; scdebug_error( c2754, c2488, CONS( n2751, EMPTYLIST ) ); L3552: X1 = sc_rename( o2750, n2751 ); if ( FALSE( X1 ) ) goto L3555; X3 = CONS( c2759, EMPTYLIST ); X2 = scrt3_string_2dappend( CONS( X1, X3 ) ); X3 = CONS( n2751, EMPTYLIST ); POPSTACKTRACE( scdebug_error( c2754, X2, CONS( o2750, X3 ) ) ); L3555: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt6_system_2dtasking_v ); DEFCSTRING( t3557, "SCRT6_SYSTEM-TASKING" ); DEFTSCP( scrt6_system_2dfile_2dmask_v ); DEFCSTRING( t3558, "SCRT6_SYSTEM-FILE-MASK" ); DEFTSCP( scrt6_max_2dsystem_2dfile_v ); DEFCSTRING( t3559, "SCRT6_MAX-SYSTEM-FILE" ); DEFTSCP( scrt6_system_2dfile_2dtask_v ); DEFCSTRING( t3560, "SCRT6_SYSTEM-FILE-TASK" ); DEFTSCP( scrt6_idle_2dtasks_v ); DEFCSTRING( t3561, "SCRT6_IDLE-TASKS" ); EXTERNTSCPP( sc_make_2dvector, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dvector_v ); DEFTSCP( scrt6_file_2dtasks_v ); DEFCSTRING( t3562, "SCRT6_FILE-TASKS" ); DEFTSCP( scrt6_ile_2dtask_5ef7698b_v ); DEFCSTRING( t3563, "DEFINE-SYSTEM-FILE-TASK" ); EXTERNTSCPP( scrt4_bit_2dor, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2dor_v ); EXTERNTSCPP( scrt4_bit_2dlsh, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2dlsh_v ); TSCP scrt6_ile_2dtask_5ef7698b( f2768, i2769, f2770 ) TSCP f2768, i2769, f2770; { TSCP X2, X1; PUSHSTACKTRACE( t3563 ); X1 = scrt6_idle_2dtasks_v; if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L3566; scdebug_error( c2777, c2778, CONS( X1, EMPTYLIST ) ); L3566: if ( EQ( TSCPTAG( f2768 ), FIXNUMTAG ) ) goto L3568; scdebug_error( c2777, c2496, CONS( f2768, EMPTYLIST ) ); L3568: if ( LT( _S2CUINT( FIXED_C( f2768 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L3570; scdebug_error( c2777, c2784, CONS( f2768, EMPTYLIST ) ); L3570: SETGEN( VECTOR_ELEMENT( X1, f2768 ), i2769 ); X1 = scrt6_file_2dtasks_v; if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L3573; scdebug_error( c2777, c2778, CONS( X1, EMPTYLIST ) ); L3573: if ( LT( _S2CUINT( FIXED_C( f2768 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L3575; scdebug_error( c2777, c2784, CONS( f2768, EMPTYLIST ) ); L3575: SETGEN( VECTOR_ELEMENT( X1, f2768 ), f2770 ); scrt6_system_2dfile_2dmask_v = _TSCP( 0 ); scrt6_max_2dsystem_2dfile_v = _TSCP( -4 ); X1 = _TSCP( 0 ); L3578: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 128 ) ) ), 3 ) ) goto L3580; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 128 ) ) ) ) goto L3584; goto L3587; L3580: if ( TRUE( scrt2__3d_2dtwo( X1, _TSCP( 128 ) ) ) ) goto L3587; L3584: X2 = scrt6_file_2dtasks_v; if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), VECTORTAG ) ) ) goto L3590; scdebug_error( c2815, c2778, CONS( X2, EMPTYLIST ) ); L3590: if ( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L3592; scdebug_error( c2815, c2496, CONS( X1, EMPTYLIST ) ); L3592: if ( LT( _S2CUINT( FIXED_C( X1 ) ), _S2CUINT( VECTOR_LENGTH( X2 ) ) ) ) goto L3594; scdebug_error( c2815, c2784, CONS( X1, EMPTYLIST ) ); L3594: if ( FALSE( VECTOR_ELEMENT( X2, X1 ) ) ) goto L3596; scrt6_max_2dsystem_2dfile_v = X1; scrt6_system_2dfile_2dmask_v = scrt4_bit_2dor( scrt6_system_2dfile_2dmask_v, CONS( scrt4_bit_2dlsh( _TSCP( 4 ), X1 ), EMPTYLIST ) ); L3596: if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X1 ) ), 3 ) ) goto L3599; X1 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X1 ) ) ); GOBACK( L3578 ); L3599: X1 = scrt2__2b_2dtwo( _TSCP( 4 ), X1 ); GOBACK( L3578 ); L3587: POPSTACKTRACE( f2768 ); } DEFTSCP( scrt6_wait_2dsystem_2dfile_v ); DEFCSTRING( t3601, "WAIT-SYSTEM-FILE" ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); EXTERNTSCP( screp__2areading_2dstdin_2a_v ); EXTERNTSCPP( sc_inputready, XAL1( TSCP ) ); EXTERNTSCP( sc_inputready_v ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); EXTERNTSCPP( scrt4_bit_2dand, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2dand_v ); TSCP scrt6_wait_2dsystem_2dfile( f2829 ) TSCP f2829; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3601 ); L3602: if ( EQ( _S2CUINT( scrt6_system_2dfile_2dmask_v ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3603; if ( FALSE( scrt6_system_2dtasking_v ) ) goto L3605; if ( NEQ( _S2CUINT( f2829 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3608; scrt6_flush_2dbuffer( CONS( scrt5_stdout_2dport_v, EMPTYLIST ) ); L3608: X2 = _TSCP( 0 ); L3611: X3 = scrt6_max_2dsystem_2dfile_v; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X3 ) ), 3 ) ) goto L3614; if ( LTE( _S2CINT( X2 ), _S2CINT( X3 ) ) ) goto L3618; goto L3621; L3614: if ( TRUE( scrt2__3e_2dtwo( X2, X3 ) ) ) goto L3621; L3618: X3 = scrt6_idle_2dtasks_v; if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), VECTORTAG ) ) ) goto L3624; scdebug_error( c2815, c2778, CONS( X3, EMPTYLIST ) ); L3624: if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L3626; scdebug_error( c2815, c2496, CONS( X2, EMPTYLIST ) ); L3626: if ( LT( _S2CUINT( FIXED_C( X2 ) ), _S2CUINT( VECTOR_LENGTH( X3 ) ) ) ) goto L3628; scdebug_error( c2815, c2784, CONS( X2, EMPTYLIST ) ); L3628: if ( FALSE( VECTOR_ELEMENT( X3, X2 ) ) ) goto L3630; X4 = screp__2areading_2dstdin_2a_v; screp__2areading_2dstdin_2a_v = FALSEVALUE; X6 = scrt6_idle_2dtasks_v; if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), VECTORTAG ) ) ) goto L3634; scdebug_error( c2815, c2778, CONS( X6, EMPTYLIST ) ); L3634: if ( LT( _S2CUINT( FIXED_C( X2 ) ), _S2CUINT( VECTOR_LENGTH( X6 ) ) ) ) goto L3636; scdebug_error( c2815, c2784, CONS( X2, EMPTYLIST ) ); L3636: X5 = VECTOR_ELEMENT( X6, X2 ); X5 = UNKNOWNCALL( X5, 0 ); VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); screp__2areading_2dstdin_2a_v = X4; L3630: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3638; X2 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L3611 ); L3638: X2 = scrt2__2b_2dtwo( X2, _TSCP( 4 ) ); GOBACK( L3611 ); L3621: if ( FALSE( f2829 ) ) goto L3640; X3 = scrt4_bit_2dlsh( _TSCP( 4 ), f2829 ); goto L3641; L3640: X3 = _TSCP( 0 ); L3641: X2 = scrt4_bit_2dor( scrt6_system_2dfile_2dmask_v, CONS( X3, EMPTYLIST ) ); X1 = sc_inputready( X2 ); if ( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L3644; if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ) GOBACK( L3602 ); goto L3649; L3644: if ( TRUE( scrt2_zero_3f( X1 ) ) ) GOBACK( L3602 ); goto L3649; L3605: POPSTACKTRACE( FALSEVALUE ); L3603: POPSTACKTRACE( FALSEVALUE ); L3649: X2 = _TSCP( 0 ); X3 = _TSCP( 4 ); L3654: X4 = scrt6_max_2dsystem_2dfile_v; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) goto L3657; if ( LTE( _S2CINT( X2 ), _S2CINT( X4 ) ) ) goto L3661; goto L3664; L3657: if ( TRUE( scrt2__3e_2dtwo( X2, X4 ) ) ) goto L3664; L3661: X4 = scrt4_bit_2dand( X3, CONS( X1, EMPTYLIST ) ); if ( EQ( _S2CUINT( _TSCP( 0 ) ), _S2CUINT( X4 ) ) ) goto L3676; X5 = scrt6_file_2dtasks_v; if ( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), VECTORTAG ) ) ) goto L3669; scdebug_error( c2815, c2778, CONS( X5, EMPTYLIST ) ); L3669: if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L3671; scdebug_error( c2815, c2496, CONS( X2, EMPTYLIST ) ); L3671: if ( LT( _S2CUINT( FIXED_C( X2 ) ), _S2CUINT( VECTOR_LENGTH( X5 ) ) ) ) goto L3673; scdebug_error( c2815, c2784, CONS( X2, EMPTYLIST ) ); L3673: X4 = VECTOR_ELEMENT( X5, X2 ); if ( FALSE( X4 ) ) goto L3676; X5 = screp__2areading_2dstdin_2a_v; screp__2areading_2dstdin_2a_v = FALSEVALUE; scrt6_system_2dfile_2dtask_v = X2; X6 = X4; X6 = UNKNOWNCALL( X6, 0 ); VIA( PROCEDURE_CODE( X6 ) )( PROCEDURE_CLOSURE( X6 ) ); screp__2areading_2dstdin_2a_v = X5; L3676: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3679; X4 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3680; L3679: X4 = scrt2__2b_2dtwo( X2, _TSCP( 4 ) ); L3680: X3 = scrt4_bit_2dlsh( X3, _TSCP( 4 ) ); X2 = X4; GOBACK( L3654 ); L3664: scrt6_system_2dfile_2dtask_v = FALSEVALUE; if ( FALSE( f2829 ) ) goto L3681; X2 = FALSEVALUE; goto L3682; L3681: X2 = TRUEVALUE; L3682: if ( TRUE( X2 ) ) GOBACK( L3602 ); X3 = scrt4_bit_2dand( X1, CONS( scrt4_bit_2dlsh( _TSCP( 4 ), f2829 ), EMPTYLIST ) ); if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L3690; if ( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ) GOBACK( L3602 ); POPSTACKTRACE( FALSEVALUE ); L3690: if ( TRUE( scrt2_zero_3f( X3 ) ) ) GOBACK( L3602 ); POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt6_le_2dtasks_e4d983f4_v ); DEFCSTRING( t3697, "ENABLE-SYSTEM-FILE-TASKS" ); TSCP scrt6_le_2dtasks_e4d983f4( e2941 ) TSCP e2941; { TSCP X2, X1; PUSHSTACKTRACE( t3697 ); X1 = scrt6_system_2dtasking_v; if ( FALSE( e2941 ) ) goto L3700; X2 = TRUEVALUE; goto L3701; L3700: X2 = FALSEVALUE; L3701: scrt6_system_2dtasking_v = X2; if ( NEQ( _S2CUINT( e2941 ), _S2CUINT( c2947 ) ) ) goto L3702; scrt6_wait_2dsystem_2dfile( FALSEVALUE ); L3702: POPSTACKTRACE( X1 ); } void screp__init(); void scrt3__init(); void scrt4__init(); void scrt2__init(); void scrt7__init(); void scdebug__init(); void scrt5__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { screp__init(); scrt3__init(); scrt4__init(); scrt2__init(); scrt7__init(); scdebug__init(); scrt5__init(); scrt1__init(); MAXDISPLAY( 2 ); } void scrt6__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scrt6 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3128, ADR( scrt6_pending_2dstdout_v ), FALSEVALUE ); INITIALIZEVAR( t3129, ADR( scrt6_input_2dport_v ), MAKEPROCEDURE( 2, 0, scrt6_input_2dport, EMPTYLIST ) ); INITIALIZEVAR( t3147, ADR( scrt6_read_v ), MAKEPROCEDURE( 0, 1, scrt6_read, EMPTYLIST ) ); INITIALIZEVAR( t3149, ADR( scrt6_read_2dchar_v ), MAKEPROCEDURE( 0, 1, scrt6_read_2dchar, EMPTYLIST ) ); INITIALIZEVAR( t3151, ADR( scrt6_peek_2dchar_v ), MAKEPROCEDURE( 0, 1, scrt6_peek_2dchar, EMPTYLIST ) ); INITIALIZEVAR( t3153, ADR( scrt6_char_2dready_3f_v ), MAKEPROCEDURE( 0, 1, scrt6_char_2dready_3f, EMPTYLIST ) ); INITIALIZEVAR( t3155, ADR( scrt6_eof_2dobject_3f_v ), MAKEPROCEDURE( 1, 0, scrt6_eof_2dobject_3f, EMPTYLIST ) ); INITIALIZEVAR( t3157, ADR( scrt6_output_2dport_v ), MAKEPROCEDURE( 2, 0, scrt6_output_2dport, EMPTYLIST ) ); INITIALIZEVAR( t3181, ADR( scrt6_write_v ), MAKEPROCEDURE( 1, 1, scrt6_write, EMPTYLIST ) ); INITIALIZEVAR( t3183, ADR( scrt6_display_v ), MAKEPROCEDURE( 1, 1, scrt6_display, EMPTYLIST ) ); INITIALIZEVAR( t3185, ADR( scrt6_write_2dchar_v ), MAKEPROCEDURE( 1, 1, scrt6_write_2dchar, EMPTYLIST ) ); INITIALIZEVAR( t3189, ADR( scrt6_newline_v ), MAKEPROCEDURE( 0, 1, scrt6_newline, EMPTYLIST ) ); INITIALIZEVAR( t3191, ADR( scrt6_flush_2dbuffer_v ), MAKEPROCEDURE( 0, 1, scrt6_flush_2dbuffer, EMPTYLIST ) ); INITIALIZEVAR( t3193, ADR( scrt6_get_2doutput_2dstring_v ), MAKEPROCEDURE( 1, 0, scrt6_get_2doutput_2dstring, EMPTYLIST ) ); INITIALIZEVAR( t3204, ADR( scrt6_write_2dcount_v ), MAKEPROCEDURE( 0, 1, scrt6_write_2dcount, EMPTYLIST ) ); INITIALIZEVAR( t3206, ADR( scrt6_write_2dwidth_v ), MAKEPROCEDURE( 0, 1, scrt6_write_2dwidth, EMPTYLIST ) ); INITIALIZEVAR( t3208, ADR( scrt6_set_2dwrite_2dwidth_21_v ), MAKEPROCEDURE( 1, 1, scrt6_set_2dwrite_2dwidth_21, EMPTYLIST ) ); INITIALIZEVAR( t3224, ADR( scrt6_write_2dcircle_v ), MAKEPROCEDURE( 0, 1, scrt6_write_2dcircle, EMPTYLIST ) ); INITIALIZEVAR( t3226, ADR( scrt6_set_2dwrite_2dcircle_21_v ), MAKEPROCEDURE( 1, 1, scrt6_set_2dwrite_2dcircle_21, EMPTYLIST ) ); INITIALIZEVAR( t3230, ADR( scrt6_write_2dlevel_v ), MAKEPROCEDURE( 0, 1, scrt6_write_2dlevel, EMPTYLIST ) ); INITIALIZEVAR( t3232, ADR( scrt6_set_2dwrite_2dlevel_21_v ), MAKEPROCEDURE( 1, 1, scrt6_set_2dwrite_2dlevel_21, EMPTYLIST ) ); INITIALIZEVAR( t3249, ADR( scrt6_write_2dlength_v ), MAKEPROCEDURE( 0, 1, scrt6_write_2dlength, EMPTYLIST ) ); INITIALIZEVAR( t3251, ADR( scrt6_set_2dwrite_2dlength_21_v ), MAKEPROCEDURE( 1, 1, scrt6_set_2dwrite_2dlength_21, EMPTYLIST ) ); INITIALIZEVAR( t3268, ADR( scrt6_write_2dpretty_v ), MAKEPROCEDURE( 0, 1, scrt6_write_2dpretty, EMPTYLIST ) ); INITIALIZEVAR( t3270, ADR( scrt6_set_2dwrite_2dpretty_21_v ), MAKEPROCEDURE( 1, 1, scrt6_set_2dwrite_2dpretty_21, EMPTYLIST ) ); INITIALIZEVAR( t3274, ADR( scrt6_echo_v ), MAKEPROCEDURE( 1, 1, scrt6_echo, EMPTYLIST ) ); INITIALIZEVAR( t3303, ADR( scrt6_transcript_2don_v ), MAKEPROCEDURE( 1, 0, scrt6_transcript_2don, EMPTYLIST ) ); INITIALIZEVAR( t3314, ADR( scrt6_transcript_2doff_v ), MAKEPROCEDURE( 0, 0, scrt6_transcript_2doff, EMPTYLIST ) ); INITIALIZEVAR( t3319, ADR( scrt6_port_2d_3estdio_2dfile_v ), MAKEPROCEDURE( 1, 0, scrt6_port_2d_3estdio_2dfile, EMPTYLIST ) ); INITIALIZEVAR( t3334, ADR( scrt6_format_v ), MAKEPROCEDURE( 1, 1, scrt6_format, EMPTYLIST ) ); INITIALIZEVAR( t3376, ADR( scrt6_formatx_v ), MAKEPROCEDURE( 3, 0, scrt6_formatx, EMPTYLIST ) ); INITIALIZEVAR( t3447, ADR( scrt6_pp_v ), MAKEPROCEDURE( 1, 1, scrt6_pp, EMPTYLIST ) ); INITIALIZEVAR( t3461, ADR( scrt6_pp1_v ), MAKEPROCEDURE( 2, 0, scrt6_pp1, EMPTYLIST ) ); INITIALIZEVAR( t3498, ADR( scrt6_print_2din_v ), MAKEPROCEDURE( 2, 0, scrt6_print_2din, EMPTYLIST ) ); INITIALIZEVAR( t3541, ADR( scrt6_remove_2dfile_v ), MAKEPROCEDURE( 1, 0, scrt6_remove_2dfile, EMPTYLIST ) ); INITIALIZEVAR( t3548, ADR( scrt6_rename_2dfile_v ), MAKEPROCEDURE( 2, 0, scrt6_rename_2dfile, EMPTYLIST ) ); INITIALIZEVAR( t3557, ADR( scrt6_system_2dtasking_v ), TRUEVALUE ); INITIALIZEVAR( t3558, ADR( scrt6_system_2dfile_2dmask_v ), _TSCP( 0 ) ); INITIALIZEVAR( t3559, ADR( scrt6_max_2dsystem_2dfile_v ), _TSCP( -4 ) ); INITIALIZEVAR( t3560, ADR( scrt6_system_2dfile_2dtask_v ), FALSEVALUE ); INITIALIZEVAR( t3561, ADR( scrt6_idle_2dtasks_v ), sc_make_2dvector( _TSCP( 128 ), CONS( FALSEVALUE, EMPTYLIST ) ) ); INITIALIZEVAR( t3562, ADR( scrt6_file_2dtasks_v ), sc_make_2dvector( _TSCP( 128 ), CONS( FALSEVALUE, EMPTYLIST ) ) ); INITIALIZEVAR( t3563, ADR( scrt6_ile_2dtask_5ef7698b_v ), MAKEPROCEDURE( 3, 0, scrt6_ile_2dtask_5ef7698b, EMPTYLIST ) ); INITIALIZEVAR( t3601, ADR( scrt6_wait_2dsystem_2dfile_v ), MAKEPROCEDURE( 1, 0, scrt6_wait_2dsystem_2dfile, EMPTYLIST ) ); INITIALIZEVAR( t3697, ADR( scrt6_le_2dtasks_e4d983f4_v ), MAKEPROCEDURE( 1, 0, scrt6_le_2dtasks_e4d983f4, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/scrt6.sc000066400000000000000000000335271203736146400161560ustar00rootroot00000000000000;;; SCHEME->C Runtime Library ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scrt6 (top-level READ READ-CHAR PEEK-CHAR CHAR-READY? EOF-OBJECT? WRITE DISPLAY WRITE-CHAR NEWLINE FLUSH-BUFFER GET-OUTPUT-STRING WRITE-COUNT WRITE-WIDTH SET-WRITE-WIDTH! WRITE-CIRCLE SET-WRITE-CIRCLE! WRITE-LEVEL SET-WRITE-LEVEL! WRITE-LENGTH SET-WRITE-LENGTH! WRITE-PRETTY SET-WRITE-PRETTY! ECHO TRANSCRIPT-ON TRANSCRIPT-OFF PORT->STDIO-FILE FORMAT PP REMOVE-FILE RENAME-FILE DEFINE-SYSTEM-FILE-TASK WAIT-SYSTEM-FILE ENABLE-SYSTEM-FILE-TASKS)) (include "repdef.sc") ;;; 6.10.2. Input ;;; Verify that an optional input port was supplied, and return the procedure ;;; to acquire the port methods. Flush stdout if working with stdin and it ;;; has pending operations. (define PENDING-STDOUT #f) (define (INPUT-PORT func pl) (let ((port (if pl (let ((port (car pl))) (if (not (input-port? port)) (error func "Argument is not an INPUT-PORT: ~s" port) port)) (current-input-port)))) (if (and (eq? port stdin-port) pending-stdout) (flush-buffer stdout-port)) (cdr port))) (define (READ . port) (read-datum (input-port 'read port))) (define (READ-CHAR . port) (((input-port 'read-char port) 'read-char))) (define (PEEK-CHAR . port) (((input-port 'peek-char port) 'peek-char))) (define (CHAR-READY? . port) (((input-port 'char-ready? port) 'char-ready?))) (define (EOF-OBJECT? obj) (eq? obj $_eof-object)) ;;; 6.10.3. Output ;;; Verify that an optional output port was supplied, and return the procedure ;;; to acquire the port methods. (define (OUTPUT-PORT func pl) (let ((port (if pl (let ((port (car pl))) (if (not (output-port? port)) (error func "Argument is not an OUTPUT-PORT: ~s" port) port)) (current-output-port)))) (cond ((and (eq? port stderr-port) pending-stdout) (flush-buffer stdout-port)) ((eq? port stdout-port) (set! pending-stdout (not (eq? func 'flush-buffer))))) (cdr port))) (define (WRITE obj . port) (write/display obj #t (output-port 'write port))) (define (DISPLAY obj . port) (write/display obj #f (output-port 'display port))) (define (WRITE-CHAR char . port) (if (not (char? char)) (error 'WRITE-CHAR "Argument is not a CHARACTER: ~s" char)) (((output-port 'write-char port) 'write-char) char)) (define (NEWLINE . port) (((output-port 'newline port) 'write-char) #\newline)) (define (FLUSH-BUFFER . port) (((output-port 'flush-buffer port) 'write-flush))) (define (GET-OUTPUT-STRING port) (let ((s (and (output-port? port) (((cdr port) 'get-output-string))))) (if s s (error 'GET-OUTPUT-STRING "Argument is not an OUTPUT STRING PORT: ~s" port)))) (define (WRITE-COUNT . port) (((output-port 'write-count port) 'write-count))) (define (WRITE-WIDTH . port) (((output-port 'write-width port) 'write-width))) (define (SET-WRITE-WIDTH! width . port) (if (or (not (fixed? width)) (<= width 0)) (error 'SET-WRITE-WIDTH! "Argument is not a POSITIVE INTEGER: ~s" width)) (((output-port 'set-write-width! port) 'write-width!) width)) (define (WRITE-CIRCLE . port) (((output-port 'write-circle port) 'write-circle))) (define (SET-WRITE-CIRCLE! flag . port) (if (not (boolean? flag)) (error 'SET-WRITE-CIRCLE! "Argument is not a BOOLEAN: ~s" flag)) (((output-port 'set-write-circle! port) 'write-circle!) flag)) (define (WRITE-LEVEL . port) (((output-port 'write-level port) 'write-level))) (define (SET-WRITE-LEVEL! level . port) (if (not (or (eq? level #f) (and (fixed? level) (>= level 0)))) (error 'SET-WRITE-LEVEL! "Argument is not #F or a NON-NEGATIVE INTEGER: ~s" level)) (((output-port 'set-write-level! port) 'write-level!) level)) (define (WRITE-LENGTH . port) (((output-port 'write-length port) 'write-length))) (define (SET-WRITE-LENGTH! length . port) (if (not (or (eq? length #f) (and (fixed? length) (>= length 0)))) (error 'SET-WRITE-LENGTH! "Argument is not #F or a NON-NEGATIVE INTEGER: ~s" length)) (((output-port 'set-write-length! port) 'write-length!) length)) (define (WRITE-PRETTY . port) (((output-port 'write-pretty port) 'write-pretty))) (define (SET-WRITE-PRETTY! flag . port) (if (not (boolean? flag)) (error 'SET-WRITE-PRETTY! "Argument is not a BOOLEAN: ~s" flag)) (((output-port 'set-write-pretty! port) 'write-pretty!) flag)) ;;; 6.10.4. User Interface (define (ECHO port . argl) (if (and (not (input-port? port)) (not (output-port? port))) (error 'ECHO "Argument is not a port: ~s" port)) (if (not ((cdr port) 'echo)) (error 'ECHO "Port does not support ECHO: ~s" port)) (if argl (let ((echo-port (car argl))) (if (and echo-port (not (output-port? echo-port))) (error 'ECHO "Argument is not an OUTPUT PORT or #F: ~s" echo-port)) (if (equal? port echo-port) (error 'ECHO "PORT cannot be echoed to itself: ~s" echo-port)) (((cdr port) 'echo!) echo-port)) (((cdr port) 'echo)))) (define (TRANSCRIPT-ON filename) (if (or (echo stdin-port) (echo stdout-port)) (error 'TRANSCRIPT-ON "A TRANSCRIPT is already in progress")) (let ((port (open-file filename "w"))) (echo stdin-port port) (echo stdout-port port) 'transcript-on)) (define (TRANSCRIPT-OFF) (let ((input-echo (echo stdin-port)) (output-echo (echo stdout-port))) (if (not (equal? input-echo output-echo)) (error 'TRANSCRIPT-OFF "A TRANSCRIPT is not in progress")) (echo stdin-port #f) (echo stdout-port #f) (close-port input-echo))) ;;; *.*. Additional I/O (define (PORT->STDIO-FILE port) (if (or (input-port? port) (output-port? port)) (let ((method ((cdr port) 'file-port))) (if method (method) #f)) (error 'PORT->STDIO-FILE "Argument is not a port: ~s" port))) (define (FORMAT form . args) (if (eq? form #t) (set! form (current-output-port))) (cond ((and (not form) args (string? (car args))) (let ((port (open-output-string))) (formatx port (car args) (cdr args)) (get-output-string port))) ((string? form) (let ((port (open-output-string))) (formatx port form args) (get-output-string port))) ((and (output-port? form) args (string? (car args))) (formatx form (car args) (cdr args))) (else (error 'format "Illegal arguments: ~s" (cons form args))))) (define (FORMATX port form args) (let ((arg (lambda () (if (null? args) (error 'format "Too few ARGUMENTS for ~s" form)) (let ((result (car args))) (set! args (cdr args)) result)))) (do ((i 0 (+ 1 i)) (tilde #f) (c #f)) ((= i (string-length form)) (if tilde (error 'format "FORM ends with a ~~: ~s" form)) (if args (error 'format "Too many ARGUMENTS for ~s" form))) (set! c (string-ref form i)) (if tilde (begin (set! tilde #f) (case c ((#\~) (display c port)) ((#\%) (newline port)) ((#\s #\S) (write (arg) port)) ((#\a #\A) (display (arg) port)) ((#\c #\C) (write-char (arg) port)) (else (error 'format "Unrecognized OUTPUT DESCRIPTOR in ~s" form)))) (cond ((eq? c #\~) (set! tilde #t)) (else (write-char c port))))))) ;;; (PP form [ output ]) pretty-prints the form on the current output port, ;;; another port, or to a file depending upon the value of "output". (define (PP form . output) (cond ((null? output) (pp1 form (current-output-port))) ((output-port? (car output)) (pp1 form (car output))) (else (let ((port (open-output-file (car output)))) (pp1 form port) (close-output-port port)))) #t) (define (PP1 form port) (let* ((indent (write-count port)) (left (print-in form (- (write-width port) indent)))) (cond ((negative? left) (cond ((pair? form) (display "(" port) (pp1 (car form) port) (do ((tab (make-string (+ indent 2) #\space)) (x (cdr form) (cdr x))) ((not (pair? x)) (when x (newline port) (display tab port) (display ". " port) (pp1 x port)) (display ")" port)) (newline port) (display tab port) (pp1 (car x) port))) ((vector? form) (display "#" port) (pp1 (vector->list form) port)) (else (write form port)))) (else (write form port))))) ;;; PRINT-IN is used to decide if a form can be printed in line-length ;;; characters. If it can, then it will return: ;;; line-length - # characters needed ;;; otherwise it will return a negative number. (define (PRINT-IN form line-length) (cond ((negative? line-length) line-length) ((pair? form) (cond ((null? (cdr form)) ;;; End of list (- (print-in (car form) (- line-length 1)) 1)) ((pair? (cdr form)) ;;; Continued list (print-in (cdr form) (print-in (car form) (- line-length 1)))) (else ;;; Dotted pair (print-in (cdr form) (print-in (car form) (- line-length 5)))))) ((vector? form) ;;; Vector is 1 longer than its list (print-in (vector->list form) (- line-length 1))) (else ;;; Print to a string port and measure (let ((port (open-output-string))) (write form port) (- line-length (string-length (get-output-string port))))))) (define (REMOVE-FILE filename) (if (not (string? filename)) (error 'REMOVE-FILE "Argument is not a STRING: ~s" filename)) (let ((status (removefile filename))) (if status (error 'REMOVE-FILE (string-append status ": ~s") filename)))) (define (RENAME-FILE old-filename new-filename) (if (not (string? old-filename)) (error 'RENAME-FILE "Argument is not a STRING: ~s" old-filename)) (if (not (string? new-filename)) (error 'RENAME-FILE "Argument is not a STRING: ~s" new-filename)) (let ((status (rename old-filename new-filename))) (if status (error 'RENAME-FILE (string-append status ": ~s ~s") old-filename new-filename)))) ;;; *.*. System file tasks. ;;; When there are no characters available on a port, the I/O system executes ;;; the idle task associated with each system file and then dispatches system ;;; tasks or continues reading from the port when some read completes. N.B: ;;; ;;; (1) System file tasks never interrupt an executing Scheme program. ;;; (2) System file tasking is disabled while in the debugger. ;;; (3) All pending system file tasks are executed before continuing reads ;;; from the port. ;;; (4) Not all implementations support system file tasks. (define SYSTEM-TASKING #t) (define SYSTEM-FILE-MASK 0) (define MAX-SYSTEM-FILE -1) (define SYSTEM-FILE-TASK #f) (define IDLE-TASKS (make-vector 32 #f)) (define FILE-TASKS (make-vector 32 #f)) ;;; A task is associated with a system file number by the following procedure. ;;; A task is deleted by passing #F for each task procedure. (define (DEFINE-SYSTEM-FILE-TASK file idle-task file-task) (vector-set! idle-tasks file idle-task) (vector-set! file-tasks file file-task) (set! system-file-mask 0) (set! max-system-file -1) (do ((i 0 (+ 1 i))) ((= i 32)) (when (vector-ref file-tasks i) (set! max-system-file i) (set! system-file-mask (bit-or system-file-mask (bit-lsh 1 i))))) file) ;;; A task waits for input on a file by calling the following procedure with ;;; the system file number, or #f. When input is available on the file (<> #f) ;;; or all tasks have completed, the procedure returns. (define (WAIT-SYSTEM-FILE file) (when (and (not (eq? system-file-mask 0)) system-tasking) (if (eq? file 0) (flush-buffer stdout-port)) (do ((i 0 (+ i 1))) ((> i max-system-file)) (if (vector-ref idle-tasks i) (let ((save *reading-stdin*)) (set! *reading-stdin* #f) ((vector-ref idle-tasks i)) (set! *reading-stdin* save)))) (let ((inputs (inputready (bit-or system-file-mask (if file (bit-lsh 1 file) 0))))) (if (zero? inputs) (wait-system-file file) (begin (do ((i 0 (+ i 1)) (mask 1 (bit-lsh mask 1))) ((> i max-system-file)) (if (not (eq? 0 (bit-and mask inputs))) (let ((task (vector-ref file-tasks i))) (if task (let ((save *reading-stdin*)) (set! *reading-stdin* #f) (set! system-file-task i) (task) (set! *reading-stdin* save)))))) (set! system-file-task #f) (if (or (not file) (zero? (bit-and inputs (bit-lsh 1 file)))) (wait-system-file file))))))) ;;; System file tasking is enabled and disabled by the following procedure. ;;; It returns the previous state of system file tasking. When called with ;;; WAIT as its argument, it will not return until all system file tasks have ;;; completed. (define (ENABLE-SYSTEM-FILE-TASKS enable) (let ((prev system-tasking)) (set! system-tasking (if enable #t #f)) (if (eq? enable 'wait) (wait-system-file #f)) prev)) scheme2c-2012.10.14/scrt/scrt7.c000066400000000000000000003763251203736146400160020ustar00rootroot00000000000000 /* SCHEME->C */ #include void scrt7__init(); DEFCSTRING( t4554, "." ); DEFSTATICTSCP( c4097 ); DEFSTATICTSCP( c4090 ); DEFSTATICTSCP( c3872 ); DEFSTATICTSCP( c3824 ); DEFSTATICTSCP( c3743 ); DEFSTATICTSCP( c3711 ); DEFCSTRING( t4556, "#\\space" ); DEFSTATICTSCP( t4555 ); DEFCSTRING( t4558, "#\\return" ); DEFSTATICTSCP( t4557 ); DEFCSTRING( t4560, "#\\formfeed" ); DEFSTATICTSCP( t4559 ); DEFCSTRING( t4562, "#\\linefeed" ); DEFSTATICTSCP( t4561 ); DEFCSTRING( t4564, "#\\newline" ); DEFSTATICTSCP( t4563 ); DEFCSTRING( t4566, "#\\tab" ); DEFSTATICTSCP( t4565 ); DEFCSTRING( t4567, "#\\???" ); DEFSTATICTSCP( c3700 ); DEFSTATICTSCP( c3696 ); DEFSTATICTSCP( c3688 ); DEFCSTRING( t4568, " ...)" ); DEFSTATICTSCP( c3676 ); DEFCSTRING( t4569, ")" ); DEFSTATICTSCP( c3675 ); DEFCSTRING( t4570, " . " ); DEFSTATICTSCP( c3674 ); DEFCSTRING( t4571, " " ); DEFSTATICTSCP( c3654 ); DEFCSTRING( t4572, "..." ); DEFSTATICTSCP( c3596 ); DEFSTATICTSCP( c3595 ); DEFCSTRING( t4574, ",@" ); DEFSTATICTSCP( t4573 ); DEFSTATICTSCP( t4575 ); DEFCSTRING( t4577, "," ); DEFSTATICTSCP( t4576 ); DEFSTATICTSCP( t4578 ); DEFCSTRING( t4580, "`" ); DEFSTATICTSCP( t4579 ); DEFSTATICTSCP( t4581 ); DEFCSTRING( t4583, "'" ); DEFSTATICTSCP( t4582 ); DEFSTATICTSCP( t4584 ); DEFCSTRING( t4585, "(...)" ); DEFSTATICTSCP( c3561 ); DEFCSTRING( t4586, "(" ); DEFSTATICTSCP( c3456 ); DEFSTATICTSCP( c3424 ); DEFSTATICTSCP( t4587 ); DEFSTATICTSCP( t4588 ); DEFCSTRING( t4589, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c3423 ); DEFSTATICTSCP( c3422 ); DEFCSTRING( t4590, "#" ); DEFSTATICTSCP( c3397 ); DEFCSTRING( t4591, "#T" ); DEFSTATICTSCP( c3394 ); DEFCSTRING( t4592, "#F" ); DEFSTATICTSCP( c3393 ); DEFCSTRING( t4593, "()" ); DEFSTATICTSCP( c3392 ); DEFCSTRING( t4594, "#*END-OF-FILE*" ); DEFSTATICTSCP( c3391 ); DEFCSTRING( t4595, "#*UNDEFINED*" ); DEFSTATICTSCP( c3390 ); DEFCSTRING( t4596, "#*PROCEDURE*" ); DEFSTATICTSCP( c3389 ); DEFSTATICTSCP( c3388 ); DEFSTATICTSCP( c3387 ); DEFCSTRING( t4597, "#*??????*" ); DEFSTATICTSCP( c3359 ); DEFCSTRING( t4598, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c3258 ); DEFSTATICTSCP( c3257 ); DEFSTATICTSCP( c3219 ); DEFSTATICTSCP( c3218 ); DEFSTATICTSCP( c3217 ); DEFSTATICTSCP( c3213 ); DEFSTATICTSCP( c3212 ); DEFSTATICTSCP( c3211 ); DEFCSTRING( t4599, "Poorly formed LIST" ); DEFSTATICTSCP( c3192 ); DEFSTATICTSCP( c3168 ); DEFCSTRING( t4600, "Poorly formed DATUM: ~s" ); DEFSTATICTSCP( c3167 ); DEFSTATICTSCP( c3113 ); DEFSTATICTSCP( c3112 ); DEFSTATICTSCP( c3105 ); DEFCSTRING( t4601, "Argument is not an FIXED: ~s" ); DEFSTATICTSCP( c3104 ); DEFSTATICTSCP( c3103 ); DEFCSTRING( t4602, "Argument is out of range: ~s" ); DEFSTATICTSCP( c2981 ); DEFCSTRING( t4603, "Argument is not a FLOAT: ~s" ); DEFSTATICTSCP( c2976 ); DEFSTATICTSCP( c2975 ); DEFSTATICTSCP( c2946 ); DEFCSTRING( t4604, "Illegal floating point number: ~a" ); DEFSTATICTSCP( c2936 ); DEFCSTRING( t4605, "Floating point numbers must be base 10: ~a" ); DEFSTATICTSCP( c2933 ); DEFCSTRING( t4606, "Illegal digit(s) in integer: ~a" ); DEFSTATICTSCP( c2929 ); DEFCSTRING( t4607, "Invalid number base: ~a" ); DEFSTATICTSCP( c2833 ); DEFSTATICTSCP( c2832 ); DEFSTATICTSCP( c2831 ); DEFSTATICTSCP( c2830 ); DEFSTATICTSCP( c2829 ); DEFSTATICTSCP( c2766 ); DEFSTATICTSCP( c2724 ); DEFCSTRING( t4608, "Index is not in bounds: ~s" ); DEFSTATICTSCP( c2610 ); DEFCSTRING( t4609, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2606 ); DEFCSTRING( t4610, "Argument is not a VECTOR: ~s" ); DEFSTATICTSCP( c2603 ); DEFSTATICTSCP( c2602 ); DEFCSTRING( t4611, "Argument not an unsigned 8-bit INTEGER: ~s" ); DEFSTATICTSCP( c2456 ); DEFSTATICTSCP( c2455 ); DEFCSTRING( t4612, "Unrecognized CHARACTER NAME: ~s" ); DEFSTATICTSCP( c2429 ); DEFSTATICTSCP( c2428 ); DEFSTATICTSCP( c2424 ); DEFSTATICTSCP( c2420 ); DEFSTATICTSCP( c2416 ); DEFSTATICTSCP( c2412 ); DEFSTATICTSCP( c2408 ); DEFSTATICTSCP( c2354 ); DEFCSTRING( t4613, "Invalid # option: ~a" ); DEFSTATICTSCP( c2323 ); DEFSTATICTSCP( c2256 ); DEFSTATICTSCP( c2228 ); DEFCSTRING( t4614, "Argument(s) not CHAR: ~s ~s" ); DEFSTATICTSCP( c2175 ); DEFSTATICTSCP( c2174 ); DEFCSTRING( t4615, "Unexpected end-of-file" ); DEFSTATICTSCP( c2156 ); DEFSTATICTSCP( c2155 ); DEFSTATICTSCP( c2147 ); DEFSTATICTSCP( c2145 ); DEFSTATICTSCP( c2143 ); DEFSTATICTSCP( c2141 ); DEFSTATICTSCP( c2139 ); DEFSTATICTSCP( c2137 ); DEFSTATICTSCP( c2135 ); DEFSTATICTSCP( c2133 ); DEFSTATICTSCP( c2131 ); static void init_constants() { TSCP X1; c4097 = CSTRING_TSCP( t4554 ); CONSTANTEXP( ADR( c4097 ) ); c4090 = EMPTYLIST; c4090 = CONS( _TSCP( 25874 ), c4090 ); c4090 = CONS( _TSCP( 11794 ), c4090 ); CONSTANTEXP( ADR( c4090 ) ); c3872 = EMPTYLIST; c3872 = CONS( _TSCP( 11538 ), c3872 ); c3872 = CONS( _TSCP( 11026 ), c3872 ); c3872 = CONS( _TSCP( 11794 ), c3872 ); CONSTANTEXP( ADR( c3872 ) ); c3824 = EMPTYLIST; c3824 = CONS( _TSCP( 8722 ), c3824 ); CONSTANTEXP( ADR( c3824 ) ); c3743 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-REF" ) ); CONSTANTEXP( ADR( c3743 ) ); c3711 = EMPTYLIST; X1 = EMPTYLIST; t4555 = CSTRING_TSCP( t4556 ); X1 = CONS( t4555, X1 ); X1 = CONS( _TSCP( 8210 ), X1 ); c3711 = CONS( X1, c3711 ); X1 = EMPTYLIST; t4557 = CSTRING_TSCP( t4558 ); X1 = CONS( t4557, X1 ); X1 = CONS( _TSCP( 3346 ), X1 ); c3711 = CONS( X1, c3711 ); X1 = EMPTYLIST; t4559 = CSTRING_TSCP( t4560 ); X1 = CONS( t4559, X1 ); X1 = CONS( _TSCP( 3090 ), X1 ); c3711 = CONS( X1, c3711 ); X1 = EMPTYLIST; t4561 = CSTRING_TSCP( t4562 ); X1 = CONS( t4561, X1 ); X1 = CONS( _TSCP( 2578 ), X1 ); c3711 = CONS( X1, c3711 ); X1 = EMPTYLIST; t4563 = CSTRING_TSCP( t4564 ); X1 = CONS( t4563, X1 ); X1 = CONS( _TSCP( 2578 ), X1 ); c3711 = CONS( X1, c3711 ); X1 = EMPTYLIST; t4565 = CSTRING_TSCP( t4566 ); X1 = CONS( t4565, X1 ); X1 = CONS( _TSCP( 2322 ), X1 ); c3711 = CONS( X1, c3711 ); CONSTANTEXP( ADR( c3711 ) ); c3700 = CSTRING_TSCP( t4567 ); CONSTANTEXP( ADR( c3700 ) ); c3696 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR<=?" ) ); CONSTANTEXP( ADR( c3696 ) ); c3688 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR>?" ) ); CONSTANTEXP( ADR( c3688 ) ); c3676 = CSTRING_TSCP( t4568 ); CONSTANTEXP( ADR( c3676 ) ); c3675 = CSTRING_TSCP( t4569 ); CONSTANTEXP( ADR( c3675 ) ); c3674 = CSTRING_TSCP( t4570 ); CONSTANTEXP( ADR( c3674 ) ); c3654 = CSTRING_TSCP( t4571 ); CONSTANTEXP( ADR( c3654 ) ); c3596 = CSTRING_TSCP( t4572 ); CONSTANTEXP( ADR( c3596 ) ); c3595 = EMPTYLIST; X1 = EMPTYLIST; t4573 = CSTRING_TSCP( t4574 ); X1 = CONS( t4573, X1 ); t4575 = STRINGTOSYMBOL( CSTRING_TSCP( "UNQUOTE-SPLICING" ) ); X1 = CONS( t4575, X1 ); c3595 = CONS( X1, c3595 ); X1 = EMPTYLIST; t4576 = CSTRING_TSCP( t4577 ); X1 = CONS( t4576, X1 ); t4578 = STRINGTOSYMBOL( CSTRING_TSCP( "UNQUOTE" ) ); X1 = CONS( t4578, X1 ); c3595 = CONS( X1, c3595 ); X1 = EMPTYLIST; t4579 = CSTRING_TSCP( t4580 ); X1 = CONS( t4579, X1 ); t4581 = STRINGTOSYMBOL( CSTRING_TSCP( "QUASIQUOTE" ) ); X1 = CONS( t4581, X1 ); c3595 = CONS( X1, c3595 ); X1 = EMPTYLIST; t4582 = CSTRING_TSCP( t4583 ); X1 = CONS( t4582, X1 ); t4584 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); X1 = CONS( t4584, X1 ); c3595 = CONS( X1, c3595 ); CONSTANTEXP( ADR( c3595 ) ); c3561 = CSTRING_TSCP( t4585 ); CONSTANTEXP( ADR( c3561 ) ); c3456 = CSTRING_TSCP( t4586 ); CONSTANTEXP( ADR( c3456 ) ); c3424 = EMPTYLIST; t4587 = STRINGTOSYMBOL( CSTRING_TSCP( "-" ) ); c3424 = CONS( t4587, c3424 ); t4588 = STRINGTOSYMBOL( CSTRING_TSCP( "+" ) ); c3424 = CONS( t4588, c3424 ); CONSTANTEXP( ADR( c3424 ) ); c3423 = CSTRING_TSCP( t4589 ); CONSTANTEXP( ADR( c3423 ) ); c3422 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c3422 ) ); c3397 = CSTRING_TSCP( t4590 ); CONSTANTEXP( ADR( c3397 ) ); c3394 = CSTRING_TSCP( t4591 ); CONSTANTEXP( ADR( c3394 ) ); c3393 = CSTRING_TSCP( t4592 ); CONSTANTEXP( ADR( c3393 ) ); c3392 = CSTRING_TSCP( t4593 ); CONSTANTEXP( ADR( c3392 ) ); c3391 = CSTRING_TSCP( t4594 ); CONSTANTEXP( ADR( c3391 ) ); c3390 = CSTRING_TSCP( t4595 ); CONSTANTEXP( ADR( c3390 ) ); c3389 = CSTRING_TSCP( t4596 ); CONSTANTEXP( ADR( c3389 ) ); c3388 = STRINGTOSYMBOL( CSTRING_TSCP( "%TO-WRITE" ) ); CONSTANTEXP( ADR( c3388 ) ); c3387 = STRINGTOSYMBOL( CSTRING_TSCP( "%TO-DISPLAY" ) ); CONSTANTEXP( ADR( c3387 ) ); c3359 = CSTRING_TSCP( t4597 ); CONSTANTEXP( ADR( c3359 ) ); c3258 = CSTRING_TSCP( t4598 ); CONSTANTEXP( ADR( c3258 ) ); c3257 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c3257 ) ); c3219 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-CIRCLE" ) ); CONSTANTEXP( ADR( c3219 ) ); c3218 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LEVEL" ) ); CONSTANTEXP( ADR( c3218 ) ); c3217 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-PRETTY" ) ); CONSTANTEXP( ADR( c3217 ) ); c3213 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-WIDTH" ) ); CONSTANTEXP( ADR( c3213 ) ); c3212 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-LENGTH" ) ); CONSTANTEXP( ADR( c3212 ) ); c3211 = STRINGTOSYMBOL( CSTRING_TSCP( "WRITE-TOKEN" ) ); CONSTANTEXP( ADR( c3211 ) ); c3192 = CSTRING_TSCP( t4599 ); CONSTANTEXP( ADR( c3192 ) ); c3168 = STRINGTOSYMBOL( CSTRING_TSCP( "PORT" ) ); CONSTANTEXP( ADR( c3168 ) ); c3167 = CSTRING_TSCP( t4600 ); CONSTANTEXP( ADR( c3167 ) ); c3113 = STRINGTOSYMBOL( CSTRING_TSCP( "READ-CHAR" ) ); CONSTANTEXP( ADR( c3113 ) ); c3112 = STRINGTOSYMBOL( CSTRING_TSCP( "PEEK-CHAR" ) ); CONSTANTEXP( ADR( c3112 ) ); c3105 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( _TSCP( 60 ), X1 ); X1 = CONS( _TSCP( 17938 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 56 ), X1 ); X1 = CONS( _TSCP( 17682 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 52 ), X1 ); X1 = CONS( _TSCP( 17426 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 48 ), X1 ); X1 = CONS( _TSCP( 17170 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 44 ), X1 ); X1 = CONS( _TSCP( 16914 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 40 ), X1 ); X1 = CONS( _TSCP( 16658 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 60 ), X1 ); X1 = CONS( _TSCP( 26130 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 56 ), X1 ); X1 = CONS( _TSCP( 25874 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 52 ), X1 ); X1 = CONS( _TSCP( 25618 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 48 ), X1 ); X1 = CONS( _TSCP( 25362 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 44 ), X1 ); X1 = CONS( _TSCP( 25106 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 40 ), X1 ); X1 = CONS( _TSCP( 24850 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 36 ), X1 ); X1 = CONS( _TSCP( 14610 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 32 ), X1 ); X1 = CONS( _TSCP( 14354 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 28 ), X1 ); X1 = CONS( _TSCP( 14098 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 24 ), X1 ); X1 = CONS( _TSCP( 13842 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 20 ), X1 ); X1 = CONS( _TSCP( 13586 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 16 ), X1 ); X1 = CONS( _TSCP( 13330 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 12 ), X1 ); X1 = CONS( _TSCP( 13074 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 8 ), X1 ); X1 = CONS( _TSCP( 12818 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 4 ), X1 ); X1 = CONS( _TSCP( 12562 ), X1 ); c3105 = CONS( X1, c3105 ); X1 = EMPTYLIST; X1 = CONS( _TSCP( 0 ), X1 ); X1 = CONS( _TSCP( 12306 ), X1 ); c3105 = CONS( X1, c3105 ); CONSTANTEXP( ADR( c3105 ) ); c3104 = CSTRING_TSCP( t4601 ); CONSTANTEXP( ADR( c3104 ) ); c3103 = STRINGTOSYMBOL( CSTRING_TSCP( "FIXED->FLOAT" ) ); CONSTANTEXP( ADR( c3103 ) ); c2981 = CSTRING_TSCP( t4602 ); CONSTANTEXP( ADR( c2981 ) ); c2976 = CSTRING_TSCP( t4603 ); CONSTANTEXP( ADR( c2976 ) ); c2975 = STRINGTOSYMBOL( CSTRING_TSCP( "FLOAT->FIXED" ) ); CONSTANTEXP( ADR( c2975 ) ); c2946 = DOUBLE_TSCP( 0. ); CONSTANTEXP( ADR( c2946 ) ); c2936 = CSTRING_TSCP( t4604 ); CONSTANTEXP( ADR( c2936 ) ); c2933 = CSTRING_TSCP( t4605 ); CONSTANTEXP( ADR( c2933 ) ); c2929 = CSTRING_TSCP( t4606 ); CONSTANTEXP( ADR( c2929 ) ); c2833 = CSTRING_TSCP( t4607 ); CONSTANTEXP( ADR( c2833 ) ); c2832 = EMPTYLIST; c2832 = CONS( _TSCP( 30738 ), c2832 ); c2832 = CONS( _TSCP( 22546 ), c2832 ); CONSTANTEXP( ADR( c2832 ) ); c2831 = EMPTYLIST; c2831 = CONS( _TSCP( 25618 ), c2831 ); c2831 = CONS( _TSCP( 17426 ), c2831 ); CONSTANTEXP( ADR( c2831 ) ); c2830 = EMPTYLIST; c2830 = CONS( _TSCP( 28434 ), c2830 ); c2830 = CONS( _TSCP( 20242 ), c2830 ); CONSTANTEXP( ADR( c2830 ) ); c2829 = EMPTYLIST; c2829 = CONS( _TSCP( 25106 ), c2829 ); c2829 = CONS( _TSCP( 16914 ), c2829 ); CONSTANTEXP( ADR( c2829 ) ); c2766 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-REF" ) ); CONSTANTEXP( ADR( c2766 ) ); c2724 = EMPTYLIST; c2724 = CONS( _TSCP( 11538 ), c2724 ); c2724 = CONS( _TSCP( 11026 ), c2724 ); c2724 = CONS( _TSCP( 11794 ), c2724 ); c2724 = CONS( _TSCP( 24082 ), c2724 ); c2724 = CONS( _TSCP( 24338 ), c2724 ); c2724 = CONS( _TSCP( 32274 ), c2724 ); c2724 = CONS( _TSCP( 16146 ), c2724 ); c2724 = CONS( _TSCP( 15890 ), c2724 ); c2724 = CONS( _TSCP( 15634 ), c2724 ); c2724 = CONS( _TSCP( 15378 ), c2724 ); c2724 = CONS( _TSCP( 14866 ), c2724 ); c2724 = CONS( _TSCP( 12050 ), c2724 ); c2724 = CONS( _TSCP( 10770 ), c2724 ); c2724 = CONS( _TSCP( 9746 ), c2724 ); c2724 = CONS( _TSCP( 9490 ), c2724 ); c2724 = CONS( _TSCP( 9234 ), c2724 ); c2724 = CONS( _TSCP( 8466 ), c2724 ); c2724 = CONS( _TSCP( 14610 ), c2724 ); c2724 = CONS( _TSCP( 14354 ), c2724 ); c2724 = CONS( _TSCP( 14098 ), c2724 ); c2724 = CONS( _TSCP( 13842 ), c2724 ); c2724 = CONS( _TSCP( 13586 ), c2724 ); c2724 = CONS( _TSCP( 13330 ), c2724 ); c2724 = CONS( _TSCP( 13074 ), c2724 ); c2724 = CONS( _TSCP( 12818 ), c2724 ); c2724 = CONS( _TSCP( 12562 ), c2724 ); c2724 = CONS( _TSCP( 12306 ), c2724 ); CONSTANTEXP( ADR( c2724 ) ); c2610 = CSTRING_TSCP( t4608 ); CONSTANTEXP( ADR( c2610 ) ); c2606 = CSTRING_TSCP( t4609 ); CONSTANTEXP( ADR( c2606 ) ); c2603 = CSTRING_TSCP( t4610 ); CONSTANTEXP( ADR( c2603 ) ); c2602 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-SET!" ) ); CONSTANTEXP( ADR( c2602 ) ); c2456 = CSTRING_TSCP( t4611 ); CONSTANTEXP( ADR( c2456 ) ); c2455 = STRINGTOSYMBOL( CSTRING_TSCP( "INTEGER->CHAR" ) ); CONSTANTEXP( ADR( c2455 ) ); c2429 = CSTRING_TSCP( t4612 ); CONSTANTEXP( ADR( c2429 ) ); c2428 = STRINGTOSYMBOL( CSTRING_TSCP( "SPACE" ) ); CONSTANTEXP( ADR( c2428 ) ); c2424 = STRINGTOSYMBOL( CSTRING_TSCP( "RETURN" ) ); CONSTANTEXP( ADR( c2424 ) ); c2420 = STRINGTOSYMBOL( CSTRING_TSCP( "FORMFEED" ) ); CONSTANTEXP( ADR( c2420 ) ); c2416 = STRINGTOSYMBOL( CSTRING_TSCP( "LINEFEED" ) ); CONSTANTEXP( ADR( c2416 ) ); c2412 = STRINGTOSYMBOL( CSTRING_TSCP( "NEWLINE" ) ); CONSTANTEXP( ADR( c2412 ) ); c2408 = STRINGTOSYMBOL( CSTRING_TSCP( "TAB" ) ); CONSTANTEXP( ADR( c2408 ) ); c2354 = EMPTYLIST; c2354 = CONS( _TSCP( 15122 ), c2354 ); c2354 = CONS( _TSCP( 8722 ), c2354 ); c2354 = CONS( _TSCP( 10514 ), c2354 ); c2354 = CONS( _TSCP( 10258 ), c2354 ); CONSTANTEXP( ADR( c2354 ) ); c2323 = CSTRING_TSCP( t4613 ); CONSTANTEXP( ADR( c2323 ) ); c2256 = EMPTYLIST; c2256 = CONS( _TSCP( 11794 ), c2256 ); c2256 = CONS( _TSCP( 8978 ), c2256 ); CONSTANTEXP( ADR( c2256 ) ); c2228 = EMPTYLIST; c2228 = CONS( _TSCP( 24082 ), c2228 ); c2228 = CONS( _TSCP( 24338 ), c2228 ); c2228 = CONS( _TSCP( 32274 ), c2228 ); c2228 = CONS( _TSCP( 16146 ), c2228 ); c2228 = CONS( _TSCP( 15890 ), c2228 ); c2228 = CONS( _TSCP( 15634 ), c2228 ); c2228 = CONS( _TSCP( 15378 ), c2228 ); c2228 = CONS( _TSCP( 14866 ), c2228 ); c2228 = CONS( _TSCP( 12050 ), c2228 ); c2228 = CONS( _TSCP( 10770 ), c2228 ); c2228 = CONS( _TSCP( 9746 ), c2228 ); c2228 = CONS( _TSCP( 9490 ), c2228 ); c2228 = CONS( _TSCP( 9234 ), c2228 ); c2228 = CONS( _TSCP( 8466 ), c2228 ); CONSTANTEXP( ADR( c2228 ) ); c2175 = CSTRING_TSCP( t4614 ); CONSTANTEXP( ADR( c2175 ) ); c2174 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR=?" ) ); CONSTANTEXP( ADR( c2174 ) ); c2156 = CSTRING_TSCP( t4615 ); CONSTANTEXP( ADR( c2156 ) ); c2155 = STRINGTOSYMBOL( CSTRING_TSCP( "READ" ) ); CONSTANTEXP( ADR( c2155 ) ); c2147 = STRINGTOSYMBOL( CSTRING_TSCP( "%RECORD" ) ); CONSTANTEXP( ADR( c2147 ) ); c2145 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR" ) ); CONSTANTEXP( ADR( c2145 ) ); c2143 = STRINGTOSYMBOL( CSTRING_TSCP( "PERIOD" ) ); CONSTANTEXP( ADR( c2143 ) ); c2141 = STRINGTOSYMBOL( CSTRING_TSCP( "UNQUOTE" ) ); CONSTANTEXP( ADR( c2141 ) ); c2139 = STRINGTOSYMBOL( CSTRING_TSCP( "UNQUOTE-SPLICING" ) ); CONSTANTEXP( ADR( c2139 ) ); c2137 = STRINGTOSYMBOL( CSTRING_TSCP( "QUASIQUOTE" ) ); CONSTANTEXP( ADR( c2137 ) ); c2135 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2135 ) ); c2133 = STRINGTOSYMBOL( CSTRING_TSCP( "RIGHT-PAREN" ) ); CONSTANTEXP( ADR( c2133 ) ); c2131 = STRINGTOSYMBOL( CSTRING_TSCP( "LEFT-PAREN" ) ); CONSTANTEXP( ADR( c2131 ) ); } DEFTSCP( scrt7_token_2dleft_2dparen_v ); DEFCSTRING( t4616, "SCRT7_TOKEN-LEFT-PAREN" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); DEFTSCP( scrt7_token_2dright_2dparen_v ); DEFCSTRING( t4617, "SCRT7_TOKEN-RIGHT-PAREN" ); DEFTSCP( scrt7_token_2dquote_v ); DEFCSTRING( t4618, "SCRT7_TOKEN-QUOTE" ); DEFTSCP( scrt7_token_2dquasiquote_v ); DEFCSTRING( t4619, "SCRT7_TOKEN-QUASIQUOTE" ); DEFTSCP( scrt7_2dsplicing_542533dd_v ); DEFCSTRING( t4620, "SCRT7_TOKEN-UNQUOTE-SPLICING" ); DEFTSCP( scrt7_token_2dunquote_v ); DEFCSTRING( t4621, "SCRT7_TOKEN-UNQUOTE" ); DEFTSCP( scrt7_token_2dperiod_v ); DEFCSTRING( t4622, "SCRT7_TOKEN-PERIOD" ); DEFTSCP( scrt7_token_2dvector_v ); DEFCSTRING( t4623, "SCRT7_TOKEN-VECTOR" ); DEFTSCP( scrt7_token_2drecord_v ); DEFCSTRING( t4624, "SCRT7_TOKEN-RECORD" ); DEFTSCP( scrt7_peek_2dchar_2dport_v ); DEFCSTRING( t4625, "SCRT7_PEEK-CHAR-PORT" ); DEFTSCP( scrt7_read_2dchar_2dport_v ); DEFCSTRING( t4626, "SCRT7_READ-CHAR-PORT" ); DEFTSCP( scrt7_ort_2dproc_ae18f815_v ); DEFCSTRING( t4627, "SCRT7_READ-DATUM-PORT-PROC" ); DEFTSCP( scrt7_next_2dchar_v ); DEFCSTRING( t4628, "SCRT7_NEXT-CHAR" ); EXTERNTSCPP( scrt6_eof_2dobject_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_eof_2dobject_3f_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP scrt7_next_2dchar( ) { TSCP X2, X1; PUSHSTACKTRACE( t4628 ); X2 = scrt7_read_2dchar_2dport_v; X2 = UNKNOWNCALL( X2, 0 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( scrt6_eof_2dobject_3f( X1 ) ) ) goto L4631; POPSTACKTRACE( scdebug_error( c2155, c2156, EMPTYLIST ) ); L4631: POPSTACKTRACE( X1 ); } DEFTSCP( scrt7_token_v ); DEFCSTRING( t4633, "SCRT7_TOKEN" ); EXTERNTSCPP( scrt7_comment_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt7_comment_3f_v ); EXTERNTSCPP( scrt3_char_2dalphabetic_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt3_char_2dalphabetic_3f_v ); EXTERNTSCPP( scrt7_identifier, XAL1( TSCP ) ); EXTERNTSCP( scrt7_identifier_v ); EXTERNTSCPP( scrt3_char_2dupcase, XAL1( TSCP ) ); EXTERNTSCP( scrt3_char_2dupcase_v ); EXTERNTSCPP( scrt7_read_2dstring, XAL0( ) ); EXTERNTSCP( scrt7_read_2dstring_v ); EXTERNTSCPP( scrt3_char_2dnumeric_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt3_char_2dnumeric_3f_v ); EXTERNTSCPP( scrt7_number, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt7_number_v ); EXTERNTSCPP( scrt7_character, XAL0( ) ); EXTERNTSCP( scrt7_character_v ); EXTERNTSCP( scrt4_fix_2dchar_c117a402_v ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); TSCP scrt7_token( ) { TSCP X22, X21, X20, X19, X18, X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4633 ); L4634: X1 = scrt7_next_2dchar( ); X1 = CONS( X1, EMPTYLIST ); X2 = BOOLEAN( OR( EQ( PAIR_CAR( X1 ), C_CHAR( 040 ) ), AND( GTE( PAIR_CAR( X1 ), C_CHAR( 011 ) ), LTE( PAIR_CAR( X1 ), C_CHAR( 015 ) ) ) ) ); if ( TRUE( X2 ) ) GOBACK( L4634 ); if ( TRUE( scrt7_comment_3f( PAIR_CAR( X1 ) ) ) ) GOBACK( L4634 ); if ( FALSE( scrt3_char_2dalphabetic_3f( PAIR_CAR( X1 ) ) ) ) goto L4643; X3 = scrt3_char_2dupcase( PAIR_CAR( X1 ) ); POPSTACKTRACE( scrt7_identifier( X3 ) ); L4643: X3 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X3 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 8722 ) ), CHARACTERTAG ) ) ) goto L4646; X4 = CONS( _TSCP( 8722 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X3, X4 ) ); L4646: if ( NEQ( _S2CINT( X3 ), _S2CINT( _TSCP( 8722 ) ) ) ) goto L4648; POPSTACKTRACE( scrt7_read_2dstring( ) ); L4648: X4 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X4 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 10258 ) ), CHARACTERTAG ) ) ) goto L4651; X5 = CONS( _TSCP( 10258 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X4, X5 ) ); L4651: if ( EQ( _S2CINT( X4 ), _S2CINT( _TSCP( 10258 ) ) ) ) goto L4653; X5 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X5 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 10514 ) ), CHARACTERTAG ) ) ) goto L4656; X6 = CONS( _TSCP( 10514 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X5, X6 ) ); L4656: if ( EQ( _S2CINT( X5 ), _S2CINT( _TSCP( 10514 ) ) ) ) goto L4658; X6 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 10002 ) ), CHARACTERTAG ) ) ) goto L4661; X7 = CONS( _TSCP( 10002 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X6, X7 ) ); L4661: if ( EQ( _S2CINT( X6 ), _S2CINT( _TSCP( 10002 ) ) ) ) goto L4663; X7 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X7 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 24594 ) ), CHARACTERTAG ) ) ) goto L4666; X8 = CONS( _TSCP( 24594 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X7, X8 ) ); L4666: if ( EQ( _S2CINT( X7 ), _S2CINT( _TSCP( 24594 ) ) ) ) goto L4668; X8 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X8 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 11282 ) ), CHARACTERTAG ) ) ) goto L4671; X9 = CONS( _TSCP( 11282 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X8, X9 ) ); L4671: if ( NEQ( _S2CINT( X8 ), _S2CINT( _TSCP( 11282 ) ) ) ) goto L4673; X10 = scrt7_peek_2dchar_2dport_v; X10 = UNKNOWNCALL( X10, 0 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( PROCEDURE_CLOSURE( X10 ) ); if ( AND( EQ( TSCPIMMEDIATETAG( X9 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 16402 ) ), CHARACTERTAG ) ) ) goto L4676; X10 = CONS( _TSCP( 16402 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X9, X10 ) ); L4676: if ( NEQ( _S2CINT( X9 ), _S2CINT( _TSCP( 16402 ) ) ) ) goto L4678; scrt7_next_2dchar( ); POPSTACKTRACE( scrt7_2dsplicing_542533dd_v ); L4678: POPSTACKTRACE( scrt7_token_2dunquote_v ); L4673: X9 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X9 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 11794 ) ), CHARACTERTAG ) ) ) goto L4682; X10 = CONS( _TSCP( 11794 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X9, X10 ) ); L4682: if ( NEQ( _S2CINT( X9 ), _S2CINT( _TSCP( 11794 ) ) ) ) goto L4684; X11 = scrt7_peek_2dchar_2dport_v; X11 = UNKNOWNCALL( X11, 0 ); X10 = VIA( PROCEDURE_CODE( X11 ) )( PROCEDURE_CLOSURE( X11 ) ); if ( FALSE( scrt3_char_2dnumeric_3f( X10 ) ) ) goto L4686; POPSTACKTRACE( scrt7_number( PAIR_CAR( X1 ), _TSCP( 40 ), _TSCP( 4 ) ) ); L4686: X11 = scrt7_peek_2dchar_2dport_v; X11 = UNKNOWNCALL( X11, 0 ); X10 = VIA( PROCEDURE_CODE( X11 ) )( PROCEDURE_CLOSURE( X11 ) ); if ( OR( EQ( X10, C_CHAR( 040 ) ), AND( GTE( X10, C_CHAR( 011 ) ), LTE( X10, C_CHAR( 015 ) ) ) ) ) goto L4688; POPSTACKTRACE( scrt7_identifier( PAIR_CAR( X1 ) ) ); L4688: POPSTACKTRACE( scrt7_token_2dperiod_v ); L4684: X10 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X10 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 8978 ) ), CHARACTERTAG ) ) ) goto L4691; X11 = CONS( _TSCP( 8978 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X10, X11 ) ); L4691: if ( NEQ( _S2CINT( X10 ), _S2CINT( _TSCP( 8978 ) ) ) ) goto L4693; X12 = scrt7_next_2dchar( ); X11 = scrt3_char_2dupcase( X12 ); SETGEN( PAIR_CAR( X1 ), X11 ); X11 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X11 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 10258 ) ), CHARACTERTAG ) ) ) goto L4697; X12 = CONS( _TSCP( 10258 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X11, X12 ) ); L4697: if ( EQ( _S2CINT( X11 ), _S2CINT( _TSCP( 10258 ) ) ) ) goto L4699; X12 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X12 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 23570 ) ), CHARACTERTAG ) ) ) goto L4702; X13 = CONS( _TSCP( 23570 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X12, X13 ) ); L4702: if ( NEQ( _S2CINT( X12 ), _S2CINT( _TSCP( 23570 ) ) ) ) goto L4704; POPSTACKTRACE( scrt7_character( ) ); L4704: X13 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X13 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 21522 ) ), CHARACTERTAG ) ) ) goto L4707; X14 = CONS( _TSCP( 21522 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X13, X14 ) ); L4707: if ( EQ( _S2CINT( X13 ), _S2CINT( _TSCP( 21522 ) ) ) ) goto L4709; X14 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X14 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 17938 ) ), CHARACTERTAG ) ) ) goto L4712; X15 = CONS( _TSCP( 17938 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X14, X15 ) ); L4712: if ( EQ( _S2CINT( X14 ), _S2CINT( _TSCP( 17938 ) ) ) ) goto L4714; X15 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X15 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 16914 ) ), CHARACTERTAG ) ) ) goto L4717; X16 = CONS( _TSCP( 16914 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X15, X16 ) ); L4717: if ( NEQ( _S2CINT( X15 ), _S2CINT( _TSCP( 16914 ) ) ) ) goto L4719; X16 = scrt7_next_2dchar( ); POPSTACKTRACE( scrt7_number( X16, _TSCP( 8 ), _TSCP( 4 ) ) ); L4719: X16 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X16 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 20242 ) ), CHARACTERTAG ) ) ) goto L4722; X17 = CONS( _TSCP( 20242 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X16, X17 ) ); L4722: if ( NEQ( _S2CINT( X16 ), _S2CINT( _TSCP( 20242 ) ) ) ) goto L4724; X17 = scrt7_next_2dchar( ); POPSTACKTRACE( scrt7_number( X17, _TSCP( 32 ), _TSCP( 4 ) ) ); L4724: X17 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X17 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 17426 ) ), CHARACTERTAG ) ) ) goto L4727; X18 = CONS( _TSCP( 17426 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X17, X18 ) ); L4727: if ( NEQ( _S2CINT( X17 ), _S2CINT( _TSCP( 17426 ) ) ) ) goto L4729; X18 = scrt7_next_2dchar( ); POPSTACKTRACE( scrt7_number( X18, _TSCP( 40 ), _TSCP( 4 ) ) ); L4729: X18 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X18 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 22546 ) ), CHARACTERTAG ) ) ) goto L4732; X19 = CONS( _TSCP( 22546 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X18, X19 ) ); L4732: if ( NEQ( _S2CINT( X18 ), _S2CINT( _TSCP( 22546 ) ) ) ) goto L4734; X19 = scrt7_next_2dchar( ); POPSTACKTRACE( scrt7_number( X19, _TSCP( 64 ), _TSCP( 4 ) ) ); L4734: X19 = scrt4_fix_2dchar_c117a402_v; if ( FALSE( X19 ) ) goto L4745; X20 = PAIR_CAR( X1 ); X21 = scrt4_fix_2dchar_c117a402_v; if ( AND( EQ( TSCPIMMEDIATETAG( X20 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( X21 ), CHARACTERTAG ) ) ) goto L4741; X22 = CONS( X21, EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X20, X22 ) ); L4741: if ( NEQ( _S2CINT( X20 ), _S2CINT( X21 ) ) ) goto L4745; POPSTACKTRACE( scrt7_token_2drecord_v ); L4714: POPSTACKTRACE( FALSEVALUE ); L4709: POPSTACKTRACE( TRUEVALUE ); L4699: POPSTACKTRACE( scrt7_token_2dvector_v ); L4693: if ( FALSE( scrt1_memq( PAIR_CAR( X1 ), c2228 ) ) ) goto L4746; POPSTACKTRACE( scrt7_identifier( PAIR_CAR( X1 ) ) ); L4746: X11 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X11 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 23570 ) ), CHARACTERTAG ) ) ) goto L4749; X12 = CONS( _TSCP( 23570 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X11, X12 ) ); L4749: if ( NEQ( _S2CINT( X11 ), _S2CINT( _TSCP( 23570 ) ) ) ) goto L4751; X12 = scrt7_next_2dchar( ); POPSTACKTRACE( scrt7_identifier( X12 ) ); L4751: X12 = BOOLEAN( EQ( _S2CUINT( PAIR_CAR( X1 ) ), _S2CUINT( _TSCP( 11026 ) ) ) ); if ( TRUE( X12 ) ) goto L4757; if ( EQ( _S2CUINT( PAIR_CAR( X1 ) ), _S2CUINT( _TSCP( 11538 ) ) ) ) goto L4757; POPSTACKTRACE( scrt7_number( PAIR_CAR( X1 ), _TSCP( 0 ), _TSCP( 0 ) ) ); L4668: POPSTACKTRACE( scrt7_token_2dquasiquote_v ); L4663: POPSTACKTRACE( scrt7_token_2dquote_v ); L4658: POPSTACKTRACE( scrt7_token_2dright_2dparen_v ); L4653: POPSTACKTRACE( scrt7_token_2dleft_2dparen_v ); L4745: POPSTACKTRACE( scdebug_error( c2155, c2323, CONS( PAIR_CAR( X1 ), EMPTYLIST ) ) ); L4757: X3 = scrt7_peek_2dchar_2dport_v; X3 = UNKNOWNCALL( X3, 0 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( PROCEDURE_CLOSURE( X3 ) ); X3 = scrt3_char_2dnumeric_3f( X2 ); if ( TRUE( X3 ) ) goto L4765; if ( TRUE( scrt1_memq( X2, c2256 ) ) ) goto L4765; POPSTACKTRACE( scrt7_identifier( PAIR_CAR( X1 ) ) ); L4765: POPSTACKTRACE( scrt7_number( PAIR_CAR( X1 ), _TSCP( 0 ), _TSCP( 0 ) ) ); } DEFTSCP( scrt7_delimiter_3f_v ); DEFCSTRING( t4768, "SCRT7_DELIMITER?" ); TSCP scrt7_delimiter_3f( c2343 ) TSCP c2343; { TSCP X1; PUSHSTACKTRACE( t4768 ); X1 = scrt6_eof_2dobject_3f( c2343 ); if ( TRUE( X1 ) ) goto L4771; if ( OR( EQ( c2343, C_CHAR( 040 ) ), AND( GTE( c2343, C_CHAR( 011 ) ), LTE( c2343, C_CHAR( 015 ) ) ) ) ) goto L4773; POPSTACKTRACE( scrt1_memq( c2343, c2354 ) ); L4773: POPSTACKTRACE( TRUEVALUE ); L4771: POPSTACKTRACE( X1 ); } DEFTSCP( scrt7_comment_3f_v ); DEFCSTRING( t4775, "SCRT7_COMMENT?" ); TSCP scrt7_comment_3f( c2356 ) TSCP c2356; { TSCP X2, X1; PUSHSTACKTRACE( t4775 ); if ( AND( EQ( TSCPIMMEDIATETAG( c2356 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 15122 ) ), CHARACTERTAG ) ) ) goto L4778; X1 = CONS( _TSCP( 15122 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( c2356, X1 ) ); L4778: if ( NEQ( _S2CINT( c2356 ), _S2CINT( _TSCP( 15122 ) ) ) ) goto L4780; L4782: X1 = scrt7_next_2dchar( ); if ( AND( EQ( TSCPIMMEDIATETAG( X1 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 2578 ) ), CHARACTERTAG ) ) ) goto L4785; X2 = CONS( _TSCP( 2578 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X1, X2 ) ); L4785: if ( NEQ( _S2CINT( X1 ), _S2CINT( _TSCP( 2578 ) ) ) ) GOBACK( L4782 ); POPSTACKTRACE( TRUEVALUE ); L4780: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( scrt7_read_2dstring_v ); DEFCSTRING( t4789, "SCRT7_READ-STRING" ); EXTERNTSCPP( scrt3_list_2d_3estring, XAL1( TSCP ) ); EXTERNTSCP( scrt3_list_2d_3estring_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); TSCP scrt7_read_2dstring( ) { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4789 ); X1 = EMPTYLIST; X2 = scrt7_next_2dchar( ); L4792: X2 = CONS( X2, EMPTYLIST ); X3 = PAIR_CAR( X2 ); if ( AND( EQ( TSCPIMMEDIATETAG( X3 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 8722 ) ), CHARACTERTAG ) ) ) goto L4794; X4 = CONS( _TSCP( 8722 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X3, X4 ) ); L4794: if ( NEQ( _S2CINT( X3 ), _S2CINT( _TSCP( 8722 ) ) ) ) goto L4796; X4 = scrt1_reverse( X1 ); POPSTACKTRACE( scrt3_list_2d_3estring( X4 ) ); L4796: X4 = PAIR_CAR( X2 ); if ( AND( EQ( TSCPIMMEDIATETAG( _TSCP( 23570 ) ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( X4 ), CHARACTERTAG ) ) ) goto L4800; X5 = CONS( X4, EMPTYLIST ); scdebug_error( c2174, c2175, CONS( _TSCP( 23570 ), X5 ) ); L4800: if ( NEQ( _S2CINT( _TSCP( 23570 ) ), _S2CINT( X4 ) ) ) goto L4802; X5 = scrt7_next_2dchar( ); SETGEN( PAIR_CAR( X2 ), X5 ); L4802: X4 = sc_cons( PAIR_CAR( X2 ), X1 ); X2 = scrt7_next_2dchar( ); X1 = X4; GOBACK( L4792 ); } DEFTSCP( scrt7_character_v ); DEFCSTRING( t4804, "SCRT7_CHARACTER" ); EXTERNTSCPP( scrt2__3c_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_2dtwo_v ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); TSCP scrt7_character( ) { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4804 ); X1 = scrt7_next_2dchar( ); if ( FALSE( scrt3_char_2dalphabetic_3f( X1 ) ) ) goto L4807; X3 = scrt7_peek_2dchar_2dport_v; X3 = UNKNOWNCALL( X3, 0 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( PROCEDURE_CLOSURE( X3 ) ); if ( TRUE( scrt7_delimiter_3f( X2 ) ) ) goto L4809; X3 = scrt3_char_2dupcase( X1 ); X2 = scrt7_identifier( X3 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2408 ) ) ) goto L4812; X3 = BOOLEAN( NEQ( TSCPTAG( _TSCP( 36 ) ), FIXNUMTAG ) ); if ( TRUE( X3 ) ) goto L4819; if ( BITAND( BITOR( _S2CINT( _TSCP( 36 ) ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4820; X4 = BOOLEAN( LT( _S2CINT( _TSCP( 36 ) ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4821; L4820: X4 = scrt2__3c_2dtwo( _TSCP( 36 ), _TSCP( 0 ) ); L4821: if ( TRUE( X4 ) ) goto L4819; if ( BITAND( BITOR( _S2CINT( _TSCP( 36 ) ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4828; if ( GT( _S2CINT( _TSCP( 36 ) ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4819; goto L4835; L4828: if ( FALSE( scrt2__3e_2dtwo( _TSCP( 36 ), _TSCP( 1020 ) ) ) ) goto L4835; L4819: scdebug_error( c2455, c2456, CONS( _TSCP( 36 ), EMPTYLIST ) ); L4835: POPSTACKTRACE( FIX_CHAR( _TSCP( 36 ) ) ); L4812: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2412 ) ) ) goto L4836; X3 = BOOLEAN( NEQ( TSCPTAG( _TSCP( 40 ) ), FIXNUMTAG ) ); if ( TRUE( X3 ) ) goto L4843; if ( BITAND( BITOR( _S2CINT( _TSCP( 40 ) ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4844; X4 = BOOLEAN( LT( _S2CINT( _TSCP( 40 ) ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4845; L4844: X4 = scrt2__3c_2dtwo( _TSCP( 40 ), _TSCP( 0 ) ); L4845: if ( TRUE( X4 ) ) goto L4843; if ( BITAND( BITOR( _S2CINT( _TSCP( 40 ) ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4852; if ( GT( _S2CINT( _TSCP( 40 ) ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4843; goto L4859; L4852: if ( FALSE( scrt2__3e_2dtwo( _TSCP( 40 ), _TSCP( 1020 ) ) ) ) goto L4859; L4843: scdebug_error( c2455, c2456, CONS( _TSCP( 40 ), EMPTYLIST ) ); L4859: POPSTACKTRACE( FIX_CHAR( _TSCP( 40 ) ) ); L4836: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2416 ) ) ) goto L4860; X3 = BOOLEAN( NEQ( TSCPTAG( _TSCP( 40 ) ), FIXNUMTAG ) ); if ( TRUE( X3 ) ) goto L4867; if ( BITAND( BITOR( _S2CINT( _TSCP( 40 ) ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4868; X4 = BOOLEAN( LT( _S2CINT( _TSCP( 40 ) ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4869; L4868: X4 = scrt2__3c_2dtwo( _TSCP( 40 ), _TSCP( 0 ) ); L4869: if ( TRUE( X4 ) ) goto L4867; if ( BITAND( BITOR( _S2CINT( _TSCP( 40 ) ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4876; if ( GT( _S2CINT( _TSCP( 40 ) ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4867; goto L4883; L4876: if ( FALSE( scrt2__3e_2dtwo( _TSCP( 40 ), _TSCP( 1020 ) ) ) ) goto L4883; L4867: scdebug_error( c2455, c2456, CONS( _TSCP( 40 ), EMPTYLIST ) ); L4883: POPSTACKTRACE( FIX_CHAR( _TSCP( 40 ) ) ); L4860: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2420 ) ) ) goto L4884; X3 = BOOLEAN( NEQ( TSCPTAG( _TSCP( 48 ) ), FIXNUMTAG ) ); if ( TRUE( X3 ) ) goto L4891; if ( BITAND( BITOR( _S2CINT( _TSCP( 48 ) ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4892; X4 = BOOLEAN( LT( _S2CINT( _TSCP( 48 ) ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4893; L4892: X4 = scrt2__3c_2dtwo( _TSCP( 48 ), _TSCP( 0 ) ); L4893: if ( TRUE( X4 ) ) goto L4891; if ( BITAND( BITOR( _S2CINT( _TSCP( 48 ) ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4900; if ( GT( _S2CINT( _TSCP( 48 ) ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4891; goto L4907; L4900: if ( FALSE( scrt2__3e_2dtwo( _TSCP( 48 ), _TSCP( 1020 ) ) ) ) goto L4907; L4891: scdebug_error( c2455, c2456, CONS( _TSCP( 48 ), EMPTYLIST ) ); L4907: POPSTACKTRACE( FIX_CHAR( _TSCP( 48 ) ) ); L4884: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2424 ) ) ) goto L4908; X3 = BOOLEAN( NEQ( TSCPTAG( _TSCP( 52 ) ), FIXNUMTAG ) ); if ( TRUE( X3 ) ) goto L4915; if ( BITAND( BITOR( _S2CINT( _TSCP( 52 ) ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4916; X4 = BOOLEAN( LT( _S2CINT( _TSCP( 52 ) ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4917; L4916: X4 = scrt2__3c_2dtwo( _TSCP( 52 ), _TSCP( 0 ) ); L4917: if ( TRUE( X4 ) ) goto L4915; if ( BITAND( BITOR( _S2CINT( _TSCP( 52 ) ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4924; if ( GT( _S2CINT( _TSCP( 52 ) ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4915; goto L4931; L4924: if ( FALSE( scrt2__3e_2dtwo( _TSCP( 52 ), _TSCP( 1020 ) ) ) ) goto L4931; L4915: scdebug_error( c2455, c2456, CONS( _TSCP( 52 ), EMPTYLIST ) ); L4931: POPSTACKTRACE( FIX_CHAR( _TSCP( 52 ) ) ); L4908: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2428 ) ) ) goto L4932; X3 = BOOLEAN( NEQ( TSCPTAG( _TSCP( 128 ) ), FIXNUMTAG ) ); if ( TRUE( X3 ) ) goto L4939; if ( BITAND( BITOR( _S2CINT( _TSCP( 128 ) ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4940; X4 = BOOLEAN( LT( _S2CINT( _TSCP( 128 ) ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4941; L4940: X4 = scrt2__3c_2dtwo( _TSCP( 128 ), _TSCP( 0 ) ); L4941: if ( TRUE( X4 ) ) goto L4939; if ( BITAND( BITOR( _S2CINT( _TSCP( 128 ) ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4948; if ( GT( _S2CINT( _TSCP( 128 ) ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4939; goto L4955; L4948: if ( FALSE( scrt2__3e_2dtwo( _TSCP( 128 ), _TSCP( 1020 ) ) ) ) goto L4955; L4939: scdebug_error( c2455, c2456, CONS( _TSCP( 128 ), EMPTYLIST ) ); L4955: POPSTACKTRACE( FIX_CHAR( _TSCP( 128 ) ) ); L4932: POPSTACKTRACE( scdebug_error( c2155, c2429, CONS( X2, EMPTYLIST ) ) ); L4809: POPSTACKTRACE( X1 ); L4807: POPSTACKTRACE( X1 ); } DEFTSCP( scrt7_idtable_v ); DEFCSTRING( t4956, "SCRT7_IDTABLE" ); EXTERNTSCPP( sc_make_2dvector, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dvector_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); DEFTSCP( scrt7_identifier_v ); DEFCSTRING( t5054, "SCRT7_IDENTIFIER" ); EXTERNTSCPP( sc_string_2d_3esymbol, XAL1( TSCP ) ); EXTERNTSCP( sc_string_2d_3esymbol_v ); TSCP scrt7_identifier( f2740 ) TSCP f2740; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5054 ); X2 = sc_cons( f2740, EMPTYLIST ); X1 = X2; X2 = X1; L5059: X4 = scrt7_peek_2dchar_2dport_v; X4 = UNKNOWNCALL( X4, 0 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( PROCEDURE_CLOSURE( X4 ) ); if ( NEQ( TSCPIMMEDIATETAG( X3 ), CHARACTERTAG ) ) goto L5061; X5 = C_FIXED( CHAR_C( X3 ) ); X6 = scrt7_idtable_v; if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), VECTORTAG ) ) ) goto L5064; scdebug_error( c2766, c2603, CONS( X6, EMPTYLIST ) ); L5064: if ( EQ( TSCPTAG( X5 ), FIXNUMTAG ) ) goto L5066; scdebug_error( c2766, c2606, CONS( X5, EMPTYLIST ) ); L5066: if ( LT( _S2CUINT( FIXED_C( X5 ) ), _S2CUINT( VECTOR_LENGTH( X6 ) ) ) ) goto L5068; scdebug_error( c2766, c2610, CONS( X5, EMPTYLIST ) ); L5068: X4 = VECTOR_ELEMENT( X6, X5 ); goto L5062; L5061: X4 = FALSEVALUE; L5062: if ( NEQ( TSCPIMMEDIATETAG( X4 ), CHARACTERTAG ) ) goto L5071; X5 = scrt7_read_2dchar_2dport_v; X5 = UNKNOWNCALL( X5, 0 ); VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); X2 = sc_cons( X4, X2 ); GOBACK( L5059 ); L5071: if ( FALSE( X4 ) ) goto L5074; X5 = scrt7_read_2dchar_2dport_v; X5 = UNKNOWNCALL( X5, 0 ); VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); X5 = scrt7_next_2dchar( ); X2 = sc_cons( X5, X2 ); GOBACK( L5059 ); L5074: X6 = scrt1_reverse( X2 ); X5 = scrt3_list_2d_3estring( X6 ); POPSTACKTRACE( sc_string_2d_3esymbol( X5 ) ); } DEFTSCP( scrt7_maxintf_v ); DEFCSTRING( t5077, "SCRT7_MAXINTF" ); DEFTSCP( scrt7_minintf_v ); DEFCSTRING( t5078, "SCRT7_MININTF" ); DEFTSCP( scrt7_number_v ); DEFCSTRING( t5079, "SCRT7_NUMBER" ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); EXTERNTSCPP( scrt1_memv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memv_v ); EXTERNTSCPP( scrt7_accv, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt7_accv_v ); EXTERNTSCPP( scrt2__3e_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_3d_2dtwo_v ); EXTERNTSCPP( scrt2__2a_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2a_2dtwo_v ); EXTERNTSCPP( scrt2_max_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_max_2dtwo_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( sc_readnumber, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_readnumber_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); TSCP scrt7_number( f2782, b2783, s2784 ) TSCP f2782, b2783, s2784; { TSCP X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5079 ); f2782 = CONS( f2782, EMPTYLIST ); b2783 = CONS( b2783, EMPTYLIST ); s2784 = CONS( s2784, EMPTYLIST ); X4 = PAIR_CAR( s2784 ); if ( NEQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L5083; if ( EQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5087; goto L5101; L5083: if ( FALSE( scrt2_zero_3f( X4 ) ) ) goto L5101; L5087: X5 = PAIR_CAR( f2782 ); if ( AND( EQ( TSCPIMMEDIATETAG( X5 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 11026 ) ), CHARACTERTAG ) ) ) goto L5092; X6 = CONS( _TSCP( 11026 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X5, X6 ) ); L5092: if ( NEQ( _S2CINT( X5 ), _S2CINT( _TSCP( 11026 ) ) ) ) goto L5094; X6 = _TSCP( 4 ); SETGEN( PAIR_CAR( s2784 ), X6 ); X6 = scrt7_next_2dchar( ); SETGEN( PAIR_CAR( f2782 ), X6 ); goto L5101; L5094: X6 = PAIR_CAR( f2782 ); if ( AND( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 11538 ) ), CHARACTERTAG ) ) ) goto L5098; X7 = CONS( _TSCP( 11538 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X6, X7 ) ); L5098: if ( NEQ( _S2CINT( X6 ), _S2CINT( _TSCP( 11538 ) ) ) ) goto L5100; X7 = _TSCP( -4 ); SETGEN( PAIR_CAR( s2784 ), X7 ); X7 = scrt7_next_2dchar( ); SETGEN( PAIR_CAR( f2782 ), X7 ); goto L5101; L5100: X7 = _TSCP( 4 ); SETGEN( PAIR_CAR( s2784 ), X7 ); L5101: X4 = PAIR_CAR( b2783 ); if ( NEQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L5105; if ( EQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5109; goto L5117; L5105: if ( FALSE( scrt2_zero_3f( X4 ) ) ) goto L5117; L5109: X5 = PAIR_CAR( f2782 ); if ( AND( EQ( TSCPIMMEDIATETAG( X5 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 8978 ) ), CHARACTERTAG ) ) ) goto L5114; X6 = CONS( _TSCP( 8978 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X5, X6 ) ); L5114: if ( NEQ( _S2CINT( X5 ), _S2CINT( _TSCP( 8978 ) ) ) ) goto L5116; X6 = scrt7_next_2dchar( ); if ( FALSE( scrt1_memv( X6, c2829 ) ) ) goto L5120; X7 = _TSCP( 8 ); SETGEN( PAIR_CAR( b2783 ), X7 ); goto L5127; L5120: if ( FALSE( scrt1_memv( X6, c2830 ) ) ) goto L5122; X7 = _TSCP( 32 ); SETGEN( PAIR_CAR( b2783 ), X7 ); goto L5127; L5122: if ( FALSE( scrt1_memv( X6, c2831 ) ) ) goto L5124; X7 = _TSCP( 40 ); SETGEN( PAIR_CAR( b2783 ), X7 ); goto L5127; L5124: if ( FALSE( scrt1_memv( X6, c2832 ) ) ) goto L5126; X7 = _TSCP( 64 ); SETGEN( PAIR_CAR( b2783 ), X7 ); goto L5127; L5126: scdebug_error( c2155, c2833, CONS( X6, EMPTYLIST ) ); L5127: X6 = scrt7_next_2dchar( ); SETGEN( PAIR_CAR( f2782 ), X6 ); goto L5117; L5116: X6 = _TSCP( 40 ); SETGEN( PAIR_CAR( b2783 ), X6 ); L5117: X4 = sc_cons( PAIR_CAR( f2782 ), EMPTYLIST ); X1 = X4; X5 = scrt7_peek_2dchar_2dport_v; X5 = UNKNOWNCALL( X5, 0 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); X6 = PAIR_CAR( f2782 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 12306 ) ) ) ) goto L5131; X5 = _TSCP( 0 ); goto L5134; L5131: if ( NEQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 12562 ) ) ) ) goto L5133; X5 = _TSCP( 4 ); goto L5134; L5133: X5 = _TSCP( -4 ); L5134: X6 = scrt7_accv( _TSCP( 0 ), PAIR_CAR( b2783 ), PAIR_CAR( f2782 ) ); X7 = C_FIXED( CHAR_C( PAIR_CAR( f2782 ) ) ); X2 = BOOLEAN( EQ( _S2CUINT( PAIR_CAR( f2782 ) ), _S2CUINT( _TSCP( 11794 ) ) ) ); L5135: if ( FALSE( scrt7_delimiter_3f( X4 ) ) ) goto L5136; if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5138; X8 = BOOLEAN( GTE( _S2CINT( X6 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L5139; L5138: X8 = scrt2__3e_3d_2dtwo( X6, _TSCP( 0 ) ); L5139: if ( FALSE( X8 ) ) goto L5146; if ( TRUE( X2 ) ) goto L5146; X9 = PAIR_CAR( s2784 ); if ( BITAND( BITOR( _S2CINT( X9 ), _S2CINT( X6 ) ), 3 ) ) goto L5148; X3 = _TSCP( ITIMES( FIXED_C( X9 ), _S2CINT( X6 ) ) ); goto L5149; L5148: X3 = scrt2__2a_2dtwo( X9, X6 ); L5149: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L5151; X9 = scrt7_maxintf_v; if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X9 ) ), 3 ) ) goto L5155; if ( LTE( _S2CINT( X3 ), _S2CINT( X9 ) ) ) goto L5159; POPSTACKTRACE( X3 ); L5155: if ( FALSE( scrt2__3e_2dtwo( X3, X9 ) ) ) goto L5159; POPSTACKTRACE( X3 ); L5151: POPSTACKTRACE( X3 ); L5136: scrt7_next_2dchar( ); X8 = sc_cons( X4, X1 ); X10 = scrt7_peek_2dchar_2dport_v; X10 = UNKNOWNCALL( X10, 0 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( PROCEDURE_CLOSURE( X10 ) ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 12306 ) ) ) ) goto L5163; if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L5165; X10 = _TSCP( ITIMES( FIXED_C( X5 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L5168; L5165: X10 = scrt2__2a_2dtwo( X5, _TSCP( 8 ) ); goto L5168; L5163: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 12562 ) ) ) ) goto L5167; if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L5169; X11 = _TSCP( ITIMES( FIXED_C( X5 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L5170; L5169: X11 = scrt2__2a_2dtwo( X5, _TSCP( 8 ) ); L5170: if ( BITAND( BITOR( _S2CINT( X11 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5172; X10 = _TSCP( IPLUS( _S2CINT( X11 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5168; L5172: X10 = scrt2__2b_2dtwo( X11, _TSCP( 4 ) ); goto L5168; L5167: X10 = _TSCP( -4 ); L5168: X11 = scrt7_accv( X6, PAIR_CAR( b2783 ), X4 ); X13 = C_FIXED( CHAR_C( X4 ) ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( X13 ) ), 3 ) ) goto L5175; if ( LTE( _S2CINT( X7 ), _S2CINT( X13 ) ) ) goto L5177; X12 = X7; goto L5176; L5177: X12 = X13; goto L5176; L5175: X12 = scrt2_max_2dtwo( X7, X13 ); L5176: if ( TRUE( X2 ) ) goto L5190; if ( NEQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 11794 ) ) ) ) goto L5181; X2 = TRUEVALUE; goto L5190; L5181: X14 = PAIR_CAR( b2783 ); if ( BITAND( BITOR( _S2CINT( X14 ), _S2CINT( _TSCP( 64 ) ) ), 3 ) ) goto L5184; X13 = BOOLEAN( NEQ( _S2CUINT( X14 ), _S2CUINT( _TSCP( 64 ) ) ) ); goto L5187; L5184: if ( FALSE( scrt2__3d_2dtwo( X14, _TSCP( 64 ) ) ) ) goto L5186; X13 = FALSEVALUE; goto L5187; L5186: X13 = TRUEVALUE; L5187: if ( FALSE( X13 ) ) goto L5189; if ( NEQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 25874 ) ) ) ) goto L5191; X2 = TRUEVALUE; goto L5190; L5191: X2 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 17682 ) ) ) ); goto L5190; L5189: X2 = X13; L5190: X7 = X12; X6 = X11; X5 = X10; X4 = X9; X1 = X8; GOBACK( L5135 ); L5146: X5 = scrt1_reverse( X1 ); X4 = scrt3_list_2d_3estring( X5 ); if ( TRUE( X2 ) ) goto L5194; scdebug_error( c2155, c2929, CONS( X4, EMPTYLIST ) ); L5194: if ( EQ( _S2CUINT( PAIR_CAR( b2783 ) ), _S2CUINT( _TSCP( 40 ) ) ) ) goto L5196; scdebug_error( c2155, c2933, CONS( X4, EMPTYLIST ) ); L5196: X5 = sc_readnumber( X4, _TSCP( 0 ) ); if ( FALSE( X5 ) ) goto L5199; if ( NEQ( _S2CUINT( PAIR_CAR( s2784 ) ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L5201; if ( NEQ( TSCPTAG( X5 ), FIXNUMTAG ) ) goto L5203; POPSTACKTRACE( _TSCP( INEGATE( _S2CINT( X5 ) ) ) ); L5203: POPSTACKTRACE( scrt2__2d_2dtwo( c2946, X5 ) ); L5201: POPSTACKTRACE( X5 ); L5199: POPSTACKTRACE( scdebug_error( c2155, c2936, CONS( X4, EMPTYLIST ) ) ); L5159: X4 = scrt7_minintf_v; if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X4 ) ), 3 ) ) goto L5207; if ( GTE( _S2CINT( X3 ), _S2CINT( X4 ) ) ) goto L5211; POPSTACKTRACE( X3 ); L5207: if ( FALSE( scrt2__3c_2dtwo( X3, X4 ) ) ) goto L5211; POPSTACKTRACE( X3 ); L5211: if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), DOUBLEFLOATTAG ) ) ) goto L5215; scdebug_error( c2975, c2976, CONS( X3, EMPTYLIST ) ); L5215: X4 = BOOLEAN( LT( FLOAT_VALUE( X3 ), MINTSCPINTF ) ); if ( TRUE( X4 ) ) goto L5221; if ( LTE( FLOAT_VALUE( X3 ), MAXTSCPINTF ) ) goto L5224; L5221: scdebug_error( c2975, c2981, CONS( X3, EMPTYLIST ) ); L5224: POPSTACKTRACE( FLT_FIX( X3 ) ); } DEFTSCP( scrt7_max_2daccv_2dvalue_v ); DEFCSTRING( t5225, "SCRT7_MAX-ACCV-VALUE" ); EXTERNTSCPP( scrt2_quotient, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_quotient_v ); DEFTSCP( scrt7_accv_v ); DEFCSTRING( t5249, "SCRT7_ACCV" ); EXTERNTSCPP( scrt1_assq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assq_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); TSCP scrt7_accv( v3033, b3034, c3035 ) TSCP v3033, b3034, c3035; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5249 ); L5250: X1 = scrt1_assq( c3035, c3105 ); if ( EQ( _S2CUINT( v3033 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L5252; if ( FALSE( X1 ) ) goto L5254; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L5257; scrt1__24__cdr_2derror( X1 ); L5257: X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5260; scrt1__24__car_2derror( X3 ); L5260: X2 = PAIR_CAR( X3 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( b3034 ) ), 3 ) ) goto L5264; if ( LT( _S2CINT( X2 ), _S2CINT( b3034 ) ) ) goto L5268; POPSTACKTRACE( _TSCP( -4 ) ); L5264: if ( FALSE( scrt2__3e_3d_2dtwo( X2, b3034 ) ) ) goto L5268; POPSTACKTRACE( _TSCP( -4 ) ); L5254: POPSTACKTRACE( _TSCP( -4 ) ); L5252: POPSTACKTRACE( _TSCP( -4 ) ); L5268: X2 = BOOLEAN( EQ( TSCPTAG( v3033 ), FIXNUMTAG ) ); if ( FALSE( X2 ) ) goto L5285; X3 = scrt7_max_2daccv_2dvalue_v; if ( BITAND( BITOR( _S2CINT( v3033 ), _S2CINT( X3 ) ), 3 ) ) goto L5277; if ( GT( _S2CINT( v3033 ), _S2CINT( X3 ) ) ) goto L5281; goto L5285; L5277: if ( FALSE( scrt2__3e_2dtwo( v3033, X3 ) ) ) goto L5285; L5281: if ( EQ( TSCPTAG( v3033 ), FIXNUMTAG ) ) goto L5287; scdebug_error( c3103, c3104, CONS( v3033, EMPTYLIST ) ); L5287: X2 = FIX_FLT( v3033 ); v3033 = X2; GOBACK( L5250 ); L5285: if ( BITAND( BITOR( _S2CINT( b3034 ), _S2CINT( v3033 ) ), 3 ) ) goto L5289; X2 = _TSCP( ITIMES( FIXED_C( b3034 ), _S2CINT( v3033 ) ) ); goto L5290; L5289: X2 = scrt2__2a_2dtwo( b3034, v3033 ); L5290: X4 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5293; scrt1__24__car_2derror( X4 ); L5293: X3 = PAIR_CAR( X4 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X3 ) ), 3 ) ) goto L5296; POPSTACKTRACE( _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( X3 ) ) ) ); L5296: POPSTACKTRACE( scrt2__2b_2dtwo( X2, X3 ) ); } DEFTSCP( scrt7_read_2ddatum_v ); DEFCSTRING( t5298, "SCRT7_READ-DATUM" ); EXTERNTSCPP( scrt7_datum, XAL1( TSCP ) ); EXTERNTSCP( scrt7_datum_v ); TSCP scrt7_read_2ddatum( p3107 ) TSCP p3107; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5298 ); X1 = scrt7_ort_2dproc_ae18f815_v; X2 = scrt7_read_2dchar_2dport_v; X3 = scrt7_peek_2dchar_2dport_v; X4 = p3107; X4 = UNKNOWNCALL( X4, 1 ); scrt7_peek_2dchar_2dport_v = VIA( PROCEDURE_CODE( X4 ) )( c3112, PROCEDURE_CLOSURE( X4 ) ); X4 = p3107; X4 = UNKNOWNCALL( X4, 1 ); scrt7_read_2dchar_2dport_v = VIA( PROCEDURE_CODE( X4 ) )( c3113, PROCEDURE_CLOSURE( X4 ) ); scrt7_ort_2dproc_ae18f815_v = p3107; X6 = scrt7_peek_2dchar_2dport_v; X6 = UNKNOWNCALL( X6, 0 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( PROCEDURE_CLOSURE( X6 ) ); X6 = X5; L5303: if ( FALSE( scrt6_eof_2dobject_3f( X6 ) ) ) goto L5304; X7 = scrt7_read_2dchar_2dport_v; X7 = UNKNOWNCALL( X7, 0 ); X4 = VIA( PROCEDURE_CODE( X7 ) )( PROCEDURE_CLOSURE( X7 ) ); goto L5313; L5304: if ( NOT( OR( EQ( X6, C_CHAR( 040 ) ), AND( GTE( X6, C_CHAR( 011 ) ), LTE( X6, C_CHAR( 015 ) ) ) ) ) ) goto L5306; X7 = scrt7_read_2dchar_2dport_v; X7 = UNKNOWNCALL( X7, 0 ); VIA( PROCEDURE_CODE( X7 ) )( PROCEDURE_CLOSURE( X7 ) ); X7 = scrt7_peek_2dchar_2dport_v; X7 = UNKNOWNCALL( X7, 0 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( PROCEDURE_CLOSURE( X7 ) ); GOBACK( L5303 ); L5306: if ( AND( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 15122 ) ), CHARACTERTAG ) ) ) goto L5310; X7 = CONS( _TSCP( 15122 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X6, X7 ) ); L5310: if ( NEQ( _S2CINT( X6 ), _S2CINT( _TSCP( 15122 ) ) ) ) goto L5312; L5314: X7 = scrt7_next_2dchar( ); if ( AND( EQ( TSCPIMMEDIATETAG( X7 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 2578 ) ), CHARACTERTAG ) ) ) goto L5318; X8 = CONS( _TSCP( 2578 ), EMPTYLIST ); scdebug_error( c2174, c2175, CONS( X7, X8 ) ); L5318: if ( NEQ( _S2CINT( X7 ), _S2CINT( _TSCP( 2578 ) ) ) ) GOBACK( L5314 ); X7 = scrt7_peek_2dchar_2dport_v; X7 = UNKNOWNCALL( X7, 0 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( PROCEDURE_CLOSURE( X7 ) ); GOBACK( L5303 ); L5312: X7 = scrt7_token( ); X4 = scrt7_datum( X7 ); L5313: scrt7_ort_2dproc_ae18f815_v = X1; scrt7_peek_2dchar_2dport_v = X3; scrt7_read_2dchar_2dport_v = X2; POPSTACKTRACE( X4 ); } DEFTSCP( scrt7_datum_v ); DEFCSTRING( t5323, "SCRT7_DATUM" ); EXTERNTSCPP( scrt7_datum_2dlist, XAL1( TSCP ) ); EXTERNTSCP( scrt7_datum_2dlist_v ); EXTERNTSCPP( scrt4_list_2d_3evector, XAL1( TSCP ) ); EXTERNTSCP( scrt4_list_2d_3evector_v ); EXTERNTSCPP( scrt7_datum_2dvector, XAL1( TSCP ) ); EXTERNTSCP( scrt7_datum_2dvector_v ); EXTERNTSCP( scrt4__25record_2dread_v ); TSCP scrt7_datum( c3143 ) TSCP c3143; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5323 ); if ( NEQ( _S2CUINT( c3143 ), _S2CUINT( scrt7_token_2dleft_2dparen_v ) ) ) goto L5325; X1 = scrt7_token( ); POPSTACKTRACE( scrt7_datum_2dlist( X1 ) ); L5325: if ( NEQ( _S2CUINT( c3143 ), _S2CUINT( scrt7_token_2dvector_v ) ) ) goto L5327; X2 = scrt7_token( ); X1 = scrt7_datum_2dvector( X2 ); POPSTACKTRACE( scrt4_list_2d_3evector( X1 ) ); L5327: if ( NEQ( _S2CUINT( c3143 ), _S2CUINT( scrt7_token_2dquote_v ) ) ) goto L5329; X4 = scrt7_token( ); X3 = scrt7_datum( X4 ); X2 = sc_cons( X3, EMPTYLIST ); X1 = sc_cons( c2135, X2 ); POPSTACKTRACE( X1 ); L5329: if ( NEQ( _S2CUINT( c3143 ), _S2CUINT( scrt7_token_2dquasiquote_v ) ) ) goto L5332; X4 = scrt7_token( ); X3 = scrt7_datum( X4 ); X2 = sc_cons( X3, EMPTYLIST ); X1 = sc_cons( c2137, X2 ); POPSTACKTRACE( X1 ); L5332: if ( NEQ( _S2CUINT( c3143 ), _S2CUINT( scrt7_token_2dunquote_v ) ) ) goto L5335; X4 = scrt7_token( ); X3 = scrt7_datum( X4 ); X2 = sc_cons( X3, EMPTYLIST ); X1 = sc_cons( c2141, X2 ); POPSTACKTRACE( X1 ); L5335: if ( NEQ( _S2CUINT( c3143 ), _S2CUINT( scrt7_2dsplicing_542533dd_v ) ) ) goto L5338; X4 = scrt7_token( ); X3 = scrt7_datum( X4 ); X2 = sc_cons( X3, EMPTYLIST ); X1 = sc_cons( c2139, X2 ); POPSTACKTRACE( X1 ); L5338: if ( NEQ( TSCPTAG( c3143 ), PAIRTAG ) ) goto L5341; if ( NEQ( _S2CUINT( c3143 ), _S2CUINT( scrt7_token_2drecord_v ) ) ) goto L5343; X2 = sc_cons( c3168, scrt7_ort_2dproc_ae18f815_v ); X1 = scrt4__25record_2dread_v; X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ) ); L5343: POPSTACKTRACE( scdebug_error( c2155, c3167, CONS( c3143, EMPTYLIST ) ) ); L5341: POPSTACKTRACE( c3143 ); } DEFTSCP( scrt7_datum_2dlist_v ); DEFCSTRING( t5345, "SCRT7_DATUM-LIST" ); TSCP scrt7_datum_2dlist( c3180 ) TSCP c3180; { TSCP X3, X2, X1; PUSHSTACKTRACE( t5345 ); if ( EQ( _S2CUINT( c3180 ), _S2CUINT( scrt7_token_2dright_2dparen_v ) ) ) goto L5347; if ( NEQ( _S2CUINT( c3180 ), _S2CUINT( scrt7_token_2dperiod_v ) ) ) goto L5349; X2 = scrt7_token( ); X1 = scrt7_datum( X2 ); X2 = scrt7_token( ); if ( EQ( _S2CUINT( X2 ), _S2CUINT( scrt7_token_2dright_2dparen_v ) ) ) goto L5352; POPSTACKTRACE( scdebug_error( c2155, c3192, EMPTYLIST ) ); L5352: POPSTACKTRACE( X1 ); L5349: X1 = scrt7_datum( c3180 ); X3 = scrt7_token( ); X2 = scrt7_datum_2dlist( X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L5347: POPSTACKTRACE( EMPTYLIST ); } DEFTSCP( scrt7_datum_2dvector_v ); DEFCSTRING( t5354, "SCRT7_DATUM-VECTOR" ); TSCP scrt7_datum_2dvector( c3194 ) TSCP c3194; { TSCP X3, X2, X1; PUSHSTACKTRACE( t5354 ); if ( EQ( _S2CUINT( c3194 ), _S2CUINT( scrt7_token_2dright_2dparen_v ) ) ) goto L5356; X1 = scrt7_datum( c3194 ); X3 = scrt7_token( ); X2 = scrt7_datum_2dvector( X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L5356: POPSTACKTRACE( EMPTYLIST ); } DEFTSCP( scrt7_write_2dtoken_2dport_v ); DEFCSTRING( t5358, "SCRT7_WRITE-TOKEN-PORT" ); DEFTSCP( scrt7_write_2dlength_2dport_v ); DEFCSTRING( t5359, "SCRT7_WRITE-LENGTH-PORT" ); DEFTSCP( scrt7_write_2dwidth_2dport_v ); DEFCSTRING( t5360, "SCRT7_WRITE-WIDTH-PORT" ); DEFTSCP( scrt7_ort_2dproc_61a60f78_v ); DEFCSTRING( t5361, "SCRT7_WRITE/DISPLAY-PORT-PROC" ); DEFTSCP( scrt7_write_2fdisplay_v ); DEFCSTRING( t5362, "SCRT7_WRITE/DISPLAY" ); EXTERNTSCPP( scrt7_write_2fdisplay2, XAL6( TSCP, TSCP, TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt7_write_2fdisplay2_v ); TSCP scrt7_write_2fdisplay( o3203, r3204, p3205 ) TSCP o3203, r3204, p3205; { TSCP X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5362 ); X1 = scrt7_ort_2dproc_61a60f78_v; X2 = scrt7_write_2dwidth_2dport_v; X3 = scrt7_write_2dlength_2dport_v; X4 = scrt7_write_2dtoken_2dport_v; X5 = p3205; X5 = UNKNOWNCALL( X5, 1 ); scrt7_write_2dtoken_2dport_v = VIA( PROCEDURE_CODE( X5 ) )( c3211, PROCEDURE_CLOSURE( X5 ) ); X6 = p3205; X6 = UNKNOWNCALL( X6, 1 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( c3212, PROCEDURE_CLOSURE( X6 ) ); X5 = UNKNOWNCALL( X5, 0 ); scrt7_write_2dlength_2dport_v = VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); X6 = p3205; X6 = UNKNOWNCALL( X6, 1 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( c3213, PROCEDURE_CLOSURE( X6 ) ); X5 = UNKNOWNCALL( X5, 0 ); scrt7_write_2dwidth_2dport_v = VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); scrt7_ort_2dproc_61a60f78_v = p3205; X8 = p3205; X8 = UNKNOWNCALL( X8, 1 ); X7 = VIA( PROCEDURE_CODE( X8 ) )( c3217, PROCEDURE_CLOSURE( X8 ) ); X7 = UNKNOWNCALL( X7, 0 ); if ( FALSE( VIA( PROCEDURE_CODE( X7 ) )( PROCEDURE_CLOSURE( X7 ) ) ) ) goto L5365; X6 = _TSCP( 0 ); goto L5366; L5365: X6 = FALSEVALUE; L5366: X9 = p3205; X9 = UNKNOWNCALL( X9, 1 ); X8 = VIA( PROCEDURE_CODE( X9 ) )( c3218, PROCEDURE_CLOSURE( X9 ) ); X8 = UNKNOWNCALL( X8, 0 ); X7 = VIA( PROCEDURE_CODE( X8 ) )( PROCEDURE_CLOSURE( X8 ) ); X10 = p3205; X10 = UNKNOWNCALL( X10, 1 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( c3219, PROCEDURE_CLOSURE( X10 ) ); X9 = UNKNOWNCALL( X9, 0 ); if ( FALSE( VIA( PROCEDURE_CODE( X9 ) )( PROCEDURE_CLOSURE( X9 ) ) ) ) goto L5367; X8 = EMPTYLIST; goto L5368; L5367: X8 = FALSEVALUE; L5368: X5 = scrt7_write_2fdisplay2( o3203, r3204, X6, X7, scrt7_write_2dlength_2dport_v, X8 ); scrt7_write_2dtoken_2dport_v = X4; scrt7_write_2dlength_2dport_v = X3; scrt7_write_2dwidth_2dport_v = X2; scrt7_ort_2dproc_61a60f78_v = X1; POPSTACKTRACE( X5 ); } DEFTSCP( scrt7_write_2fdisplay2_v ); DEFCSTRING( t5370, "SCRT7_WRITE/DISPLAY2" ); EXTERNTSCPP( scrt7_readable_2dsymbol, XAL1( TSCP ) ); EXTERNTSCP( scrt7_readable_2dsymbol_v ); EXTERNTSCPP( scrt7_fixed_2d_3eclist, XAL1( TSCP ) ); EXTERNTSCP( scrt7_fixed_2d_3eclist_v ); EXTERNTSCPP( scrt7_readable_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt7_readable_2dstring_v ); EXTERNTSCPP( scrt7_readable_2dchar, XAL1( TSCP ) ); EXTERNTSCP( scrt7_readable_2dchar_v ); EXTERNTSCPP( scrt4_vector_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt4_vector_2d_3elist_v ); EXTERNTSCPP( scrt7_float_2d_3estring, XAL1( TSCP ) ); EXTERNTSCP( scrt7_float_2d_3estring_v ); EXTERNTSCP( sc_undefined ); EXTERNTSCPP( scrt4_p_2dmethod_3ccf392b, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_p_2dmethod_3ccf392b_v ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); TSCP scrt7_c3235( x3237, c5503 ) TSCP x3237, c5503; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "COUNT-CHAR [inside WRITE/DISPLAY2]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c5503, 0 ); X4 = PAIR_CAR( DISPLAY( 0 ) ); if ( NOT( AND( EQ( TSCPTAG( x3237 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3237 ), STRINGTAG ) ) ) ) goto L5505; X6 = C_FIXED( STRING_LENGTH( x3237 ) ); goto L5506; L5505: X6 = FALSEVALUE; L5506: if ( FALSE( X6 ) ) goto L5509; X5 = X6; goto L5515; L5509: if ( NEQ( TSCPTAG( x3237 ), PAIRTAG ) ) goto L5511; X7 = scrt1_length( x3237 ); goto L5512; L5511: X7 = FALSEVALUE; L5512: if ( FALSE( X7 ) ) goto L5514; X5 = X7; goto L5515; L5514: X5 = _TSCP( 4 ); L5515: if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( X4 ) ), 3 ) ) goto L5517; X3 = _TSCP( IPLUS( _S2CINT( X5 ), _S2CINT( X4 ) ) ); goto L5518; L5517: X3 = scrt2__2b_2dtwo( X5, X4 ); L5518: X2 = SETGEN( PAIR_CAR( DISPLAY( 0 ) ), X3 ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } EXTERNTSCPP( scrt2__3c_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_3d_2dtwo_v ); EXTERNTSCPP( scrt7_write_2fdisplay_2dlist, XAL6( TSCP, TSCP, TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt7_write_2fdisplay_2dlist_v ); TSCP scrt7_write_2fdisplay2( o3221, r3222, i3223, w3224, w3225, c3226 ) TSCP o3221, r3222, i3223, w3224, w3225, c3226; { TSCP X7, X6, X5, X4, X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t5370 ); L5371: X1 = BOOLEAN( EQ( _S2CUINT( w3224 ), _S2CUINT( _TSCP( 0 ) ) ) ); if ( FALSE( X1 ) ) goto L5387; if ( EQ( TSCPTAG( o3221 ), PAIRTAG ) ) goto L5380; if ( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), VECTORTAG ) ) ) goto L5380; if ( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), RECORDTAG ) ) ) goto L5380; L5387: X1 = BOOLEAN( NEQ( _S2CUINT( c3226 ), _S2CUINT( FALSEVALUE ) ) ); if ( FALSE( X1 ) ) goto L5403; if ( NEQ( TSCPTAG( o3221 ), PAIRTAG ) ) goto L5392; X2 = TRUEVALUE; goto L5395; L5392: if ( NOT( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), VECTORTAG ) ) ) ) goto L5394; X2 = TRUEVALUE; goto L5395; L5394: X2 = BOOLEAN( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), RECORDTAG ) ) ); L5395: if ( FALSE( X2 ) ) goto L5403; if ( FALSE( scrt1_memq( o3221, c3226 ) ) ) goto L5403; X3 = scrt7_write_2dtoken_2dport_v; X3 = UNKNOWNCALL( X3, 1 ); SDVAL = VIA( PROCEDURE_CODE( X3 ) )( c3596, PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5380: X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( c3397, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5403: if ( NEQ( TSCPTAG( o3221 ), PAIRTAG ) ) goto L5404; X2 = PAIR_CDR( o3221 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5406; X3 = PAIR_CDR( o3221 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5413; scrt1__24__cdr_2derror( X3 ); L5413: X2 = PAIR_CDR( X3 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L5409; X2 = PAIR_CAR( o3221 ); X1 = scrt1_assq( X2, c3595 ); goto L5407; L5409: X1 = FALSEVALUE; goto L5407; L5406: X1 = FALSEVALUE; L5407: if ( NEQ( _S2CUINT( scrt7_write_2dlength_2dport_v ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5417; X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c3561, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5417: if ( FALSE( X1 ) ) goto L5435; if ( FALSE( r3222 ) ) goto L5435; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L5426; scrt1__24__cdr_2derror( X1 ); L5426: X4 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5429; scrt1__24__car_2derror( X4 ); L5429: X3 = PAIR_CAR( X4 ); X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); X3 = PAIR_CDR( o3221 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5433; scrt1__24__car_2derror( X3 ); L5433: X2 = PAIR_CAR( X3 ); o3221 = X2; GOBACK( L5371 ); L5404: if ( NOT( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), SYMBOLTAG ) ) ) ) goto L5436; if ( FALSE( r3222 ) ) goto L5438; if ( FALSE( scrt1_memq( o3221, c3424 ) ) ) goto L5440; X2 = SYMBOL_NAME( o3221 ); X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5440: X2 = scrt7_readable_2dsymbol( o3221 ); X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5438: X2 = SYMBOL_NAME( o3221 ); X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5436: if ( NEQ( TSCPTAG( o3221 ), FIXNUMTAG ) ) goto L5444; X2 = scrt7_fixed_2d_3eclist( o3221 ); X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5444: if ( NOT( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), STRINGTAG ) ) ) ) goto L5446; if ( FALSE( r3222 ) ) goto L5448; X2 = scrt7_readable_2dstring( o3221 ); goto L5449; L5448: X2 = o3221; L5449: X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5446: if ( NEQ( TSCPIMMEDIATETAG( o3221 ), CHARACTERTAG ) ) goto L5450; if ( FALSE( r3222 ) ) goto L5452; X2 = scrt7_readable_2dchar( o3221 ); goto L5453; L5452: X2 = o3221; L5453: X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5450: X1 = BOOLEAN( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), STRINGTAG ) ) ); if ( TRUE( X1 ) ) goto L5458; if ( NOT( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), VECTORTAG ) ) ) ) goto L5459; X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); VIA( PROCEDURE_CODE( X2 ) )( c3397, PROCEDURE_CLOSURE( X2 ) ); X2 = scrt4_vector_2d_3elist( o3221 ); if ( FALSE( i3223 ) ) goto L5462; if ( BITAND( BITOR( _S2CINT( i3223 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5464; X3 = _TSCP( IPLUS( _S2CINT( i3223 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5463; L5464: X3 = scrt2__2b_2dtwo( i3223, _TSCP( 4 ) ); goto L5463; L5462: X3 = i3223; L5463: if ( EQ( _S2CUINT( c3226 ), _S2CUINT( FALSEVALUE ) ) ) goto L5466; c3226 = sc_cons( o3221, c3226 ); goto L5467; L5466: c3226 = FALSEVALUE; L5467: i3223 = X3; o3221 = X2; GOBACK( L5371 ); L5459: if ( NOT( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), DOUBLEFLOATTAG ) ) ) ) goto L5468; X3 = scrt7_float_2d_3estring( o3221 ); X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5468: if ( NEQ( _S2CUINT( o3221 ), _S2CUINT( TRUEVALUE ) ) ) goto L5470; X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c3394, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5470: if ( NEQ( _S2CUINT( o3221 ), _S2CUINT( FALSEVALUE ) ) ) goto L5472; X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c3393, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5472: if ( NEQ( _S2CUINT( o3221 ), _S2CUINT( EMPTYLIST ) ) ) goto L5474; X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c3392, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5474: if ( FALSE( scrt6_eof_2dobject_3f( o3221 ) ) ) goto L5476; X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c3391, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5476: if ( NEQ( _S2CUINT( o3221 ), _S2CUINT( sc_undefined ) ) ) goto L5478; X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c3390, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5478: if ( NOT( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), PROCEDURETAG ) ) ) ) goto L5480; X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c3389, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5480: if ( NOT( AND( EQ( TSCPTAG( o3221 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3221 ), RECORDTAG ) ) ) ) goto L5482; if ( FALSE( r3222 ) ) goto L5484; X3 = c3388; goto L5485; L5484: X3 = c3387; L5485: X2 = scrt4_p_2dmethod_3ccf392b( o3221, X3 ); X5 = sc_cons( c3168, scrt7_ort_2dproc_61a60f78_v ); X4 = X2; X4 = UNKNOWNCALL( X4, 6 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( o3221, X5, i3223, w3224, w3225, c3226, PROCEDURE_CLOSURE( X4 ) ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5488; X4 = PAIR_CAR( X3 ); if ( FALSE( i3223 ) ) goto L5491; if ( BITAND( BITOR( _S2CINT( i3223 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L5493; X5 = _TSCP( IPLUS( _S2CINT( i3223 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L5492; L5493: X5 = scrt2__2b_2dtwo( i3223, _TSCP( 8 ) ); goto L5492; L5491: X5 = i3223; L5492: if ( EQ( _S2CUINT( c3226 ), _S2CUINT( FALSEVALUE ) ) ) goto L5495; c3226 = sc_cons( o3221, c3226 ); goto L5496; L5495: c3226 = FALSEVALUE; L5496: i3223 = X5; o3221 = X4; GOBACK( L5371 ); L5488: SDVAL = FALSEVALUE; DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5482: X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c3359, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5435: if ( FALSE( i3223 ) ) goto L5536; X3 = o3221; DISPLAY( 0 ) = _TSCP( 0 ); X4 = scrt7_write_2dtoken_2dport_v; DISPLAY( 0 ) = CONS( DISPLAY( 0 ), EMPTYLIST ); X5 = _TSCP( 0 ); X5 = CONS( X5, EMPTYLIST ); X6 = MAKEPROCEDURE( 1, 0, scrt7_c3235, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( X5 ), X6 ); scrt7_write_2dtoken_2dport_v = PAIR_CAR( X5 ); if ( FALSE( w3224 ) ) goto L5519; X6 = w3224; goto L5520; L5519: X6 = _TSCP( 200 ); L5520: if ( FALSE( w3225 ) ) goto L5521; X7 = w3225; goto L5522; L5521: X7 = _TSCP( 200 ); L5522: scrt7_write_2fdisplay2( X3, r3222, FALSEVALUE, X6, X7, c3226 ); scrt7_write_2dtoken_2dport_v = X4; X2 = PAIR_CAR( DISPLAY( 0 ) ); if ( BITAND( BITOR( _S2CINT( i3223 ), _S2CINT( X2 ) ), 3 ) ) goto L5524; X1 = _TSCP( IPLUS( _S2CINT( i3223 ), _S2CINT( X2 ) ) ); goto L5525; L5524: X1 = scrt2__2b_2dtwo( i3223, X2 ); L5525: X2 = scrt7_write_2dwidth_2dport_v; if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X2 ) ), 3 ) ) goto L5528; if ( LTE( _S2CINT( X1 ), _S2CINT( X2 ) ) ) goto L5532; goto L5536; L5528: if ( FALSE( scrt2__3c_3d_2dtwo( X1, X2 ) ) ) goto L5536; L5532: i3223 = FALSEVALUE; GOBACK( L5371 ); L5458: X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( o3221, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5536: X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); VIA( PROCEDURE_CODE( X1 ) )( c3456, PROCEDURE_CLOSURE( X1 ) ); X1 = PAIR_CAR( o3221 ); if ( FALSE( i3223 ) ) goto L5539; if ( BITAND( BITOR( _S2CINT( i3223 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5541; X2 = _TSCP( IPLUS( _S2CINT( i3223 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5540; L5541: X2 = scrt2__2b_2dtwo( i3223, _TSCP( 4 ) ); goto L5540; L5539: X2 = i3223; L5540: if ( FALSE( w3224 ) ) goto L5543; if ( BITAND( BITOR( _S2CINT( w3224 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5545; X3 = _TSCP( IDIFFERENCE( _S2CINT( w3224 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5544; L5545: X3 = scrt2__2d_2dtwo( w3224, _TSCP( 4 ) ); goto L5544; L5543: X3 = w3224; L5544: X5 = scrt7_write_2dlength_2dport_v; if ( FALSE( X5 ) ) goto L5548; X6 = scrt7_write_2dlength_2dport_v; if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5551; X4 = _TSCP( IDIFFERENCE( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5549; L5551: X4 = scrt2__2d_2dtwo( X6, _TSCP( 4 ) ); goto L5549; L5548: X4 = X5; L5549: if ( EQ( _S2CUINT( c3226 ), _S2CUINT( FALSEVALUE ) ) ) goto L5553; X5 = sc_cons( o3221, c3226 ); goto L5554; L5553: X5 = FALSEVALUE; L5554: scrt7_write_2fdisplay2( X1, r3222, X2, X3, X4, X5 ); X1 = PAIR_CDR( o3221 ); if ( FALSE( i3223 ) ) goto L5556; if ( BITAND( BITOR( _S2CINT( i3223 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5558; X2 = _TSCP( IPLUS( _S2CINT( i3223 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5557; L5558: X2 = scrt2__2b_2dtwo( i3223, _TSCP( 4 ) ); goto L5557; L5556: X2 = i3223; L5557: if ( FALSE( w3224 ) ) goto L5560; if ( BITAND( BITOR( _S2CINT( w3224 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5562; X3 = _TSCP( IDIFFERENCE( _S2CINT( w3224 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5561; L5562: X3 = scrt2__2d_2dtwo( w3224, _TSCP( 4 ) ); goto L5561; L5560: X3 = w3224; L5561: X5 = scrt7_write_2dlength_2dport_v; if ( FALSE( X5 ) ) goto L5565; X6 = scrt7_write_2dlength_2dport_v; if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5568; X4 = _TSCP( IDIFFERENCE( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5566; L5568: X4 = scrt2__2d_2dtwo( X6, _TSCP( 4 ) ); goto L5566; L5565: X4 = X5; L5566: if ( EQ( _S2CUINT( c3226 ), _S2CUINT( FALSEVALUE ) ) ) goto L5570; X5 = sc_cons( o3221, c3226 ); goto L5571; L5570: X5 = FALSEVALUE; L5571: SDVAL = scrt7_write_2fdisplay_2dlist( X1, r3222, X2, X3, X4, X5 ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } DEFTSCP( scrt7_write_2fdisplay_2dlist_v ); DEFCSTRING( t5572, "SCRT7_WRITE/DISPLAY-LIST" ); EXTERNTSCPP( scrt3_substring, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt3_substring_v ); TSCP scrt7_p3605( x3607 ) TSCP x3607; { TSCP X3, X2, X1; PUSHSTACKTRACE( "PRINT [inside WRITE/DISPLAY-LIST]" ); if ( FALSE( DISPLAY( 0 ) ) ) goto L5576; X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); VIA( PROCEDURE_CODE( X1 ) )( _TSCP( 2578 ), PROCEDURE_CLOSURE( X1 ) ); X1 = DISPLAY( 0 ); L5580: if ( NEQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L5582; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5586; goto L5589; L5582: if ( TRUE( scrt2_zero_3f( X1 ) ) ) goto L5589; L5586: X2 = scrt7_write_2dtoken_2dport_v; X2 = UNKNOWNCALL( X2, 1 ); VIA( PROCEDURE_CODE( X2 ) )( _TSCP( 8210 ), PROCEDURE_CLOSURE( X2 ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5591; X1 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L5580 ); L5591: X1 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); GOBACK( L5580 ); L5589: if ( AND( EQ( TSCPTAG( x3607 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3607 ), STRINGTAG ) ) ) goto L5594; scdebug_error( c3257, c3258, CONS( x3607, EMPTYLIST ) ); L5594: X3 = C_FIXED( STRING_LENGTH( x3607 ) ); X2 = scrt3_substring( x3607, _TSCP( 4 ), X3 ); X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ) ); L5576: X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( x3607, PROCEDURE_CLOSURE( X1 ) ) ); } TSCP scrt7_write_2fdisplay_2dlist( o3598, r3599, i3600, w3601, w3602, c3603 ) TSCP o3598, r3599, i3600, w3601, w3602, c3603; { TSCP X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t5572 ); DISPLAY( 0 ) = i3600; L5573: if ( NEQ( _S2CUINT( o3598 ), _S2CUINT( EMPTYLIST ) ) ) goto L5596; X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( c3675, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5596: if ( NEQ( _S2CUINT( w3602 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5598; SDVAL = scrt7_p3605( c3676 ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5598: X1 = BOOLEAN( NEQ( _S2CUINT( c3603 ), _S2CUINT( FALSEVALUE ) ) ); if ( FALSE( X1 ) ) goto L5606; if ( FALSE( scrt1_memq( o3598, c3603 ) ) ) goto L5606; SDVAL = scrt7_p3605( c3676 ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L5606: if ( NEQ( TSCPTAG( o3598 ), PAIRTAG ) ) goto L5607; scrt7_p3605( c3654 ); X1 = PAIR_CAR( o3598 ); scrt7_write_2fdisplay2( X1, r3599, DISPLAY( 0 ), w3601, w3602, c3603 ); X1 = PAIR_CDR( o3598 ); if ( FALSE( w3602 ) ) goto L5612; if ( BITAND( BITOR( _S2CINT( w3602 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5614; X2 = _TSCP( IDIFFERENCE( _S2CINT( w3602 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5613; L5614: X2 = scrt2__2d_2dtwo( w3602, _TSCP( 4 ) ); goto L5613; L5612: X2 = w3602; L5613: w3602 = X2; o3598 = X1; GOBACK( L5573 ); L5607: scrt7_p3605( c3674 ); scrt7_write_2fdisplay2( o3598, r3599, DISPLAY( 0 ), w3601, w3602, c3603 ); X1 = scrt7_write_2dtoken_2dport_v; X1 = UNKNOWNCALL( X1, 1 ); SDVAL = VIA( PROCEDURE_CODE( X1 ) )( c3675, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } DEFTSCP( scrt7_readable_2dchar_v ); DEFCSTRING( t5617, "SCRT7_READABLE-CHAR" ); EXTERNTSCPP( scrt1_assoc, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assoc_v ); TSCP scrt7_readable_2dchar( o3678 ) TSCP o3678; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5617 ); if ( AND( EQ( TSCPIMMEDIATETAG( o3678 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 8210 ) ), CHARACTERTAG ) ) ) goto L5620; X2 = CONS( _TSCP( 8210 ), EMPTYLIST ); scdebug_error( c3688, c2175, CONS( o3678, X2 ) ); L5620: X1 = BOOLEAN( GT( _S2CINT( o3678 ), _S2CINT( _TSCP( 8210 ) ) ) ); if ( FALSE( X1 ) ) goto L5632; if ( AND( EQ( TSCPIMMEDIATETAG( o3678 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 32274 ) ), CHARACTERTAG ) ) ) goto L5627; X2 = CONS( _TSCP( 32274 ), EMPTYLIST ); scdebug_error( c3696, c2175, CONS( o3678, X2 ) ); L5627: if ( GT( _S2CINT( o3678 ), _S2CINT( _TSCP( 32274 ) ) ) ) goto L5632; X5 = sc_cons( o3678, EMPTYLIST ); X4 = sc_cons( _TSCP( 23570 ), X5 ); X3 = sc_cons( _TSCP( 8978 ), X4 ); X2 = X3; POPSTACKTRACE( scrt3_list_2d_3estring( X2 ) ); L5632: X1 = scrt1_assoc( o3678, c3711 ); if ( FALSE( X1 ) ) goto L5634; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L5637; scrt1__24__cdr_2derror( X1 ); L5637: X2 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5640; scrt1__24__car_2derror( X2 ); L5640: POPSTACKTRACE( PAIR_CAR( X2 ) ); L5634: POPSTACKTRACE( c3700 ); } DEFTSCP( scrt7_readable_2dstring_v ); DEFCSTRING( t5642, "SCRT7_READABLE-STRING" ); TSCP scrt7_readable_2dstring( o3715 ) TSCP o3715; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5642 ); X1 = c3824; if ( AND( EQ( TSCPTAG( o3715 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( o3715 ), STRINGTAG ) ) ) goto L5646; scdebug_error( c3257, c3258, CONS( o3715, EMPTYLIST ) ); L5646: X2 = C_FIXED( STRING_LENGTH( o3715 ) ); X3 = _TSCP( 0 ); L5648: X1 = CONS( X1, EMPTYLIST ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X3 ) ), 3 ) ) goto L5650; if ( EQ( _S2CUINT( X2 ), _S2CUINT( X3 ) ) ) goto L5654; goto L5655; L5650: if ( FALSE( scrt2__3d_2dtwo( X2, X3 ) ) ) goto L5655; L5654: X4 = sc_cons( _TSCP( 8722 ), PAIR_CAR( X1 ) ); POPSTACKTRACE( scrt1_reverse( X4 ) ); L5655: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L5660; scdebug_error( c3743, c2606, CONS( X3, EMPTYLIST ) ); L5660: X6 = BOOLEAN( LT( _S2CINT( X3 ), 0 ) ); if ( TRUE( X6 ) ) goto L5666; X7 = C_FIXED( STRING_LENGTH( o3715 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X7 ) ), 3 ) ) goto L5670; if ( GTE( _S2CINT( X3 ), _S2CINT( X7 ) ) ) goto L5666; goto L5677; L5670: if ( FALSE( scrt2__3e_3d_2dtwo( X3, X7 ) ) ) goto L5677; L5666: scdebug_error( c3743, c2981, CONS( X3, EMPTYLIST ) ); L5677: X5 = C_CHAR( STRING_CHAR( o3715, X3 ) ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( _TSCP( 23570 ) ) ) ); if ( TRUE( X4 ) ) goto L5682; X6 = BOOLEAN( LT( _S2CINT( X3 ), 0 ) ); if ( TRUE( X6 ) ) goto L5690; X7 = C_FIXED( STRING_LENGTH( o3715 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X7 ) ), 3 ) ) goto L5694; if ( GTE( _S2CINT( X3 ), _S2CINT( X7 ) ) ) goto L5690; goto L5701; L5694: if ( FALSE( scrt2__3e_3d_2dtwo( X3, X7 ) ) ) goto L5701; L5690: scdebug_error( c3743, c2981, CONS( X3, EMPTYLIST ) ); L5701: X5 = C_CHAR( STRING_CHAR( o3715, X3 ) ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( _TSCP( 8722 ) ) ) ) goto L5702; L5682: X5 = sc_cons( _TSCP( 23570 ), PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X5 ); L5702: X6 = BOOLEAN( LT( _S2CINT( X3 ), 0 ) ); if ( TRUE( X6 ) ) goto L5708; X7 = C_FIXED( STRING_LENGTH( o3715 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X7 ) ), 3 ) ) goto L5712; if ( GTE( _S2CINT( X3 ), _S2CINT( X7 ) ) ) goto L5708; goto L5719; L5712: if ( FALSE( scrt2__3e_3d_2dtwo( X3, X7 ) ) ) goto L5719; L5708: scdebug_error( c3743, c2981, CONS( X3, EMPTYLIST ) ); L5719: X5 = C_CHAR( STRING_CHAR( o3715, X3 ) ); X4 = sc_cons( X5, PAIR_CAR( X1 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5720; X3 = _TSCP( IPLUS( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5721; L5720: X3 = scrt2__2b_2dtwo( X3, _TSCP( 4 ) ); L5721: X1 = X4; GOBACK( L5648 ); } DEFTSCP( scrt7_readable_2dsymbol_v ); DEFCSTRING( t5722, "SCRT7_READABLE-SYMBOL" ); EXTERNTSCPP( scrt3_char_2dupper_2dcase_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt3_char_2dupper_2dcase_3f_v ); TSCP scrt7_readable_2dsymbol( o3830 ) TSCP o3830; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5722 ); o3830 = CONS( o3830, EMPTYLIST ); X2 = PAIR_CAR( o3830 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) goto L5725; scdebug_error( c3422, c3423, CONS( X2, EMPTYLIST ) ); L5725: X1 = SYMBOL_NAME( X2 ); SETGEN( PAIR_CAR( o3830 ), X1 ); X1 = EMPTYLIST; X3 = PAIR_CAR( o3830 ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), STRINGTAG ) ) ) goto L5729; scdebug_error( c3257, c3258, CONS( X3, EMPTYLIST ) ); L5729: X2 = C_FIXED( STRING_LENGTH( X3 ) ); X3 = _TSCP( 0 ); L5731: X1 = CONS( X1, EMPTYLIST ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X2 ) ), 3 ) ) goto L5733; if ( EQ( _S2CUINT( X3 ), _S2CUINT( X2 ) ) ) goto L5737; goto L5738; L5733: if ( FALSE( scrt2__3d_2dtwo( X3, X2 ) ) ) goto L5738; L5737: POPSTACKTRACE( scrt1_reverse( PAIR_CAR( X1 ) ) ); L5738: X5 = PAIR_CAR( o3830 ); if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L5743; scdebug_error( c3743, c2606, CONS( X3, EMPTYLIST ) ); L5743: X6 = BOOLEAN( LT( _S2CINT( X3 ), 0 ) ); if ( TRUE( X6 ) ) goto L5749; if ( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), STRINGTAG ) ) ) goto L5751; scdebug_error( c3257, c3258, CONS( X5, EMPTYLIST ) ); L5751: X7 = C_FIXED( STRING_LENGTH( X5 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X7 ) ), 3 ) ) goto L5755; if ( GTE( _S2CINT( X3 ), _S2CINT( X7 ) ) ) goto L5749; goto L5762; L5755: if ( FALSE( scrt2__3e_3d_2dtwo( X3, X7 ) ) ) goto L5762; L5749: scdebug_error( c3743, c2981, CONS( X3, EMPTYLIST ) ); L5762: X4 = C_CHAR( STRING_CHAR( X5, X3 ) ); if ( FALSE( scrt3_char_2dalphabetic_3f( X4 ) ) ) goto L5764; if ( FALSE( scrt3_char_2dupper_2dcase_3f( X4 ) ) ) goto L5766; X5 = FALSEVALUE; goto L5765; L5766: X5 = TRUEVALUE; goto L5765; L5764: X5 = TRUEVALUE; L5765: if ( FALSE( X5 ) ) goto L5788; if ( FALSE( scrt1_memq( X4, c2228 ) ) ) goto L5772; X6 = FALSEVALUE; goto L5773; L5772: X6 = TRUEVALUE; L5773: if ( FALSE( X6 ) ) goto L5788; if ( FALSE( scrt1_memq( X4, c3872 ) ) ) goto L5778; X7 = FALSEVALUE; goto L5779; L5778: X7 = TRUEVALUE; L5779: if ( FALSE( X7 ) ) goto L5788; if ( TRUE( scrt3_char_2dnumeric_3f( X4 ) ) ) goto L5788; X8 = sc_cons( _TSCP( 23570 ), PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X8 ); goto L5796; L5788: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5796; if ( TRUE( scrt3_char_2dalphabetic_3f( X4 ) ) ) goto L5796; if ( TRUE( scrt1_memq( X4, c2228 ) ) ) goto L5796; X5 = sc_cons( _TSCP( 23570 ), PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X5 ); L5796: X6 = PAIR_CAR( o3830 ); X7 = BOOLEAN( LT( _S2CINT( X3 ), 0 ) ); if ( TRUE( X7 ) ) goto L5803; if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), STRINGTAG ) ) ) goto L5805; scdebug_error( c3257, c3258, CONS( X6, EMPTYLIST ) ); L5805: X8 = C_FIXED( STRING_LENGTH( X6 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X8 ) ), 3 ) ) goto L5809; if ( GTE( _S2CINT( X3 ), _S2CINT( X8 ) ) ) goto L5803; goto L5816; L5809: if ( FALSE( scrt2__3e_3d_2dtwo( X3, X8 ) ) ) goto L5816; L5803: scdebug_error( c3743, c2981, CONS( X3, EMPTYLIST ) ); L5816: X5 = C_CHAR( STRING_CHAR( X6, X3 ) ); X4 = sc_cons( X5, PAIR_CAR( X1 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X3 ) ), 3 ) ) goto L5817; X3 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X3 ) ) ); goto L5818; L5817: X3 = scrt2__2b_2dtwo( _TSCP( 4 ), X3 ); L5818: X1 = X4; GOBACK( L5731 ); } DEFTSCP( scrt7_fixed_2d_3eclist_v ); DEFCSTRING( t5819, "SCRT7_FIXED->CLIST" ); EXTERNTSCPP( scrt2_remainder, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_remainder_v ); EXTERNTSCPP( scrt2_abs, XAL1( TSCP ) ); EXTERNTSCP( scrt2_abs_v ); TSCP scrt7_fixed_2d_3eclist( o3954 ) TSCP o3954; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5819 ); X1 = EMPTYLIST; X2 = o3954; L5822: if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L5823; X3 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ); goto L5824; L5823: X3 = scrt2_zero_3f( X2 ); L5824: if ( FALSE( X3 ) ) goto L5839; if ( FALSE( X1 ) ) goto L5839; if ( BITAND( BITOR( _S2CINT( o3954 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5832; if ( LT( _S2CINT( o3954 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L5836; POPSTACKTRACE( X1 ); L5832: if ( TRUE( scrt2__3c_2dtwo( o3954, _TSCP( 0 ) ) ) ) goto L5836; POPSTACKTRACE( X1 ); L5839: X8 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X8 ) ) goto L5846; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5846; X7 = _TSCP( REMAINDER( _S2CINT( X2 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L5847; L5846: X7 = scrt2_remainder( X2, _TSCP( 40 ) ); L5847: if ( NEQ( TSCPTAG( X7 ), FIXNUMTAG ) ) goto L5849; if ( LT( _S2CINT( X7 ), 0 ) ) goto L5854; X6 = X7; goto L5855; L5849: X6 = scrt2_abs( X7 ); goto L5855; L5854: X6 = _TSCP( INEGATE( _S2CINT( X7 ) ) ); L5855: X7 = C_FIXED( CHAR_C( _TSCP( 12306 ) ) ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( X6 ) ), 3 ) ) goto L5857; X5 = _TSCP( IPLUS( _S2CINT( X7 ), _S2CINT( X6 ) ) ); goto L5858; L5857: X5 = scrt2__2b_2dtwo( X7, X6 ); L5858: X6 = BOOLEAN( NEQ( TSCPTAG( X5 ), FIXNUMTAG ) ); if ( TRUE( X6 ) ) goto L5864; if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5865; X7 = BOOLEAN( LT( _S2CINT( X5 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L5866; L5865: X7 = scrt2__3c_2dtwo( X5, _TSCP( 0 ) ); L5866: if ( TRUE( X7 ) ) goto L5864; if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L5873; if ( GT( _S2CINT( X5 ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L5864; goto L5880; L5873: if ( FALSE( scrt2__3e_2dtwo( X5, _TSCP( 1020 ) ) ) ) goto L5880; L5864: scdebug_error( c2455, c2456, CONS( X5, EMPTYLIST ) ); L5880: X4 = FIX_CHAR( X5 ); X3 = sc_cons( X4, X1 ); X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L5887; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5887; X2 = C_FIXED( QUOTIENT( _S2CINT( X2 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L5888; L5887: X2 = scrt2_quotient( X2, _TSCP( 40 ) ); L5888: X1 = X3; GOBACK( L5822 ); L5836: POPSTACKTRACE( sc_cons( _TSCP( 11538 ), X1 ) ); } DEFTSCP( scrt7_float_2d_3estring_v ); DEFCSTRING( t5889, "SCRT7_FLOAT->STRING" ); EXTERNTSCPP( sc_formatnumber, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( sc_formatnumber_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); TSCP scrt7_float_2d_3estring( o4050 ) TSCP o4050; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5889 ); X1 = sc_formatnumber( o4050, _TSCP( 12 ), _TSCP( 64 ) ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), STRINGTAG ) ) ) goto L5893; scdebug_error( c3257, c3258, CONS( X1, EMPTYLIST ) ); L5893: X3 = C_FIXED( STRING_LENGTH( X1 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5896; X2 = _TSCP( IDIFFERENCE( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5897; L5896: X2 = scrt2__2d_2dtwo( X3, _TSCP( 4 ) ); L5897: X3 = X2; L5900: if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5902; if ( LT( _S2CINT( X3 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L5906; goto L5907; L5902: if ( FALSE( scrt2__3c_2dtwo( X3, _TSCP( 0 ) ) ) ) goto L5907; L5906: X4 = CONS( c4097, EMPTYLIST ); POPSTACKTRACE( scrt3_string_2dappend( CONS( X1, X4 ) ) ); L5907: if ( EQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L5913; scdebug_error( c3743, c2606, CONS( X3, EMPTYLIST ) ); L5913: X5 = BOOLEAN( LT( _S2CINT( X3 ), 0 ) ); if ( TRUE( X5 ) ) goto L5919; X6 = C_FIXED( STRING_LENGTH( X1 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X6 ) ), 3 ) ) goto L5923; if ( GTE( _S2CINT( X3 ), _S2CINT( X6 ) ) ) goto L5919; goto L5930; L5923: if ( FALSE( scrt2__3e_3d_2dtwo( X3, X6 ) ) ) goto L5930; L5919: scdebug_error( c3743, c2981, CONS( X3, EMPTYLIST ) ); L5930: X4 = C_CHAR( STRING_CHAR( X1, X3 ) ); if ( TRUE( scrt1_memq( X4, c4090 ) ) ) goto L5910; if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5931; X3 = _TSCP( IDIFFERENCE( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L5900 ); L5931: X3 = scrt2__2d_2dtwo( X3, _TSCP( 4 ) ); GOBACK( L5900 ); L5910: POPSTACKTRACE( X1 ); } void scrt2__init(); void scrt1__init(); void scrt4__init(); void scrt3__init(); void scdebug__init(); void scrt6__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt2__init(); scrt1__init(); scrt4__init(); scrt3__init(); scdebug__init(); scrt6__init(); MAXDISPLAY( 1 ); } void scrt7__init() { TSCP X7, X6, X5, X4, X3, X2, X1; static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scrt7 SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t4616, ADR( scrt7_token_2dleft_2dparen_v ), sc_cons( c2131, EMPTYLIST ) ); INITIALIZEVAR( t4617, ADR( scrt7_token_2dright_2dparen_v ), sc_cons( c2133, EMPTYLIST ) ); INITIALIZEVAR( t4618, ADR( scrt7_token_2dquote_v ), sc_cons( c2135, EMPTYLIST ) ); INITIALIZEVAR( t4619, ADR( scrt7_token_2dquasiquote_v ), sc_cons( c2137, EMPTYLIST ) ); INITIALIZEVAR( t4620, ADR( scrt7_2dsplicing_542533dd_v ), sc_cons( c2139, EMPTYLIST ) ); INITIALIZEVAR( t4621, ADR( scrt7_token_2dunquote_v ), sc_cons( c2141, EMPTYLIST ) ); INITIALIZEVAR( t4622, ADR( scrt7_token_2dperiod_v ), sc_cons( c2143, EMPTYLIST ) ); INITIALIZEVAR( t4623, ADR( scrt7_token_2dvector_v ), sc_cons( c2145, EMPTYLIST ) ); INITIALIZEVAR( t4624, ADR( scrt7_token_2drecord_v ), sc_cons( c2147, EMPTYLIST ) ); INITIALIZEVAR( t4625, ADR( scrt7_peek_2dchar_2dport_v ), EMPTYLIST ); INITIALIZEVAR( t4626, ADR( scrt7_read_2dchar_2dport_v ), EMPTYLIST ); INITIALIZEVAR( t4627, ADR( scrt7_ort_2dproc_ae18f815_v ), EMPTYLIST ); INITIALIZEVAR( t4628, ADR( scrt7_next_2dchar_v ), MAKEPROCEDURE( 0, 0, scrt7_next_2dchar, EMPTYLIST ) ); INITIALIZEVAR( t4633, ADR( scrt7_token_v ), MAKEPROCEDURE( 0, 0, scrt7_token, EMPTYLIST ) ); INITIALIZEVAR( t4768, ADR( scrt7_delimiter_3f_v ), MAKEPROCEDURE( 1, 0, scrt7_delimiter_3f, EMPTYLIST ) ); INITIALIZEVAR( t4775, ADR( scrt7_comment_3f_v ), MAKEPROCEDURE( 1, 0, scrt7_comment_3f, EMPTYLIST ) ); INITIALIZEVAR( t4789, ADR( scrt7_read_2dstring_v ), MAKEPROCEDURE( 0, 0, scrt7_read_2dstring, EMPTYLIST ) ); INITIALIZEVAR( t4804, ADR( scrt7_character_v ), MAKEPROCEDURE( 0, 0, scrt7_character, EMPTYLIST ) ); X1 = sc_make_2dvector( _TSCP( 1024 ), CONS( FALSEVALUE, EMPTYLIST ) ); X2 = C_FIXED( CHAR_C( _TSCP( 16658 ) ) ); X3 = C_FIXED( CHAR_C( _TSCP( 23058 ) ) ); L4959: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X3 ) ), 3 ) ) goto L4961; if ( LTE( _S2CINT( X2 ), _S2CINT( X3 ) ) ) goto L4965; goto L4968; L4961: if ( TRUE( scrt2__3e_2dtwo( X2, X3 ) ) ) goto L4968; L4965: X5 = BOOLEAN( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ); if ( TRUE( X5 ) ) goto L4975; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4976; X6 = BOOLEAN( LT( _S2CINT( X2 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4977; L4976: X6 = scrt2__3c_2dtwo( X2, _TSCP( 0 ) ); L4977: if ( TRUE( X6 ) ) goto L4975; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4984; if ( GT( _S2CINT( X2 ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4975; goto L4991; L4984: if ( FALSE( scrt2__3e_2dtwo( X2, _TSCP( 1020 ) ) ) ) goto L4991; L4975: scdebug_error( c2455, c2456, CONS( X2, EMPTYLIST ) ); L4991: X4 = FIX_CHAR( X2 ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L4993; scdebug_error( c2602, c2603, CONS( X1, EMPTYLIST ) ); L4993: if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L4995; scdebug_error( c2602, c2606, CONS( X2, EMPTYLIST ) ); L4995: if ( LT( _S2CUINT( FIXED_C( X2 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L4997; scdebug_error( c2602, c2610, CONS( X2, EMPTYLIST ) ); L4997: SETGEN( VECTOR_ELEMENT( X1, X2 ), X4 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 128 ) ) ), 3 ) ) goto L4999; X4 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 128 ) ) ) ); goto L5000; L4999: X4 = scrt2__2b_2dtwo( X2, _TSCP( 128 ) ); L5000: X6 = BOOLEAN( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ); if ( TRUE( X6 ) ) goto L5006; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L5007; X7 = BOOLEAN( LT( _S2CINT( X2 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L5008; L5007: X7 = scrt2__3c_2dtwo( X2, _TSCP( 0 ) ); L5008: if ( TRUE( X7 ) ) goto L5006; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L5015; if ( GT( _S2CINT( X2 ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L5006; goto L5022; L5015: if ( FALSE( scrt2__3e_2dtwo( X2, _TSCP( 1020 ) ) ) ) goto L5022; L5006: scdebug_error( c2455, c2456, CONS( X2, EMPTYLIST ) ); L5022: X5 = FIX_CHAR( X2 ); if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L5024; scdebug_error( c2602, c2606, CONS( X4, EMPTYLIST ) ); L5024: if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L5026; scdebug_error( c2602, c2610, CONS( X4, EMPTYLIST ) ); L5026: SETGEN( VECTOR_ELEMENT( X1, X4 ), X5 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L5028; X4 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L5029; L5028: X4 = scrt2__2b_2dtwo( X2, _TSCP( 4 ) ); L5029: X2 = X4; GOBACK( L4959 ); L4968: X2 = c2724; L5031: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L5032; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5036; scrt1__24__car_2derror( X2 ); L5036: X3 = PAIR_CAR( X2 ); X4 = C_FIXED( CHAR_C( X3 ) ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L5040; scdebug_error( c2602, c2603, CONS( X1, EMPTYLIST ) ); L5040: if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L5042; scdebug_error( c2602, c2606, CONS( X4, EMPTYLIST ) ); L5042: if ( LT( _S2CUINT( FIXED_C( X4 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L5044; scdebug_error( c2602, c2610, CONS( X4, EMPTYLIST ) ); L5044: SETGEN( VECTOR_ELEMENT( X1, X4 ), X3 ); X2 = PAIR_CDR( X2 ); GOBACK( L5031 ); L5032: X2 = C_FIXED( CHAR_C( _TSCP( 23570 ) ) ); if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), VECTORTAG ) ) ) goto L5048; scdebug_error( c2602, c2603, CONS( X1, EMPTYLIST ) ); L5048: if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L5050; scdebug_error( c2602, c2606, CONS( X2, EMPTYLIST ) ); L5050: if ( LT( _S2CUINT( FIXED_C( X2 ) ), _S2CUINT( VECTOR_LENGTH( X1 ) ) ) ) goto L5052; scdebug_error( c2602, c2610, CONS( X2, EMPTYLIST ) ); L5052: SETGEN( VECTOR_ELEMENT( X1, X2 ), TRUEVALUE ); INITIALIZEVAR( t4956, ADR( scrt7_idtable_v ), X1 ); INITIALIZEVAR( t5054, ADR( scrt7_identifier_v ), MAKEPROCEDURE( 1, 0, scrt7_identifier, EMPTYLIST ) ); INITIALIZEVAR( t5077, ADR( scrt7_maxintf_v ), DOUBLE_TSCP( MAXTSCPINTF ) ); INITIALIZEVAR( t5078, ADR( scrt7_minintf_v ), DOUBLE_TSCP( MINTSCPINTF ) ); INITIALIZEVAR( t5079, ADR( scrt7_number_v ), MAKEPROCEDURE( 3, 0, scrt7_number, EMPTYLIST ) ); X3 = scrt7_maxintf_v; if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), DOUBLEFLOATTAG ) ) ) goto L5227; scdebug_error( c2975, c2976, CONS( X3, EMPTYLIST ) ); L5227: X4 = BOOLEAN( LT( FLOAT_VALUE( X3 ), MINTSCPINTF ) ); if ( TRUE( X4 ) ) goto L5233; if ( LTE( FLOAT_VALUE( X3 ), MAXTSCPINTF ) ) goto L5236; L5233: scdebug_error( c2975, c2981, CONS( X3, EMPTYLIST ) ); L5236: X2 = FLT_FIX( X3 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 60 ) ) ), 3 ) ) goto L5238; X1 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 60 ) ) ) ); goto L5239; L5238: X1 = scrt2__2d_2dtwo( X2, _TSCP( 60 ) ); L5239: X3 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 64 ) ) ), 3 ) ) ); if ( FALSE( X3 ) ) goto L5247; if ( EQ( _S2CUINT( _TSCP( 64 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L5247; X2 = C_FIXED( QUOTIENT( _S2CINT( X1 ), _S2CINT( _TSCP( 64 ) ) ) ); goto L5248; L5247: X2 = scrt2_quotient( X1, _TSCP( 64 ) ); L5248: INITIALIZEVAR( t5225, ADR( scrt7_max_2daccv_2dvalue_v ), X2 ); INITIALIZEVAR( t5249, ADR( scrt7_accv_v ), MAKEPROCEDURE( 3, 0, scrt7_accv, EMPTYLIST ) ); INITIALIZEVAR( t5298, ADR( scrt7_read_2ddatum_v ), MAKEPROCEDURE( 1, 0, scrt7_read_2ddatum, EMPTYLIST ) ); INITIALIZEVAR( t5323, ADR( scrt7_datum_v ), MAKEPROCEDURE( 1, 0, scrt7_datum, EMPTYLIST ) ); INITIALIZEVAR( t5345, ADR( scrt7_datum_2dlist_v ), MAKEPROCEDURE( 1, 0, scrt7_datum_2dlist, EMPTYLIST ) ); INITIALIZEVAR( t5354, ADR( scrt7_datum_2dvector_v ), MAKEPROCEDURE( 1, 0, scrt7_datum_2dvector, EMPTYLIST ) ); INITIALIZEVAR( t5358, ADR( scrt7_write_2dtoken_2dport_v ), EMPTYLIST ); INITIALIZEVAR( t5359, ADR( scrt7_write_2dlength_2dport_v ), FALSEVALUE ); INITIALIZEVAR( t5360, ADR( scrt7_write_2dwidth_2dport_v ), FALSEVALUE ); INITIALIZEVAR( t5361, ADR( scrt7_ort_2dproc_61a60f78_v ), FALSEVALUE ); INITIALIZEVAR( t5362, ADR( scrt7_write_2fdisplay_v ), MAKEPROCEDURE( 3, 0, scrt7_write_2fdisplay, EMPTYLIST ) ); INITIALIZEVAR( t5370, ADR( scrt7_write_2fdisplay2_v ), MAKEPROCEDURE( 6, 0, scrt7_write_2fdisplay2, EMPTYLIST ) ); INITIALIZEVAR( t5572, ADR( scrt7_write_2fdisplay_2dlist_v ), MAKEPROCEDURE( 6, 0, scrt7_write_2fdisplay_2dlist, EMPTYLIST ) ); INITIALIZEVAR( t5617, ADR( scrt7_readable_2dchar_v ), MAKEPROCEDURE( 1, 0, scrt7_readable_2dchar, EMPTYLIST ) ); INITIALIZEVAR( t5642, ADR( scrt7_readable_2dstring_v ), MAKEPROCEDURE( 1, 0, scrt7_readable_2dstring, EMPTYLIST ) ); INITIALIZEVAR( t5722, ADR( scrt7_readable_2dsymbol_v ), MAKEPROCEDURE( 1, 0, scrt7_readable_2dsymbol, EMPTYLIST ) ); INITIALIZEVAR( t5819, ADR( scrt7_fixed_2d_3eclist_v ), MAKEPROCEDURE( 1, 0, scrt7_fixed_2d_3eclist, EMPTYLIST ) ); INITIALIZEVAR( t5889, ADR( scrt7_float_2d_3estring_v ), MAKEPROCEDURE( 1, 0, scrt7_float_2d_3estring, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scrt/scrt7.sc000066400000000000000000000442671203736146400161620ustar00rootroot00000000000000;;; SCHEME->C Runtime Library ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module scrt7 (top-level)) (include "repdef.sc") ;;; 7.1.1. Lexical Structure ;;; The following global values define tokens used to denote special symbols ;;; which are returned by TOKEN. They must be computed at run-time as they ;;; cannot use READCONSTANT. (define TOKEN-LEFT-PAREN (cons 'left-paren '())) (define TOKEN-RIGHT-PAREN (cons 'right-paren '())) (define TOKEN-QUOTE (cons 'quote '())) (define TOKEN-QUASIQUOTE (cons 'quasiquote '())) (define TOKEN-UNQUOTE-SPLICING (cons 'unquote-splicing '())) (define TOKEN-UNQUOTE (cons 'unquote '())) (define TOKEN-PERIOD (cons 'period '())) (define TOKEN-VECTOR (cons 'vector '())) (define TOKEN-RECORD (cons '%record '())) ;;; In order to read characters faster from the current input port, the ;;; methods are cached here on entry to this module by READ-DATUM. (define PEEK-CHAR-PORT '()) ;;; Method to inspect a char (define READ-CHAR-PORT '()) ;;; Method to read a char (define READ-DATUM-PORT-PROC '()) ;;; Procedure representing the port (define (NEXT-CHAR) (let ((char (read-char-port))) (if (eof-object? char) (error 'READ "Unexpected end-of-file") char))) (define-in-line (CHAR-WHITESPACE? char) ((lap (char) (BOOLEAN (OR (EQ char (C_CHAR "040")) (AND (GTE char (C_CHAR "011")) (LTE char (C_CHAR "015")))))) char)) (define-in-line (CHAR->INTEGER c) ((lap (c) (C_FIXED (CHAR_C c))) c)) (define-in-line (SPECIAL-INITIAL? char) (memq char '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^))) (define-in-line (SPECIAL-SUBSEQUENT? char) (memq char '(#\. #\+ #\-))) (define (TOKEN) (let ((char (next-char))) (cond ((or (char-whitespace? char) (comment? char)) (token)) ((char-alphabetic? char) (identifier (char-upcase char))) ((char=? char #\") (read-string)) ((char=? char #\() token-left-paren) ((char=? char #\)) token-right-paren) ((char=? char #\') token-quote) ((char=? char #\`) token-quasiquote) ((char=? char #\,) (if (char=? (peek-char-port) #\@) (begin (next-char) token-unquote-splicing) token-unquote)) ((char=? char #\.) (cond ((char-numeric? (peek-char-port)) (number char 10 1)) ((char-whitespace? (peek-char-port)) token-period) (else (identifier char)))) ((char=? char #\#) (set! char (char-upcase (next-char))) (cond ((char=? char #\() token-vector) ((char=? char #\\ ) (character)) ((char=? char #\T) #t) ((char=? char #\F) #f) ((char=? char #\B) (number (next-char) 2 1)) ((char=? char #\O) (number (next-char) 8 1)) ((char=? char #\D) (number (next-char) 10 1)) ((char=? char #\X) (number (next-char) 16 1)) ((and %record-prefix-char (char=? char %record-prefix-char)) token-record) (else (error 'READ "Invalid # option: ~a" char)))) ((special-initial? char) (identifier char)) ((char=? char #\\ ) (identifier (next-char))) ((or (eq? char '#\+) (eq? char #\-)) (let ((next (peek-char-port))) (if (or (char-numeric? next) (memq next '(#\# #\.))) (number char 0 0) (identifier char)))) (else (number char 0 0))))) (define (DELIMITER? char) (or (eof-object? char) (char-whitespace? char) (memq char '(#\( #\) #\" #\;)))) (define (COMMENT? char) (if (char=? char #\;) (do () ((char=? (next-char) #\newline) #t)) #f)) ;;; When a " is detected, this function is called to read the rest of the ;;; string. (define (READ-STRING) (do ((cl '() (cons char cl)) (char (next-char) (next-char))) ((char=? char #\") (list->string (reverse cl))) (if (char=? #\\ char) (set! char (next-char))))) ;;; When a #\ is detected, this function is called to read the rest of the ;;; character constant. (define (CHARACTER) (let ((char (next-char))) (if (and (char-alphabetic? char) (not (delimiter? (peek-char-port)))) (let ((id (identifier (char-upcase char)))) (case id ((tab) (integer->char #o11)) ((newline) (integer->char #o12)) ((linefeed) (integer->char #o12)) ((formfeed) (integer->char #o14)) ((return) (integer->char #o15)) ((space) (integer->char #o40)) (else (error 'READ "Unrecognized CHARACTER NAME: ~s" id)))) char))) ;;; When the start of an identifier is detected, the following function is ;;; called to finish reading it. It is table driven from the IDTABLE which ;;; contains an entry for each possible character. The entries are: ;;; ;;; #f character is not part of the identifier. ;;; newchar character is part of the identifier and "newchar" is the ;;; upshifted value. ;;; #t character is \ so the following character is taken as is. (define IDTABLE (let ((tab (make-vector 256 #f))) (do ((i (char->integer #\A) (+ i 1)) (last (char->integer #\Z))) ((> i last)) (vector-set! tab i (integer->char i)) (vector-set! tab (+ i 32) (integer->char i))) (for-each (lambda (c) (vector-set! tab (char->integer c) c)) '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 ; Numeric characters. #\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^ ; Special initial. #\. #\+ #\-)) ; Special subsequent. (vector-set! tab (char->integer #\\) #t) tab)) (define (IDENTIFIER firstchar) (let loop ((cl (list firstchar))) (let* ((pc (peek-char-port)) (tc (and (char? pc) (vector-ref idtable (char->integer pc))))) (cond ((char? tc) (read-char-port) (loop (cons tc cl))) (tc (read-char-port) (loop (cons (next-char) cl))) (else (string->symbol (list->string (reverse cl)))))))) ;;; Integer bounds expressed a floating point values. (define MAXINTF ((lap () (DOUBLE_TSCP MAXTSCPINTF)))) (define MININTF ((lap () (DOUBLE_TSCP MINTSCPINTF)))) ;;; When the start of a number is detected, the following function is called ;;; to finish reading it. (define (NUMBER firstchar base sign) (if (zero? sign) (cond ((char=? firstchar #\+) (set! sign 1) (set! firstchar (next-char))) ((char=? firstchar #\-) (set! sign -1) (set! firstchar (next-char))) (else (set! sign 1)))) (if (zero? base) (cond ((char=? firstchar #\#) (let ((char (next-char))) (case char ((#\B #\b) (set! base 2)) ((#\O #\o) (set! base 8)) ((#\D #\d) (set! base 10)) ((#\X #\x) (set! base 16)) (else (error 'READ "Invalid number base: ~a" char)))) (set! firstchar (next-char))) (else (set! base 10)))) (do ((cl (list firstchar) (cons char cl)) (char (peek-char-port) (peek-char-port)) (bv (case firstchar ((#\0) 0) ((#\1) 1) (else -1)) (case char ((#\0) (* bv 2)) (( #\1) (+ (* bv 2) 1)) (else -1))) (iv (accv 0 base firstchar) (accv iv base char)) (maxchar (char->integer firstchar) (max maxchar (char->integer char))) (fpt (eq? firstchar #\.) (or fpt (eq? char #\.) (and (not (= base 16)) (or (eq? char #\e) (eq? char #\E)))))) ((delimiter? char) (if (and (>= iv 0) (not fpt)) (let ((siv (* sign iv))) (if (or (fixed? siv) (> siv maxintf) (< siv minintf)) siv (float->fixed siv))) (let ((cl (list->string (reverse cl)))) (if (not fpt) (error 'READ "Illegal digit(s) in integer: ~a" cl)) (if (not (eq? base 10)) (error 'READ "Floating point numbers must be base 10: ~a" cl)) (let ((value (readnumber cl 0))) (if value (if (eq? sign -1) (- value) value) (error 'READ "Illegal floating point number: ~a" cl)))))) (next-char))) (define MAX-ACCV-VALUE (quotient (- (float->fixed maxintf) 15) 16)) (define (ACCV value base char) (let ((cv (assq char '((#\0 0) (#\1 1) (#\2 2) (#\3 3) (#\4 4) (#\5 5) (#\6 6) (#\7 7) (#\8 8) (#\9 9) (#\a 10) (#\b 11) (#\c 12) (#\d 13) (#\e 14) (#\f 15) (#\A 10) (#\B 11) (#\C 12) (#\D 13) (#\E 14) (#\F 15))))) (cond ((or (eq? value -1) (not cv) (>= (cadr cv) base)) -1) ((and (fixed? value) (> value max-accv-value)) (accv (fixed->float value) base char)) (else (+ (* base value) (cadr cv)))))) ;;; 7.1.2. External Representations (define (READ-DATUM port-proc) (let ((save-peek-char-port peek-char-port) (save-read-char-port read-char-port) (save-read-datum-port-proc read-datum-port-proc)) (set! peek-char-port (port-proc 'peek-char)) (set! read-char-port (port-proc 'read-char)) (set! read-datum-port-proc port-proc) (let ((result (let loop ((char (peek-char-port))) (cond ((eof-object? char) (read-char-port)) ((char-whitespace? char) (read-char-port) (loop (peek-char-port))) ((char=? char #\;) (do () ((char=? (next-char) #\newline))) (loop (peek-char-port))) (else (datum (token))))))) (set! read-datum-port-proc save-read-datum-port-proc) (set! peek-char-port save-peek-char-port) (set! read-char-port save-read-char-port) result))) (define (DATUM current-token) (cond ((eq? current-token token-left-paren) (datum-list (token))) ((eq? current-token token-vector) (list->vector (datum-vector (token)))) ((eq? current-token token-quote) (list 'quote (datum (token)))) ((eq? current-token token-quasiquote) (list 'quasiquote (datum (token)))) ((eq? current-token token-unquote) (list 'unquote (datum (token)))) ((eq? current-token token-unquote-splicing) (list 'unquote-splicing (datum (token)))) ((not (pair? current-token)) current-token) ((eq? current-token token-record) (%record-read (cons 'port read-datum-port-proc))) (else (error 'READ "Poorly formed DATUM: ~s" current-token)))) (define (DATUM-LIST current-token) (cond ((eq? current-token token-right-paren) '()) ((eq? current-token token-period) (let ((result (datum (token)))) (if (eq? (token) token-right-paren) result (error 'READ "Poorly formed LIST")))) (else (cons (datum current-token) (datum-list (token)))))) (define (DATUM-VECTOR current-token) (cond ((eq? current-token token-right-paren) '()) (else (cons (datum current-token) (datum-vector (token)))))) ;;; Method for printing a token, the write-length, and the write width ;;; are cached here. (define WRITE-TOKEN-PORT '()) (define WRITE-LENGTH-PORT #f) (define WRITE-WIDTH-PORT #f) (define WRITE/DISPLAY-PORT-PROC #f) (define (WRITE/DISPLAY obj readable port-proc) (let ((save-write-token-port write-token-port) (save-write-length-port write-length-port) (save-write-width-port write-width-port) (save-write/display-port-proc write/display-port-proc)) (set! write-token-port (port-proc 'write-token)) (set! write-length-port ((port-proc 'write-length))) (set! write-width-port ((port-proc 'write-width))) (set! write/display-port-proc port-proc) (let ((result (write/display2 obj readable (if ((port-proc 'write-pretty)) 0 #f) ((port-proc 'write-level)) write-length-port (if ((port-proc 'write-circle)) '() #f)))) (set! write-token-port save-write-token-port) (set! write-length-port save-write-length-port) (set! write-width-port save-write-width-port) (set! write/display-port-proc save-write/display-port-proc) result))) (define (WRITE/DISPLAY2 obj readable indent wlevel wlength circle) (define (WRITE/DISPLAY-SIZE obj) (let ((save-write-token-port write-token-port) (size 0)) (define (COUNT-CHAR x) (set! size (+ (or (and (string? x) (string-length x)) (and (pair? x) (length x)) 1) size))) (set! write-token-port count-char) (write/display2 obj readable #f (or wlevel 50) (or wlength 50) circle) (set! write-token-port save-write-token-port) size)) (cond ((and (eq? wlevel 0) (or (pair? obj) (vector? obj) (%record? obj))) (write-token-port "#")) ((and (not (eq? circle #f)) (or (pair? obj) (vector? obj) (%record? obj)) (memq obj circle)) (write-token-port "...")) ((pair? obj) (let ((qq (and (pair? (cdr obj)) (null? (cddr obj)) (assq (car obj) '((quote "'") (quasiquote "`") (unquote ",") (unquote-splicing ",@")))))) (cond ((eq? write-length-port 0) (write-token-port "(...)")) ((and qq readable) (write-token-port (cadr qq)) (write/display2 (cadr obj) readable indent wlevel wlength circle)) ((and indent (<= (+ indent (write/display-size obj)) write-width-port)) (write/display2 obj readable #f wlevel wlength circle)) (else (write-token-port "(") (write/display2 (car obj) readable (and indent (+ indent 1)) (and wlevel (- wlevel 1)) (and write-length-port (- write-length-port 1)) (and (not (eq? circle #f)) (cons obj circle))) (write/display-list (cdr obj) readable (and indent (+ indent 1)) (and wlevel (- wlevel 1)) (and write-length-port (- write-length-port 1)) (and (not (eq? circle #f)) (cons obj circle))))))) ((symbol? obj) (if readable (if (memq obj '(+ - )) (write-token-port (symbol->string obj)) (write-token-port (readable-symbol obj))) (write-token-port (symbol->string obj)))) ((fixed? obj) (write-token-port (fixed->clist obj))) ((string? obj) (write-token-port (if readable (readable-string obj) obj))) ((char? obj) (write-token-port (if readable (readable-char obj) obj))) ((or (string? obj) (char? obj)) (write-token-port obj)) ((vector? obj) (write-token-port "#") (write/display2 (vector->list obj) readable (and indent (+ indent 1)) wlevel wlength (and (not (eq? circle #f)) (cons obj circle)))) ((float? obj) (write-token-port (float->string obj))) ((eq? obj #t) (write-token-port "#T")) ((eq? obj #f) (write-token-port "#F")) ((null? obj) (write-token-port "()")) ((eof-object? obj) (write-token-port "#*END-OF-FILE*")) ((eq? obj undefined) (write-token-port "#*UNDEFINED*")) ((procedure? obj) (write-token-port "#*PROCEDURE*")) ((%record? obj) (let* ((method (%record-lookup-method obj (if readable '%to-write '%to-display))) (data (method obj (cons 'port write/display-port-proc) indent wlevel wlength circle))) (if (pair? data) (write/display2 (car data) readable (and indent (+ indent 2)) wlevel wlength (and (not (eq? circle #f)) (cons obj circle)))))) (else (write-token-port "#*??????*")))) (define (WRITE/DISPLAY-LIST obj readable indent wlevel wlength circle) (define (PRINT x) (if indent (begin (write-token-port #\newline) (let loop ((i indent)) (unless (zero? i) (write-token-port #\space) (loop (- i 1)))) (write-token-port (substring x 1 (string-length x)))) (write-token-port x))) (cond ((null? obj) (write-token-port ")")) ((eq? wlength 0) (print " ...)")) ((and (not (eq? circle #f)) (memq obj circle)) (print " ...)")) ((not (pair? obj)) (print " . ") (write/display2 obj readable indent wlevel wlength circle) (write-token-port ")")) (else (print " ") (write/display2 (car obj) readable indent wlevel wlength circle) (write/display-list (cdr obj) readable indent wlevel (and wlength (- wlength 1)) circle)))) (define (READABLE-CHAR obj) (if (and (char>? obj #\space) (char<=? obj #\~)) (list->string (list #\# #\\ obj)) (let ((spec (assoc obj '((#\tab "#\\tab") (#\newline "#\\newline") (#\linefeed "#\\linefeed") (#\formfeed "#\\formfeed") (#\return "#\\return") (#\space "#\\space"))))) (if spec (cadr spec) "#\\???")))) (define (READABLE-STRING obj) (do ((cl '(#\") (cons (string-ref obj i) cl)) (len (string-length obj)) (i 0 (+ i 1))) ((= len i) (reverse (cons #\" cl))) (if (and (or (eq? (string-ref obj i) #\\ ) (eq? (string-ref obj i) #\" ))) (set! cl (cons #\\ cl))))) (define (READABLE-SYMBOL obj) (set! obj (symbol->string obj)) (do ((cl '() (cons (string-ref obj i) cl)) (len (string-length obj)) (i 0 (+ 1 i))) ((= i len) (reverse cl)) (let ((c (string-ref obj i))) (cond ((and (not (and (char-alphabetic? c) (char-upper-case? c))) (not (special-initial? c)) (not (special-subsequent? c)) (not (char-numeric? c))) (set! cl (cons #\\ cl))) ((and (zero? i) (not (char-alphabetic? c)) (not (special-initial? c))) (set! cl (cons #\\ cl))))))) (define (FIXED->CLIST obj) (do ((cl '() (cons (integer->char (+ (char->integer #\0) (abs (remainder number 10)))) cl)) (number obj (quotient number 10))) ((and (zero? number) cl) (if (< obj 0) (cons #\- cl) cl)))) (define (FLOAT->STRING obj) (let ((buffer (formatnumber obj 3 16))) (let loop ((i (- (string-length buffer) 1))) (cond ((< i 0) (string-append buffer ".")) ((memq (string-ref buffer i) '(#\. #\e)) buffer) (else (loop (- i 1))))))) scheme2c-2012.10.14/scrt/scrtuser.c000066400000000000000000000007411203736146400165740ustar00rootroot00000000000000 /* SCHEME->C */ #include void scrtuser__init(); static void init_constants() { } static void init_modules( compiler_version ) char *compiler_version; { MAXDISPLAY( 0 ); } void scrtuser__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(scrtuser SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); return; } scheme2c-2012.10.14/scrt/scrtuser.sc000066400000000000000000000030501203736146400167530ustar00rootroot00000000000000;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. ;;; To extend the basic Scheme->C runtime system, replace this module with ;;; one also named scrtuser, whose MODULE form includes a WITH clause that ;;; lists all user modules in the order that they must be initialized. ;;; ;;; N.B. Modules that are implicity referenced because of a DEFINE-EXTERNAL ;;; declaration need not be listed. Those modules are automatically ;;; initialized. (module scrtuser) scheme2c-2012.10.14/scsc/000077500000000000000000000000001203736146400145345ustar00rootroot00000000000000scheme2c-2012.10.14/scsc/README000066400000000000000000000001011203736146400154040ustar00rootroot00000000000000Source directory for Scheme->C compiler for all implementations. scheme2c-2012.10.14/scsc/callcode.c000066400000000000000000001702301203736146400164510ustar00rootroot00000000000000 /* SCHEME->C */ #include void callcode__init(); DEFSTATICTSCP( lambda_2dbody_2dgenc_v ); DEFSTATICTSCP( report_2derror_v ); DEFSTATICTSCP( reserve_2ddisplay_v ); DEFSTATICTSCP( update_2dcondition_2dinfo_v ); DEFSTATICTSCP( report_2dwarning_v ); DEFSTATICTSCP( list_2dhead_v ); DEFCSTRING( t3308, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c3134 ); DEFSTATICTSCP( c3133 ); DEFSTATICTSCP( c3095 ); DEFSTATICTSCP( c3094 ); DEFSTATICTSCP( c3093 ); DEFSTATICTSCP( c3076 ); DEFSTATICTSCP( c3070 ); DEFSTATICTSCP( t3309 ); DEFSTATICTSCP( c3067 ); DEFSTATICTSCP( c3012 ); DEFSTATICTSCP( c3009 ); DEFSTATICTSCP( c2997 ); DEFSTATICTSCP( t3310 ); DEFSTATICTSCP( c2996 ); DEFSTATICTSCP( t3311 ); DEFSTATICTSCP( t3312 ); DEFSTATICTSCP( c2995 ); DEFSTATICTSCP( t3313 ); DEFSTATICTSCP( t3314 ); DEFSTATICTSCP( c2994 ); DEFSTATICTSCP( t3315 ); DEFSTATICTSCP( c2993 ); DEFSTATICTSCP( t3316 ); DEFSTATICTSCP( t3317 ); DEFSTATICTSCP( c2992 ); DEFSTATICTSCP( c2991 ); DEFSTATICTSCP( c2990 ); DEFSTATICTSCP( t3318 ); DEFSTATICTSCP( t3319 ); DEFCSTRING( t3320, "C procedure does not return a value:" ); DEFSTATICTSCP( c2989 ); DEFSTATICTSCP( c2986 ); DEFSTATICTSCP( t3321 ); DEFSTATICTSCP( c2985 ); DEFSTATICTSCP( c2975 ); DEFSTATICTSCP( t3322 ); DEFSTATICTSCP( t3323 ); DEFSTATICTSCP( t3324 ); DEFSTATICTSCP( c2974 ); DEFSTATICTSCP( t3325 ); DEFSTATICTSCP( t3326 ); DEFSTATICTSCP( t3327 ); DEFSTATICTSCP( c2945 ); DEFSTATICTSCP( c2932 ); DEFSTATICTSCP( c2919 ); DEFSTATICTSCP( c2914 ); DEFSTATICTSCP( c2909 ); DEFSTATICTSCP( c2904 ); DEFSTATICTSCP( c2899 ); DEFSTATICTSCP( c2895 ); DEFSTATICTSCP( c2891 ); DEFSTATICTSCP( t3328 ); DEFSTATICTSCP( t3329 ); DEFSTATICTSCP( c2890 ); DEFSTATICTSCP( c2886 ); DEFSTATICTSCP( c2882 ); DEFSTATICTSCP( c2878 ); DEFSTATICTSCP( c2874 ); DEFSTATICTSCP( c2870 ); DEFSTATICTSCP( c2866 ); DEFCSTRING( t3330, "Incorrect number of arguments for LAP construct" ); DEFSTATICTSCP( c2703 ); DEFSTATICTSCP( c2595 ); DEFCSTRING( t3331, "Incorrect number of arguments for" ); DEFSTATICTSCP( c2531 ); DEFSTATICTSCP( c2529 ); DEFSTATICTSCP( c2490 ); DEFCSTRING( t3332, "EMPTYLIST" ); DEFSTATICTSCP( c2484 ); DEFSTATICTSCP( c2478 ); DEFSTATICTSCP( c2477 ); DEFSTATICTSCP( c2463 ); DEFSTATICTSCP( c2403 ); DEFCSTRING( t3333, "DISPLAY" ); DEFSTATICTSCP( c2394 ); DEFSTATICTSCP( c2388 ); DEFSTATICTSCP( c2383 ); DEFCSTRING( t3334, "Incorrect number of arguments for lambda" ); DEFSTATICTSCP( c2378 ); DEFSTATICTSCP( c2366 ); DEFSTATICTSCP( c2361 ); DEFSTATICTSCP( c2275 ); DEFSTATICTSCP( c2205 ); DEFSTATICTSCP( c2184 ); DEFSTATICTSCP( c2171 ); DEFSTATICTSCP( c2164 ); DEFSTATICTSCP( c2152 ); DEFSTATICTSCP( c2151 ); DEFSTATICTSCP( c2134 ); DEFSTATICTSCP( c2118 ); static void init_constants() { TSCP X1; lambda_2dbody_2dgenc_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA-BODY-\ GENC" ) ); CONSTANTEXP( ADR( lambda_2dbody_2dgenc_v ) ); report_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-ERROR" ) ); CONSTANTEXP( ADR( report_2derror_v ) ); reserve_2ddisplay_v = STRINGTOSYMBOL( CSTRING_TSCP( "RESERVE-DISPLAY\ " ) ); CONSTANTEXP( ADR( reserve_2ddisplay_v ) ); update_2dcondition_2dinfo_v = STRINGTOSYMBOL( CSTRING_TSCP( "UPDATE-\ CONDITION-INFO" ) ); CONSTANTEXP( ADR( update_2dcondition_2dinfo_v ) ); report_2dwarning_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-WARNING" ) ); CONSTANTEXP( ADR( report_2dwarning_v ) ); list_2dhead_v = STRINGTOSYMBOL( CSTRING_TSCP( "LIST-HEAD" ) ); CONSTANTEXP( ADR( list_2dhead_v ) ); c3134 = CSTRING_TSCP( t3308 ); CONSTANTEXP( ADR( c3134 ) ); c3133 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c3133 ) ); c3095 = STRINGTOSYMBOL( CSTRING_TSCP( "PROCEDURE_CODE" ) ); CONSTANTEXP( ADR( c3095 ) ); c3094 = STRINGTOSYMBOL( CSTRING_TSCP( "VIA" ) ); CONSTANTEXP( ADR( c3094 ) ); c3093 = STRINGTOSYMBOL( CSTRING_TSCP( "UNKNOWNCALL" ) ); CONSTANTEXP( ADR( c3093 ) ); c3076 = STRINGTOSYMBOL( CSTRING_TSCP( "PROCEDURE_CLOSURE" ) ); CONSTANTEXP( ADR( c3076 ) ); c3070 = EMPTYLIST; t3309 = STRINGTOSYMBOL( CSTRING_TSCP( "TOS" ) ); c3070 = CONS( t3309, c3070 ); CONSTANTEXP( ADR( c3070 ) ); c3067 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); CONSTANTEXP( ADR( c3067 ) ); c3012 = STRINGTOSYMBOL( CSTRING_TSCP( "OPTVARS" ) ); CONSTANTEXP( ADR( c3012 ) ); c3009 = STRINGTOSYMBOL( CSTRING_TSCP( "PRINTNAME" ) ); CONSTANTEXP( ADR( c3009 ) ); c2997 = EMPTYLIST; c2997 = CONS( t3309, c2997 ); t3310 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR_TSCP" ) ); c2997 = CONS( t3310, c2997 ); CONSTANTEXP( ADR( c2997 ) ); c2996 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3309, X1 ); t3311 = STRINGTOSYMBOL( CSTRING_TSCP( "_S2CINT" ) ); X1 = CONS( t3311, X1 ); c2996 = CONS( X1, c2996 ); t3312 = STRINGTOSYMBOL( CSTRING_TSCP( "S2CINT_TSCP" ) ); c2996 = CONS( t3312, c2996 ); CONSTANTEXP( ADR( c2996 ) ); c2995 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3309, X1 ); t3313 = STRINGTOSYMBOL( CSTRING_TSCP( "_S2CUINT" ) ); X1 = CONS( t3313, X1 ); c2995 = CONS( X1, c2995 ); t3314 = STRINGTOSYMBOL( CSTRING_TSCP( "S2CUINT_TSCP" ) ); c2995 = CONS( t3314, c2995 ); CONSTANTEXP( ADR( c2995 ) ); c2994 = EMPTYLIST; c2994 = CONS( t3309, c2994 ); t3315 = STRINGTOSYMBOL( CSTRING_TSCP( "POINTER_TSCP" ) ); c2994 = CONS( t3315, c2994 ); CONSTANTEXP( ADR( c2994 ) ); c2993 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3309, X1 ); t3316 = STRINGTOSYMBOL( CSTRING_TSCP( "CDOUBLE" ) ); X1 = CONS( t3316, X1 ); c2993 = CONS( X1, c2993 ); t3317 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUBLE_TSCP" ) ); c2993 = CONS( t3317, c2993 ); CONSTANTEXP( ADR( c2993 ) ); c2992 = EMPTYLIST; c2992 = CONS( t3309, c2992 ); c2992 = CONS( t3317, c2992 ); CONSTANTEXP( ADR( c2992 ) ); c2991 = STRINGTOSYMBOL( CSTRING_TSCP( "FALSEVALUE" ) ); CONSTANTEXP( ADR( c2991 ) ); c2990 = EMPTYLIST; c2990 = CONS( t3309, c2990 ); t3318 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-VALUE" ) ); c2990 = CONS( t3318, c2990 ); t3319 = STRINGTOSYMBOL( CSTRING_TSCP( "SET" ) ); c2990 = CONS( t3319, c2990 ); CONSTANTEXP( ADR( c2990 ) ); c2989 = CSTRING_TSCP( t3320 ); CONSTANTEXP( ADR( c2989 ) ); c2986 = EMPTYLIST; c2986 = CONS( t3309, c2986 ); t3321 = STRINGTOSYMBOL( CSTRING_TSCP( "_TSCP" ) ); c2986 = CONS( t3321, c2986 ); CONSTANTEXP( ADR( c2986 ) ); c2985 = STRINGTOSYMBOL( CSTRING_TSCP( "VOID" ) ); CONSTANTEXP( ADR( c2985 ) ); c2975 = EMPTYLIST; t3322 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGUNSIGNED" ) ); c2975 = CONS( t3322, c2975 ); t3323 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTUNSIGNED" ) ); c2975 = CONS( t3323, c2975 ); t3324 = STRINGTOSYMBOL( CSTRING_TSCP( "UNSIGNED" ) ); c2975 = CONS( t3324, c2975 ); CONSTANTEXP( ADR( c2975 ) ); c2974 = EMPTYLIST; t3325 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGINT" ) ); c2974 = CONS( t3325, c2974 ); t3326 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTINT" ) ); c2974 = CONS( t3326, c2974 ); t3327 = STRINGTOSYMBOL( CSTRING_TSCP( "INT" ) ); c2974 = CONS( t3327, c2974 ); CONSTANTEXP( ADR( c2974 ) ); c2945 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_CHAR" ) ); CONSTANTEXP( ADR( c2945 ) ); c2932 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_S2CINT" ) ); CONSTANTEXP( ADR( c2932 ) ); c2919 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_S2CUINT" ) ); CONSTANTEXP( ADR( c2919 ) ); c2914 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_POINTER" ) ); CONSTANTEXP( ADR( c2914 ) ); c2909 = STRINGTOSYMBOL( CSTRING_TSCP( "CFLOAT" ) ); CONSTANTEXP( ADR( c2909 ) ); c2904 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_DOUBLE" ) ); CONSTANTEXP( ADR( c2904 ) ); c2899 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUBLE" ) ); CONSTANTEXP( ADR( c2899 ) ); c2895 = STRINGTOSYMBOL( CSTRING_TSCP( "FLOAT" ) ); CONSTANTEXP( ADR( c2895 ) ); c2891 = EMPTYLIST; t3328 = STRINGTOSYMBOL( CSTRING_TSCP( "ARRAY" ) ); c2891 = CONS( t3328, c2891 ); t3329 = STRINGTOSYMBOL( CSTRING_TSCP( "POINTER" ) ); c2891 = CONS( t3329, c2891 ); CONSTANTEXP( ADR( c2891 ) ); c2890 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGUNSIGNED" ) ); CONSTANTEXP( ADR( c2890 ) ); c2886 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTUNSIGNED" ) ); CONSTANTEXP( ADR( c2886 ) ); c2882 = STRINGTOSYMBOL( CSTRING_TSCP( "UNSIGNED" ) ); CONSTANTEXP( ADR( c2882 ) ); c2878 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGINT" ) ); CONSTANTEXP( ADR( c2878 ) ); c2874 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTINT" ) ); CONSTANTEXP( ADR( c2874 ) ); c2870 = STRINGTOSYMBOL( CSTRING_TSCP( "INT" ) ); CONSTANTEXP( ADR( c2870 ) ); c2866 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR" ) ); CONSTANTEXP( ADR( c2866 ) ); c2703 = CSTRING_TSCP( t3330 ); CONSTANTEXP( ADR( c2703 ) ); c2595 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2595 ) ); c2531 = CSTRING_TSCP( t3331 ); CONSTANTEXP( ADR( c2531 ) ); c2529 = STRINGTOSYMBOL( CSTRING_TSCP( "GOTO" ) ); CONSTANTEXP( ADR( c2529 ) ); c2490 = STRINGTOSYMBOL( CSTRING_TSCP( "EMPTYLIST" ) ); CONSTANTEXP( ADR( c2490 ) ); c2484 = CSTRING_TSCP( t3332 ); CONSTANTEXP( ADR( c2484 ) ); c2478 = STRINGTOSYMBOL( CSTRING_TSCP( "CONS" ) ); CONSTANTEXP( ADR( c2478 ) ); c2477 = STRINGTOSYMBOL( CSTRING_TSCP( "SET" ) ); CONSTANTEXP( ADR( c2477 ) ); c2463 = STRINGTOSYMBOL( CSTRING_TSCP( "TOS" ) ); CONSTANTEXP( ADR( c2463 ) ); c2403 = STRINGTOSYMBOL( CSTRING_TSCP( "REQVARS" ) ); CONSTANTEXP( ADR( c2403 ) ); c2394 = CSTRING_TSCP( t3333 ); CONSTANTEXP( ADR( c2394 ) ); c2388 = STRINGTOSYMBOL( CSTRING_TSCP( "VNAME" ) ); CONSTANTEXP( ADR( c2388 ) ); c2383 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY" ) ); CONSTANTEXP( ADR( c2383 ) ); c2378 = CSTRING_TSCP( t3334 ); CONSTANTEXP( ADR( c2378 ) ); c2366 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-VALUE" ) ); CONSTANTEXP( ADR( c2366 ) ); c2361 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED-PROCEDURE" ) ); CONSTANTEXP( ADR( c2361 ) ); c2275 = STRINGTOSYMBOL( CSTRING_TSCP( "EXITS" ) ); CONSTANTEXP( ADR( c2275 ) ); c2205 = STRINGTOSYMBOL( CSTRING_TSCP( "$CALL" ) ); CONSTANTEXP( ADR( c2205 ) ); c2184 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2184 ) ); c2171 = STRINGTOSYMBOL( CSTRING_TSCP( "TYPE" ) ); CONSTANTEXP( ADR( c2171 ) ); c2164 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE" ) ); CONSTANTEXP( ADR( c2164 ) ); c2152 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE-TAIL" ) ); CONSTANTEXP( ADR( c2152 ) ); c2151 = STRINGTOSYMBOL( CSTRING_TSCP( "GENERATE" ) ); CONSTANTEXP( ADR( c2151 ) ); c2134 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAP" ) ); CONSTANTEXP( ADR( c2134 ) ); c2118 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); CONSTANTEXP( ADR( c2118 ) ); } DEFTSCP( callcode__24call_2dgenc_v ); DEFCSTRING( t3335, "$CALL-GENC" ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); EXTERNTSCPP( callcode_inline_2dcall, XAL4( TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( callcode_inline_2dcall_v ); EXTERNTSCPP( callcode__24lap_2dgenc, XAL4( TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( callcode__24lap_2dgenc_v ); EXTERNTSCPP( callcode_la_2dexits_2dlb_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( callcode_la_2dexits_2dlb_3f_v ); EXTERNTSCPP( callcode_tail_2dcall, XAL5( TSCP, TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( callcode_tail_2dcall_v ); EXTERNTSCPP( callcode_known_2dc_2dcall, XAL5( TSCP, TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( callcode_known_2dc_2dcall_v ); EXTERNTSCPP( callcode_known_2dcall, XAL5( TSCP, TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( callcode_known_2dcall_v ); EXTERNTSCPP( callcode_unknown_2dcall, XAL4( TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( callcode_unknown_2dcall_v ); TSCP callcode__24call_2dgenc( l2092, e2093, b2094 ) TSCP l2092, e2093, b2094; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3335 ); if ( NEQ( TSCPTAG( e2093 ), PAIRTAG ) ) goto L3337; X6 = PAIR_CAR( e2093 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2205 ) ) ); goto L3338; L3337: X5 = FALSEVALUE; L3338: if ( FALSE( X5 ) ) goto L3341; X4 = scrt1_caddr( e2093 ); goto L3342; L3341: X4 = X5; L3342: if ( NEQ( TSCPTAG( e2093 ), PAIRTAG ) ) goto L3344; X6 = PAIR_CAR( e2093 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2205 ) ) ); goto L3345; L3344: X5 = FALSEVALUE; L3345: if ( FALSE( X5 ) ) goto L3348; if ( EQ( TSCPTAG( e2093 ), PAIRTAG ) ) goto L3351; scrt1__24__cdr_2derror( e2093 ); L3351: X6 = PAIR_CDR( e2093 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3354; scrt1__24__car_2derror( X6 ); L3354: X1 = PAIR_CAR( X6 ); goto L3349; L3348: X1 = X5; L3349: if ( NEQ( TSCPTAG( e2093 ), PAIRTAG ) ) goto L3357; X6 = PAIR_CAR( e2093 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2205 ) ) ); goto L3358; L3357: X5 = FALSEVALUE; L3358: if ( FALSE( X5 ) ) goto L3361; X3 = scrt1_cdddr( e2093 ); goto L3362; L3361: X3 = X5; L3362: if ( NOT( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), SYMBOLTAG ) ) ) ) goto L3364; X2 = plist_get( X4, c2184 ); goto L3365; L3364: X2 = FALSEVALUE; L3365: X5 = BOOLEAN( EQ( TSCPTAG( X4 ), PAIRTAG ) ); if ( FALSE( X5 ) ) goto L3376; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3374; scrt1__24__car_2derror( X4 ); L3374: X6 = PAIR_CAR( X4 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( c2118 ) ) ) goto L3376; POPSTACKTRACE( callcode_inline_2dcall( l2092, X4, X3, b2094 ) ); L3376: X5 = BOOLEAN( EQ( TSCPTAG( X4 ), PAIRTAG ) ); if ( FALSE( X5 ) ) goto L3386; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3384; scrt1__24__car_2derror( X4 ); L3384: X6 = PAIR_CAR( X4 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( c2134 ) ) ) goto L3386; POPSTACKTRACE( callcode__24lap_2dgenc( l2092, X4, X3, b2094 ) ); L3386: if ( FALSE( X2 ) ) goto L3400; if ( FALSE( X1 ) ) goto L3400; X5 = plist_get( X2, c2151 ); if ( EQ( _S2CUINT( X5 ), _S2CUINT( c2152 ) ) ) goto L3396; if ( FALSE( callcode_la_2dexits_2dlb_3f( X1, X2 ) ) ) goto L3400; L3396: POPSTACKTRACE( callcode_tail_2dcall( l2092, X4, X3, X2, b2094 ) ); L3400: if ( FALSE( X2 ) ) goto L3406; X5 = plist_get( X2, c2151 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2164 ) ) ) goto L3406; X5 = plist_get( X2, c2118 ); POPSTACKTRACE( callcode_inline_2dcall( l2092, X5, X3, b2094 ) ); L3406: if ( FALSE( X2 ) ) goto L3412; if ( FALSE( plist_get( X4, c2171 ) ) ) goto L3412; POPSTACKTRACE( callcode_known_2dc_2dcall( l2092, X4, X3, X2, b2094 ) ); L3412: if ( FALSE( X2 ) ) goto L3413; POPSTACKTRACE( callcode_known_2dcall( l2092, X4, X3, X2, b2094 ) ); L3413: POPSTACKTRACE( callcode_unknown_2dcall( l2092, X4, X3, b2094 ) ); } DEFTSCP( callcode_la_2dexits_2dlb_3f_v ); DEFCSTRING( t3415, "LA-EXITS-LB?" ); TSCP callcode_la_2dexits_2dlb_3f( i2260, i2261 ) TSCP i2260, i2261; { TSCP X1; PUSHSTACKTRACE( t3415 ); L3416: if ( FALSE( i2260 ) ) goto L3417; if ( EQ( _S2CUINT( i2260 ), _S2CUINT( i2261 ) ) ) goto L3419; X1 = plist_get( i2260, c2275 ); i2260 = X1; GOBACK( L3416 ); L3419: POPSTACKTRACE( TRUEVALUE ); L3417: POPSTACKTRACE( i2260 ); } DEFTSCP( callcode_inline_2dcall_v ); DEFCSTRING( t3421, "INLINE-CALL" ); EXTERNTSCPP( gencode_optional_2dargs, XAL1( TSCP ) ); EXTERNTSCP( gencode_optional_2dargs_v ); EXTERNTSCPP( lap_save_2dlap_2dtemps, XAL0( ) ); EXTERNTSCP( lap_save_2dlap_2dtemps_v ); EXTERNTSCP( gencode_free_2ddisplay_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); EXTERNTSCPP( lap_use_2dlap_2dtemp, XAL0( ) ); EXTERNTSCP( lap_use_2dlap_2dtemp_v ); TSCP callcode_b2296( v2380 ) TSCP v2380; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "BIND [inside INLINE-CALL]" ); X1 = sc_cons( v2380, PAIR_CAR( DISPLAY( 1 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 1 ) ), X1 ); if ( FALSE( plist_get( v2380, c2383 ) ) ) goto L3443; if ( TRUE( scrt1_memq( v2380, PAIR_CAR( DISPLAY( 0 ) ) ) ) ) goto L3446; X5 = sc_cons( v2380, EMPTYLIST ); X4 = X5; X3 = SYMBOL_VALUE( reserve_2ddisplay_v ); X3 = UNKNOWNCALL( X3, 2 ); VIA( PROCEDURE_CODE( X3 ) )( X4, PAIR_CAR( DISPLAY( 0 ) ), PROCEDURE_CLOSURE( X3 ) ); X3 = sc_cons( v2380, PAIR_CAR( DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 0 ) ), X3 ); L3446: X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = scrt1_cons_2a( c2394, CONS( plist_get( v2380, c2383 ), X3 ) ); goto L3451; L3443: if ( FALSE( scrt1_memq( v2380, PAIR_CAR( DISPLAY( 0 ) ) ) ) ) goto L3450; X2 = v2380; goto L3451; L3450: X3 = sc_cons( v2380, PAIR_CAR( DISPLAY( 0 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 0 ) ), X3 ); X3 = lap_use_2dlap_2dtemp( ); plist_put( v2380, c2388, X3 ); X2 = v2380; L3451: X1 = sc_cons( X2, PAIR_CAR( DISPLAY( 2 ) ) ); SETGEN( PAIR_CAR( DISPLAY( 2 ) ), X1 ); X1 = PAIR_CAR( DISPLAY( 2 ) ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3454; scrt1__24__car_2derror( X1 ); L3454: POPSTACKTRACE( PAIR_CAR( X1 ) ); } EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt2__3c_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_2dtwo_v ); EXTERNTSCPP( gencode_exp_2dgenc, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( gencode_exp_2dgenc_v ); EXTERNTSCPP( callcode_nal_2dargs_9446856b, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( callcode_nal_2dargs_9446856b_v ); EXTERNTSCPP( lap_restore_2dlap_2dtemps, XAL1( TSCP ) ); EXTERNTSCP( lap_restore_2dlap_2dtemps_v ); TSCP callcode_inline_2dcall( l2277, e2278, a2279, b2280 ) TSCP l2277, e2278, a2279, b2280; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( t3421 ); DISPLAY( 0 ) = b2280; a2279 = CONS( a2279, EMPTYLIST ); DISPLAY( 0 ) = CONS( DISPLAY( 0 ), EMPTYLIST ); if ( NEQ( TSCPTAG( e2278 ), PAIRTAG ) ) goto L3423; X3 = PAIR_CAR( e2278 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2118 ) ) ); goto L3424; L3423: X2 = FALSEVALUE; L3424: if ( FALSE( X2 ) ) goto L3427; if ( EQ( TSCPTAG( e2278 ), PAIRTAG ) ) goto L3430; scrt1__24__cdr_2derror( e2278 ); L3430: X3 = PAIR_CDR( e2278 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3433; scrt1__24__car_2derror( X3 ); L3433: X1 = PAIR_CAR( X3 ); goto L3428; L3427: X1 = X2; L3428: X2 = plist_get( X1, c2403 ); X3 = gencode_optional_2dargs( X1 ); X4 = lap_save_2dlap_2dtemps( ); DISPLAY( 1 ) = EMPTYLIST; DISPLAY( 1 ) = CONS( DISPLAY( 1 ), EMPTYLIST ); DISPLAY( 2 ) = EMPTYLIST; DISPLAY( 2 ) = CONS( DISPLAY( 2 ), EMPTYLIST ); X5 = gencode_free_2ddisplay_v; if ( FALSE( X3 ) ) goto L3457; X7 = scrt1_length( X2 ); X8 = scrt1_length( PAIR_CAR( a2279 ) ); if ( BITAND( BITOR( _S2CINT( X8 ), _S2CINT( X7 ) ), 3 ) ) goto L3460; X6 = BOOLEAN( LT( _S2CINT( X8 ), _S2CINT( X7 ) ) ); goto L3458; L3460: X6 = scrt2__3c_2dtwo( X8, X7 ); goto L3458; L3457: X6 = X3; L3458: if ( TRUE( X6 ) ) goto L3466; if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3472; X7 = scrt1_length( PAIR_CAR( a2279 ) ); X8 = scrt1_length( X2 ); if ( EQ( _S2CUINT( X7 ), _S2CUINT( X8 ) ) ) goto L3472; L3466: X7 = SYMBOL_VALUE( report_2derror_v ); X7 = UNKNOWNCALL( X7, 1 ); VIA( PROCEDURE_CODE( X7 ) )( c2378, PROCEDURE_CLOSURE( X7 ) ); goto L3473; L3472: X7 = X2; L3476: if ( EQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L3477; if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3481; scrt1__24__car_2derror( X7 ); L3481: X8 = PAIR_CAR( X7 ); X9 = plist_get( X8, c2184 ); if ( FALSE( X9 ) ) goto L3493; X11 = plist_get( X8, c2184 ); X10 = plist_get( X11, c2151 ); if ( EQ( _S2CUINT( X10 ), _S2CUINT( c2361 ) ) ) goto L3493; X11 = PAIR_CAR( a2279 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L3491; scrt1__24__car_2derror( X11 ); L3491: X10 = PAIR_CAR( X11 ); gencode_exp_2dgenc( c2366, X10, PAIR_CAR( DISPLAY( 0 ) ) ); goto L3494; L3493: X10 = callcode_b2296( X8 ); X12 = PAIR_CAR( a2279 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L3496; scrt1__24__car_2derror( X12 ); L3496: X11 = PAIR_CAR( X12 ); gencode_exp_2dgenc( X10, X11, PAIR_CAR( DISPLAY( 0 ) ) ); L3494: X10 = PAIR_CAR( a2279 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3499; scrt1__24__cdr_2derror( X10 ); L3499: X9 = PAIR_CDR( X10 ); SETGEN( PAIR_CAR( a2279 ), X9 ); X7 = PAIR_CDR( X7 ); GOBACK( L3476 ); L3477: if ( FALSE( X3 ) ) goto L3502; X7 = callcode_b2296( X3 ); callcode_nal_2dargs_9446856b( X7, PAIR_CAR( a2279 ), PAIR_CAR( DISPLAY( 0 ) ) ); L3502: X7 = SYMBOL_VALUE( lambda_2dbody_2dgenc_v ); X7 = UNKNOWNCALL( X7, 5 ); VIA( PROCEDURE_CODE( X7 ) )( l2277, e2278, PAIR_CAR( DISPLAY( 1 ) ), PAIR_CAR( DISPLAY( 2 ) ), PAIR_CAR( DISPLAY( 0 ) ), PROCEDURE_CLOSURE( X7 ) ); L3473: gencode_free_2ddisplay_v = X5; SDVAL = lap_restore_2dlap_2dtemps( X4 ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } DEFTSCP( callcode_nal_2dargs_9446856b_v ); DEFCSTRING( t3504, "LISTIFY-OPTIONAL-ARGS" ); EXTERNTSCPP( lap_emit_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_emit_2dlap_v ); EXTERNTSCPP( expform_vname, XAL1( TSCP ) ); EXTERNTSCP( expform_vname_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); EXTERNTSCPP( lap_drop_2dlap_2dtemp, XAL1( TSCP ) ); EXTERNTSCP( lap_drop_2dlap_2dtemp_v ); TSCP callcode_nal_2dargs_9446856b( v2436, a2437, b2438 ) TSCP v2436, a2437, b2438; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3504 ); if ( NEQ( _S2CUINT( a2437 ), _S2CUINT( EMPTYLIST ) ) ) goto L3506; X2 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( c2490, X2 ); X1 = scrt1_cons_2a( c2477, CONS( expform_vname( v2436 ), X2 ) ); POPSTACKTRACE( lap_emit_2dlap( X1 ) ); L3506: if ( EQ( TSCPTAG( a2437 ), PAIRTAG ) ) goto L3511; scrt1__24__cdr_2derror( a2437 ); L3511: X1 = PAIR_CDR( a2437 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3508; X1 = PAIR_CAR( a2437 ); gencode_exp_2dgenc( c2463, X1, b2438 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( c2490, X3 ); X2 = CONS( scrt1_cons_2a( c2478, CONS( c2463, X3 ) ), X2 ); X1 = scrt1_cons_2a( c2477, CONS( expform_vname( v2436 ), X2 ) ); POPSTACKTRACE( lap_emit_2dlap( X1 ) ); L3508: X1 = lap_use_2dlap_2dtemp( ); X2 = scrt1_reverse( a2437 ); X3 = X2; X4 = c2484; L3518: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3520; scrt1__24__car_2derror( X3 ); L3520: X5 = PAIR_CAR( X3 ); gencode_exp_2dgenc( c2463, X5, b2438 ); X5 = PAIR_CDR( X3 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L3522; X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( X4, X7 ); X6 = CONS( scrt1_cons_2a( c2478, CONS( c2463, X7 ) ), X6 ); X5 = scrt1_cons_2a( c2477, CONS( expform_vname( v2436 ), X6 ) ); lap_emit_2dlap( X5 ); goto L3523; L3522: X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( X4, X7 ); X6 = CONS( scrt1_cons_2a( c2478, CONS( c2463, X7 ) ), X6 ); X5 = scrt1_cons_2a( c2477, CONS( expform_vname( X1 ), X6 ) ); lap_emit_2dlap( X5 ); X5 = PAIR_CDR( X3 ); X4 = expform_vname( X1 ); X3 = X5; GOBACK( L3518 ); L3523: POPSTACKTRACE( lap_drop_2dlap_2dtemp( X1 ) ); } DEFTSCP( callcode_tail_2dcall_v ); DEFCSTRING( t3527, "TAIL-CALL" ); EXTERNTSCPP( callcode_tail_2dcall_2dbind, XAL4( TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( callcode_tail_2dcall_2dbind_v ); EXTERNTSCPP( gencode_code_2dlabel, XAL1( TSCP ) ); EXTERNTSCP( gencode_code_2dlabel_v ); TSCP callcode_tail_2dcall( l2492, f2493, a2494, i2495, b2496 ) TSCP l2492, f2493, a2494, i2495, b2496; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3527 ); X1 = gencode_optional_2dargs( i2495 ); X2 = plist_get( i2495, c2403 ); if ( FALSE( X1 ) ) goto L3530; X4 = scrt1_length( X2 ); X5 = scrt1_length( a2494 ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( X4 ) ), 3 ) ) goto L3533; X3 = BOOLEAN( LT( _S2CINT( X5 ), _S2CINT( X4 ) ) ); goto L3531; L3533: X3 = scrt2__3c_2dtwo( X5, X4 ); goto L3531; L3530: X3 = X1; L3531: if ( TRUE( X3 ) ) goto L3539; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3545; X4 = scrt1_length( a2494 ); X5 = scrt1_length( X2 ); if ( EQ( _S2CUINT( X4 ), _S2CUINT( X5 ) ) ) goto L3545; L3539: X3 = SYMBOL_VALUE( report_2derror_v ); X3 = UNKNOWNCALL( X3, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X3 ) )( c2531, f2493, PROCEDURE_CLOSURE( X3 ) ) ); L3545: X3 = lap_save_2dlap_2dtemps( ); callcode_tail_2dcall_2dbind( X2, X1, a2494, b2496 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X4 = scrt1_cons_2a( c2529, CONS( gencode_code_2dlabel( i2495 ), X5 ) ); lap_emit_2dlap( X4 ); X4 = SYMBOL_VALUE( update_2dcondition_2dinfo_v ); X4 = UNKNOWNCALL( X4, 1 ); VIA( PROCEDURE_CODE( X4 ) )( i2495, PROCEDURE_CLOSURE( X4 ) ); POPSTACKTRACE( lap_restore_2dlap_2dtemps( X3 ) ); } DEFTSCP( callcode_tail_2dcall_2dbind_v ); DEFCSTRING( t3547, "TAIL-CALL-BIND" ); EXTERNTSCPP( gencode_lookup, XAL2( TSCP, TSCP ) ); EXTERNTSCP( gencode_lookup_v ); EXTERNTSCPP( callcode_load_2dargl, XAL2( TSCP, TSCP ) ); EXTERNTSCP( callcode_load_2dargl_v ); TSCP callcode_tail_2dcall_2dbind( r2535, o2536, a2537, b2538 ) TSCP r2535, o2536, a2537, b2538; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3547 ); if ( NEQ( _S2CUINT( r2535 ), _S2CUINT( EMPTYLIST ) ) ) goto L3549; X1 = BOOLEAN( EQ( _S2CUINT( o2536 ), _S2CUINT( EMPTYLIST ) ) ); goto L3550; L3549: X1 = FALSEVALUE; L3550: if ( TRUE( X1 ) ) goto L3552; if ( NEQ( _S2CUINT( r2535 ), _S2CUINT( EMPTYLIST ) ) ) goto L3554; X2 = gencode_lookup( o2536, b2538 ); POPSTACKTRACE( callcode_nal_2dargs_9446856b( X2, a2537, b2538 ) ); L3554: if ( EQ( TSCPTAG( r2535 ), PAIRTAG ) ) goto L3557; scrt1__24__cdr_2derror( r2535 ); L3557: X3 = PAIR_CDR( r2535 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ); if ( FALSE( X2 ) ) goto L3580; if ( NEQ( _S2CUINT( o2536 ), _S2CUINT( EMPTYLIST ) ) ) goto L3580; X3 = PAIR_CAR( r2535 ); if ( FALSE( plist_get( X3, c2595 ) ) ) goto L3567; if ( EQ( TSCPTAG( a2537 ), PAIRTAG ) ) goto L3571; scrt1__24__car_2derror( a2537 ); L3571: X4 = PAIR_CAR( a2537 ); gencode_exp_2dgenc( c2463, X4, b2538 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( c2463, X5 ); X6 = plist_get( X3, c2383 ); if ( FALSE( X6 ) ) goto L3574; X8 = CONS( EMPTYLIST, EMPTYLIST ); X7 = scrt1_cons_2a( c2394, CONS( X6, X8 ) ); goto L3575; L3574: X7 = expform_vname( X3 ); L3575: X4 = scrt1_cons_2a( c2477, CONS( X7, X5 ) ); POPSTACKTRACE( lap_emit_2dlap( X4 ) ); L3567: X5 = PAIR_CAR( r2535 ); X4 = gencode_lookup( X5, b2538 ); if ( EQ( TSCPTAG( a2537 ), PAIRTAG ) ) goto L3578; scrt1__24__car_2derror( a2537 ); L3578: X5 = PAIR_CAR( a2537 ); POPSTACKTRACE( gencode_exp_2dgenc( X4, X5, b2538 ) ); L3552: POPSTACKTRACE( X1 ); L3580: X1 = PAIR_CAR( r2535 ); if ( EQ( TSCPTAG( a2537 ), PAIRTAG ) ) goto L3583; scrt1__24__car_2derror( a2537 ); L3583: X3 = PAIR_CAR( a2537 ); X4 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( o2536 ) ) ); if ( TRUE( X4 ) ) goto L3590; X5 = PAIR_CDR( r2535 ); if ( TRUE( scrt1_memq( X3, X5 ) ) ) goto L3590; X7 = sc_cons( X3, EMPTYLIST ); X6 = X7; X5 = callcode_load_2dargl( X6, b2538 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3596; scrt1__24__car_2derror( X5 ); L3596: X2 = PAIR_CAR( X5 ); goto L3598; L3590: X4 = lap_use_2dlap_2dtemp( ); gencode_exp_2dgenc( X4, X3, b2538 ); X2 = X4; L3598: X3 = PAIR_CDR( r2535 ); X4 = PAIR_CDR( a2537 ); callcode_tail_2dcall_2dbind( X3, o2536, X4, b2538 ); X3 = plist_get( X1, c2383 ); if ( FALSE( plist_get( X1, c2595 ) ) ) goto L3604; X5 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( X2, X5 ); if ( FALSE( X3 ) ) goto L3606; X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2394, CONS( X3, X7 ) ); goto L3607; L3606: X6 = expform_vname( X1 ); L3607: X4 = scrt1_cons_2a( c2477, CONS( X6, X5 ) ); POPSTACKTRACE( lap_emit_2dlap( X4 ) ); L3604: X5 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( X2, X5 ); X4 = scrt1_cons_2a( c2477, CONS( gencode_lookup( X1, b2538 ), X5 ) ); POPSTACKTRACE( lap_emit_2dlap( X4 ) ); } DEFTSCP( callcode__24lap_2dgenc_v ); DEFCSTRING( t3608, "$LAP-GENC" ); EXTERNTSCPP( callcode_subsym, XAL2( TSCP, TSCP ) ); EXTERNTSCP( callcode_subsym_v ); TSCP callcode__24lap_2dgenc( l2654, l2655, a2656, b2657 ) TSCP l2654, l2655, a2656, b2657; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3608 ); X1 = lap_save_2dlap_2dtemps( ); X2 = EMPTYLIST; X2 = CONS( X2, EMPTYLIST ); if ( NEQ( TSCPTAG( l2655 ), PAIRTAG ) ) goto L3612; X6 = PAIR_CAR( l2655 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2134 ) ) ); goto L3613; L3612: X5 = FALSEVALUE; L3613: if ( FALSE( X5 ) ) goto L3616; X3 = scrt1_caddr( l2655 ); goto L3617; L3616: X3 = X5; L3617: X4 = callcode_load_2dargl( a2656, b2657 ); L3618: X5 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ); if ( TRUE( X5 ) ) goto L3623; if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3623; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3628; scrt1__24__car_2derror( X3 ); L3628: X9 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3631; scrt1__24__car_2derror( X4 ); L3631: X11 = PAIR_CAR( X4 ); X10 = sc_cons( X11, EMPTYLIST ); X8 = sc_cons( X9, X10 ); X7 = X8; X6 = sc_cons( X7, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X6 ); X6 = PAIR_CDR( X3 ); X4 = PAIR_CDR( X4 ); X3 = X6; GOBACK( L3618 ); L3623: if ( TRUE( X4 ) ) goto L3640; if ( FALSE( X3 ) ) goto L3636; L3640: X5 = SYMBOL_VALUE( report_2derror_v ); X5 = UNKNOWNCALL( X5, 1 ); VIA( PROCEDURE_CODE( X5 ) )( c2703, PROCEDURE_CLOSURE( X5 ) ); L3636: if ( NEQ( TSCPTAG( l2655 ), PAIRTAG ) ) goto L3643; X5 = PAIR_CAR( l2655 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2134 ) ) ); goto L3644; L3643: X4 = FALSEVALUE; L3644: if ( FALSE( X4 ) ) goto L3647; X3 = scrt1_cdddr( l2655 ); goto L3648; L3647: X3 = X4; L3648: X4 = X3; L3651: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3653; scrt1__24__cdr_2derror( X4 ); L3653: if ( FALSE( PAIR_CDR( X4 ) ) ) goto L3655; X6 = PAIR_CAR( X4 ); X5 = callcode_subsym( X6, PAIR_CAR( X2 ) ); lap_emit_2dlap( X5 ); X4 = PAIR_CDR( X4 ); GOBACK( L3651 ); L3655: X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = PAIR_CAR( X4 ); X6 = CONS( callcode_subsym( X7, PAIR_CAR( X2 ) ), X6 ); X5 = scrt1_cons_2a( c2477, CONS( expform_vname( l2654 ), X6 ) ); lap_emit_2dlap( X5 ); POPSTACKTRACE( lap_restore_2dlap_2dtemps( X1 ) ); } DEFTSCP( callcode_subsym_v ); DEFCSTRING( t3661, "SUBSYM" ); EXTERNTSCPP( scrt1_assq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assq_v ); TSCP callcode_subsym( e2771, a2772 ) TSCP e2771, a2772; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3661 ); if ( EQ( _S2CUINT( e2771 ), _S2CUINT( EMPTYLIST ) ) ) goto L3663; if ( NOT( AND( EQ( TSCPTAG( e2771 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2771 ), SYMBOLTAG ) ) ) ) goto L3665; X1 = scrt1_assq( e2771, a2772 ); if ( FALSE( X1 ) ) goto L3668; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3671; scrt1__24__cdr_2derror( X1 ); L3671: X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3674; scrt1__24__car_2derror( X3 ); L3674: X2 = PAIR_CAR( X3 ); POPSTACKTRACE( expform_vname( X2 ) ); L3668: POPSTACKTRACE( e2771 ); L3665: if ( NEQ( TSCPTAG( e2771 ), PAIRTAG ) ) goto L3676; X2 = PAIR_CAR( e2771 ); X1 = callcode_subsym( X2, a2772 ); X3 = PAIR_CDR( e2771 ); X2 = callcode_subsym( X3, a2772 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L3676: POPSTACKTRACE( e2771 ); L3663: POPSTACKTRACE( e2771 ); } DEFTSCP( callcode_known_2dc_2dcall_v ); DEFCSTRING( t3680, "KNOWN-C-CALL" ); EXTERNTSCPP( gencode_emit_2dextern, XAL1( TSCP ) ); EXTERNTSCP( gencode_emit_2dextern_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( expform_cname, XAL1( TSCP ) ); EXTERNTSCP( expform_cname_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_memv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memv_v ); EXTERNTSCPP( callcode_l2857, XAL2( TSCP, TSCP ) ); TSCP callcode_l2857( a2859, t2860 ) TSCP a2859, t2860; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside KNOWN-C-CALL]" ); if ( FALSE( a2859 ) ) goto L3718; if ( EQ( TSCPTAG( t2860 ), PAIRTAG ) ) goto L3721; scrt1__24__car_2derror( t2860 ); L3721: X2 = PAIR_CAR( t2860 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2866 ) ) ) goto L3724; X3 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3727; scrt1__24__car_2derror( a2859 ); L3727: X1 = scrt1_cons_2a( c2945, CONS( PAIR_CAR( a2859 ), X3 ) ); goto L3770; L3724: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2870 ) ) ) goto L3729; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3732; scrt1__24__car_2derror( a2859 ); L3732: X1 = scrt1_cons_2a( c2870, CONS( scrt1_cons_2a( c2932, CONS( PAIR_CAR( a2859 ), X4 ) ), X3 ) ); goto L3770; L3729: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2874 ) ) ) goto L3734; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3737; scrt1__24__car_2derror( a2859 ); L3737: X1 = scrt1_cons_2a( c2874, CONS( scrt1_cons_2a( c2932, CONS( PAIR_CAR( a2859 ), X4 ) ), X3 ) ); goto L3770; L3734: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2878 ) ) ) goto L3739; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3742; scrt1__24__car_2derror( a2859 ); L3742: X1 = scrt1_cons_2a( c2878, CONS( scrt1_cons_2a( c2932, CONS( PAIR_CAR( a2859 ), X4 ) ), X3 ) ); goto L3770; L3739: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2882 ) ) ) goto L3744; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3747; scrt1__24__car_2derror( a2859 ); L3747: X1 = scrt1_cons_2a( c2882, CONS( scrt1_cons_2a( c2919, CONS( PAIR_CAR( a2859 ), X4 ) ), X3 ) ); goto L3770; L3744: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2886 ) ) ) goto L3749; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3752; scrt1__24__car_2derror( a2859 ); L3752: X1 = scrt1_cons_2a( c2886, CONS( scrt1_cons_2a( c2919, CONS( PAIR_CAR( a2859 ), X4 ) ), X3 ) ); goto L3770; L3749: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2890 ) ) ) goto L3754; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3757; scrt1__24__car_2derror( a2859 ); L3757: X1 = scrt1_cons_2a( c2890, CONS( scrt1_cons_2a( c2919, CONS( PAIR_CAR( a2859 ), X4 ) ), X3 ) ); goto L3770; L3754: if ( FALSE( scrt1_memv( X2, c2891 ) ) ) goto L3759; X3 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3762; scrt1__24__car_2derror( a2859 ); L3762: X1 = scrt1_cons_2a( c2914, CONS( PAIR_CAR( a2859 ), X3 ) ); goto L3770; L3759: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2895 ) ) ) goto L3764; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3767; scrt1__24__car_2derror( a2859 ); L3767: X1 = scrt1_cons_2a( c2909, CONS( scrt1_cons_2a( c2904, CONS( PAIR_CAR( a2859 ), X4 ) ), X3 ) ); goto L3770; L3764: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2899 ) ) ) goto L3769; X3 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3772; scrt1__24__car_2derror( a2859 ); L3772: X1 = scrt1_cons_2a( c2904, CONS( PAIR_CAR( a2859 ), X3 ) ); goto L3770; L3769: if ( EQ( TSCPTAG( a2859 ), PAIRTAG ) ) goto L3775; scrt1__24__car_2derror( a2859 ); L3775: X1 = PAIR_CAR( a2859 ); L3770: X3 = PAIR_CDR( a2859 ); X5 = PAIR_CDR( t2860 ); if ( FALSE( X5 ) ) goto L3780; X4 = X5; goto L3781; L3780: X4 = t2860; L3781: X2 = callcode_l2857( X3, X4 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L3718: POPSTACKTRACE( EMPTYLIST ); } TSCP callcode_known_2dc_2dcall( l2805, f2806, a2807, i2808, b2809 ) TSCP l2805, f2806, a2807, i2808, b2809; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3680 ); X1 = plist_get( i2808, c2403 ); X2 = plist_get( i2808, c3012 ); X3 = scrt1_length( X1 ); X4 = lap_save_2dlap_2dtemps( ); X5 = callcode_load_2dargl( a2807, b2809 ); gencode_emit_2dextern( f2806 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3687; X7 = scrt1_length( X5 ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( X3 ) ), 3 ) ) goto L3690; X6 = BOOLEAN( NEQ( _S2CUINT( X7 ), _S2CUINT( X3 ) ) ); goto L3688; L3690: if ( FALSE( scrt2__3d_2dtwo( X7, X3 ) ) ) goto L3692; X6 = FALSEVALUE; goto L3688; L3692: X6 = TRUEVALUE; goto L3688; L3687: X6 = FALSEVALUE; L3688: if ( TRUE( X6 ) ) goto L3698; if ( FALSE( X2 ) ) goto L3712; X7 = scrt1_length( X5 ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( X3 ) ), 3 ) ) goto L3704; if ( LT( _S2CINT( X7 ), _S2CINT( X3 ) ) ) goto L3698; goto L3712; L3704: if ( TRUE( scrt2__3c_2dtwo( X7, X3 ) ) ) goto L3698; L3712: X8 = CONS( EMPTYLIST, EMPTYLIST ); X9 = expform_cname( i2808 ); X11 = scrt1_append_2dtwo( X1, X2 ); X10 = callcode_l2857( X5, X11 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = CONS( scrt1_cons_2a( X9, CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ) ), X8 ); X7 = scrt1_cons_2a( c2477, CONS( c2463, X8 ) ); lap_emit_2dlap( X7 ); X8 = CONS( EMPTYLIST, EMPTYLIST ); if ( NEQ( _S2CUINT( l2805 ), _S2CUINT( c2366 ) ) ) goto L3782; X9 = TRUEVALUE; goto L3783; L3782: X9 = plist_get( f2806, c2171 ); L3783: if ( NEQ( _S2CUINT( X9 ), _S2CUINT( TRUEVALUE ) ) ) goto L3785; X10 = c2463; goto L3800; L3785: if ( NEQ( _S2CUINT( X9 ), _S2CUINT( c2866 ) ) ) goto L3787; X10 = c2997; goto L3800; L3787: if ( FALSE( scrt1_memv( X9, c2974 ) ) ) goto L3789; X10 = c2996; goto L3800; L3789: if ( FALSE( scrt1_memv( X9, c2975 ) ) ) goto L3791; X10 = c2995; goto L3800; L3791: if ( FALSE( scrt1_memv( X9, c2891 ) ) ) goto L3793; X10 = c2994; goto L3800; L3793: if ( NEQ( _S2CUINT( X9 ), _S2CUINT( c2895 ) ) ) goto L3795; X10 = c2993; goto L3800; L3795: if ( NEQ( _S2CUINT( X9 ), _S2CUINT( c2899 ) ) ) goto L3797; X10 = c2992; goto L3800; L3797: if ( NEQ( _S2CUINT( X9 ), _S2CUINT( c2985 ) ) ) goto L3799; X12 = expform_cname( i2808 ); X11 = SYMBOL_VALUE( report_2dwarning_v ); X11 = UNKNOWNCALL( X11, 2 ); VIA( PROCEDURE_CODE( X11 ) )( c2989, X12, PROCEDURE_CLOSURE( X11 ) ); lap_emit_2dlap( c2990 ); X10 = c2991; goto L3800; L3799: X10 = c2986; L3800: X8 = CONS( X10, X8 ); X7 = scrt1_cons_2a( c2477, CONS( expform_vname( l2805 ), X8 ) ); lap_emit_2dlap( X7 ); goto L3713; L3698: X8 = plist_get( f2806, c3009 ); X7 = SYMBOL_VALUE( report_2derror_v ); X7 = UNKNOWNCALL( X7, 2 ); VIA( PROCEDURE_CODE( X7 ) )( c2531, X8, PROCEDURE_CLOSURE( X7 ) ); L3713: POPSTACKTRACE( lap_restore_2dlap_2dtemps( X4 ) ); } DEFTSCP( callcode_known_2dcall_v ); DEFCSTRING( t3802, "KNOWN-CALL" ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCP( sc_emptystring ); EXTERNTSCPP( scrt1_list_2dtail, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_list_2dtail_v ); TSCP callcode_known_2dcall( l3016, f3017, a3018, i3019, b3020 ) TSCP l3016, f3017, a3018, i3019, b3020; { TSCP X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3802 ); a3018 = CONS( a3018, EMPTYLIST ); X1 = plist_get( i3019, c2403 ); X1 = CONS( X1, EMPTYLIST ); X2 = gencode_optional_2dargs( i3019 ); X3 = scrt1_length( PAIR_CAR( X1 ) ); X4 = lap_save_2dlap_2dtemps( ); gencode_emit_2dextern( f3017 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3808; X6 = scrt1_length( PAIR_CAR( a3018 ) ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( X3 ) ), 3 ) ) goto L3811; X5 = BOOLEAN( NEQ( _S2CUINT( X6 ), _S2CUINT( X3 ) ) ); goto L3809; L3811: if ( FALSE( scrt2__3d_2dtwo( X6, X3 ) ) ) goto L3813; X5 = FALSEVALUE; goto L3809; L3813: X5 = TRUEVALUE; goto L3809; L3808: X5 = FALSEVALUE; L3809: if ( TRUE( X5 ) ) goto L3819; if ( FALSE( X2 ) ) goto L3833; X6 = scrt1_length( PAIR_CAR( a3018 ) ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( X3 ) ), 3 ) ) goto L3825; if ( LT( _S2CINT( X6 ), _S2CINT( X3 ) ) ) goto L3819; goto L3833; L3825: if ( TRUE( scrt2__3c_2dtwo( X6, X3 ) ) ) goto L3819; L3833: if ( FALSE( X2 ) ) goto L3841; X6 = plist_get( f3017, c3067 ); if ( FALSE( scrt1_equal_3f( X6, sc_emptystring ) ) ) goto L3841; X6 = callcode_load_2dargl( PAIR_CAR( a3018 ), b3020 ); SETGEN( PAIR_CAR( a3018 ), X6 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = expform_cname( i3019 ); X9 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X7 = CONS( scrt1_cons_2a( X8, CONS( scrt1_append_2dtwo( PAIR_CAR( a3018 ), X9 ), EMPTYLIST ) ), X7 ); X6 = scrt1_cons_2a( c2477, CONS( expform_vname( l3016 ), X7 ) ); lap_emit_2dlap( X6 ); goto L3834; L3841: X8 = SYMBOL_VALUE( list_2dhead_v ); X8 = UNKNOWNCALL( X8, 2 ); X7 = VIA( PROCEDURE_CODE( X8 ) )( PAIR_CAR( a3018 ), X3, PROCEDURE_CLOSURE( X8 ) ); X6 = callcode_load_2dargl( X7, b3020 ); SETGEN( PAIR_CAR( X1 ), X6 ); if ( FALSE( X2 ) ) goto L3843; X6 = scrt1_list_2dtail( PAIR_CAR( a3018 ), X3 ); callcode_nal_2dargs_9446856b( c2463, X6, b3020 ); L3843: X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = expform_cname( i3019 ); if ( FALSE( X2 ) ) goto L3845; X11 = c3070; goto L3846; L3845: X11 = EMPTYLIST; L3846: X15 = plist_get( i3019, c2151 ); if ( NEQ( _S2CUINT( X15 ), _S2CUINT( c2361 ) ) ) goto L3847; X16 = CONS( EMPTYLIST, EMPTYLIST ); X15 = scrt1_cons_2a( c3076, CONS( gencode_lookup( f3017, b3020 ), X16 ) ); X14 = scrt1_cons_2a( X15, CONS( EMPTYLIST, EMPTYLIST ) ); goto L3848; L3847: X14 = EMPTYLIST; L3848: X15 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X13 = scrt1_append_2dtwo( X14, X15 ); X12 = scrt1_cons_2a( X13, EMPTYLIST ); X10 = scrt1_append_2dtwo( X11, X12 ); X9 = scrt1_cons_2a( X10, EMPTYLIST ); X7 = CONS( scrt1_cons_2a( X8, CONS( scrt1_append_2dtwo( PAIR_CAR( X1 ), X9 ), EMPTYLIST ) ), X7 ); X6 = scrt1_cons_2a( c2477, CONS( expform_vname( l3016 ), X7 ) ); lap_emit_2dlap( X6 ); goto L3834; L3819: X7 = plist_get( f3017, c3009 ); X6 = SYMBOL_VALUE( report_2derror_v ); X6 = UNKNOWNCALL( X6, 2 ); VIA( PROCEDURE_CODE( X6 ) )( c2531, X7, PROCEDURE_CLOSURE( X6 ) ); L3834: POPSTACKTRACE( lap_restore_2dlap_2dtemps( X4 ) ); } DEFTSCP( callcode_unknown_2dcall_v ); DEFCSTRING( t3849, "UNKNOWN-CALL" ); TSCP callcode_unknown_2dcall( l3083, f3084, a3085, b3086 ) TSCP l3083, f3084, a3085, b3086; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3849 ); X1 = lap_save_2dlap_2dtemps( ); X2 = lap_use_2dlap_2dtemp( ); X3 = callcode_load_2dargl( a3085, b3086 ); gencode_exp_2dgenc( X2, f3084, b3086 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_length( a3085 ), X6 ); X5 = CONS( scrt1_cons_2a( c3093, CONS( expform_vname( X2 ), X6 ) ), X5 ); X4 = scrt1_cons_2a( c2477, CONS( X2, X5 ) ); lap_emit_2dlap( X4 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c3094, CONS( scrt1_cons_2a( c3095, CONS( expform_vname( X2 ), X8 ) ), X7 ) ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( c3076, CONS( expform_vname( X2 ), X9 ) ); X7 = scrt1_cons_2a( X8, CONS( EMPTYLIST, EMPTYLIST ) ); X5 = CONS( scrt1_cons_2a( X6, CONS( scrt1_append_2dtwo( X3, X7 ), EMPTYLIST ) ), X5 ); X4 = scrt1_cons_2a( c2477, CONS( expform_vname( l3083 ), X5 ) ); lap_emit_2dlap( X4 ); POPSTACKTRACE( lap_restore_2dlap_2dtemps( X1 ) ); } DEFTSCP( callcode_load_2dargl_v ); DEFCSTRING( t3854, "LOAD-ARGL" ); EXTERNTSCPP( gencode_var_2din_2dstack, XAL1( TSCP ) ); EXTERNTSCP( gencode_var_2din_2dstack_v ); EXTERNTSCPP( gencode_var_2dis_2dglobal, XAL1( TSCP ) ); EXTERNTSCP( gencode_var_2dis_2dglobal_v ); EXTERNTSCPP( gencode_var_2dis_2dconstant, XAL1( TSCP ) ); EXTERNTSCP( gencode_var_2dis_2dconstant_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP callcode_load_2dargl( a3097, b3098 ) TSCP a3097, b3098; { TSCP X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3854 ); X1 = a3097; X2 = EMPTYLIST; X3 = EMPTYLIST; L3857: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3858; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3861; scrt1__24__car_2derror( X1 ); L3861: X6 = PAIR_CAR( X1 ); X7 = BOOLEAN( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), SYMBOLTAG ) ) ); if ( FALSE( X7 ) ) goto L3885; X8 = gencode_var_2din_2dstack( X6 ); if ( TRUE( X8 ) ) goto L3872; X10 = gencode_var_2dis_2dglobal( X6 ); if ( FALSE( X10 ) ) goto L3874; if ( FALSE( plist_get( X6, c2171 ) ) ) goto L3876; X9 = FALSEVALUE; goto L3875; L3876: X9 = TRUEVALUE; goto L3875; L3874: X9 = X10; L3875: if ( TRUE( X9 ) ) goto L3872; if ( TRUE( gencode_var_2dis_2dconstant( X6 ) ) ) goto L3872; L3885: X7 = lap_use_2dlap_2dtemp( ); gencode_exp_2dgenc( X7, X6, b3098 ); X5 = X7; goto L3886; L3872: gencode_emit_2dextern( X6 ); X5 = gencode_lookup( X6, b3098 ); L3886: X4 = sc_cons( X5, EMPTYLIST ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3890; X5 = PAIR_CDR( X1 ); X3 = X4; X2 = X4; X1 = X5; GOBACK( L3857 ); L3890: X5 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3895; scdebug_error( c3133, c3134, CONS( X3, EMPTYLIST ) ); L3895: X3 = SETGEN( PAIR_CDR( X3 ), X4 ); X1 = X5; GOBACK( L3857 ); L3858: POPSTACKTRACE( X2 ); } void scdebug__init(); void expform__init(); void scrt2__init(); void lap__init(); void gencode__init(); void plist__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scdebug__init(); expform__init(); scrt2__init(); lap__init(); gencode__init(); plist__init(); scrt1__init(); MAXDISPLAY( 3 ); } void callcode__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(callcode SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3335, ADR( callcode__24call_2dgenc_v ), MAKEPROCEDURE( 3, 0, callcode__24call_2dgenc, EMPTYLIST ) ); INITIALIZEVAR( t3415, ADR( callcode_la_2dexits_2dlb_3f_v ), MAKEPROCEDURE( 2, 0, callcode_la_2dexits_2dlb_3f, EMPTYLIST ) ); INITIALIZEVAR( t3421, ADR( callcode_inline_2dcall_v ), MAKEPROCEDURE( 4, 0, callcode_inline_2dcall, EMPTYLIST ) ); INITIALIZEVAR( t3504, ADR( callcode_nal_2dargs_9446856b_v ), MAKEPROCEDURE( 3, 0, callcode_nal_2dargs_9446856b, EMPTYLIST ) ); INITIALIZEVAR( t3527, ADR( callcode_tail_2dcall_v ), MAKEPROCEDURE( 5, 0, callcode_tail_2dcall, EMPTYLIST ) ); INITIALIZEVAR( t3547, ADR( callcode_tail_2dcall_2dbind_v ), MAKEPROCEDURE( 4, 0, callcode_tail_2dcall_2dbind, EMPTYLIST ) ); INITIALIZEVAR( t3608, ADR( callcode__24lap_2dgenc_v ), MAKEPROCEDURE( 4, 0, callcode__24lap_2dgenc, EMPTYLIST ) ); INITIALIZEVAR( t3661, ADR( callcode_subsym_v ), MAKEPROCEDURE( 2, 0, callcode_subsym, EMPTYLIST ) ); INITIALIZEVAR( t3680, ADR( callcode_known_2dc_2dcall_v ), MAKEPROCEDURE( 5, 0, callcode_known_2dc_2dcall, EMPTYLIST ) ); INITIALIZEVAR( t3802, ADR( callcode_known_2dcall_v ), MAKEPROCEDURE( 5, 0, callcode_known_2dcall, EMPTYLIST ) ); INITIALIZEVAR( t3849, ADR( callcode_unknown_2dcall_v ), MAKEPROCEDURE( 4, 0, callcode_unknown_2dcall, EMPTYLIST ) ); INITIALIZEVAR( t3854, ADR( callcode_load_2dargl_v ), MAKEPROCEDURE( 2, 0, callcode_load_2dargl, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/callcode.sc000066400000000000000000000321071203736146400166340ustar00rootroot00000000000000;;; Code generator for $call and $lap expressions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module callcode) ;;; External and in-line declarations. (include "plist.sch") (include "expform.sch") (include "lambdaexp.sch") (include "miscexp.sch") (include "gencode.sch") (include "lap.sch") ;;; ($call tail func arg ...) ==> emit code for the call and return it's ;;; result. ;;; ;;; The first step in generating code for a call is figuring out the type of ;;; function being called and the type of call. This is done by the following ;;; function which then calls the appropriate function to actually generate ;;; code for the call. (define ($CALL-GENC loc exp bindings) (let* ((func ($call-func exp)) (tail ($call-tail exp)) (argl ($call-argl exp)) (id (if (symbol? func) (id-lambda func) #f))) (cond (($lambda? func) (inline-call loc func argl bindings)) (($lap? func) ($lap-genc loc func argl bindings)) ((and id tail (or (eq? (lambda-generate id) 'inline-tail) (la-exits-lb? tail id))) (tail-call loc func argl id bindings)) ((and id (eq? (lambda-generate id) 'inline)) (inline-call loc (lambda-$lambda id) argl bindings)) ((and id (id-type func)) (known-c-call loc func argl id bindings)) (id (known-call loc func argl id bindings)) (else (unknown-call loc func argl bindings))))) (define (LA-EXITS-LB? ida idb) (and ida (or (eq? ida idb) (la-exits-lb? (lambda-exits ida) idb)))) ;;; When the function is a lambda expression, or when there is only one actual ;;; call to an internally defined function, then it may be expanded in-line. ;;; The lambda expression is effectively treated as LET, with the arguments ;;; used as the initial values. (define (INLINE-CALL loc exp argl bindings) (let* ((id ($lambda-id exp)) (req (lambda-reqvars id)) (opt (optional-args id)) (temp-state (save-lap-temps)) (varl '()) (vals '()) (save-free-display free-display) ;;; Assign a temp. to the lexically bound var if it does not ;;; have a memory location. Build the varl and vals lists. (bind (lambda (var) (set! varl (cons var varl)) (set! vals (cons (cond ((id-display var) (when (not (memq var bindings)) (reserve-display (list var) bindings) (set! bindings (cons var bindings))) `("DISPLAY" ,(id-display var))) ((not (memq var bindings)) (set! bindings (cons var bindings)) (set-id-vname! var (use-lap-temp)) var) (else var)) vals)) (car vals)))) (cond ((or (and opt (< (length argl) (length req))) (and (null? opt) (not (eq? (length argl) (length req))))) (report-error "Incorrect number of arguments for lambda")) (else (for-each (lambda (var) (if (and (id-lambda var) (not (eq? (lambda-generate (id-lambda var)) 'closed-procedure))) (exp-genc 'no-value (car argl) bindings) (exp-genc (bind var) (car argl) bindings)) (set! argl (cdr argl))) req) (if opt (listify-optional-args (bind opt) argl bindings)) (lambda-body-genc loc exp varl vals bindings))) (set! free-display save-free-display) (restore-lap-temps temp-state))) ;;; Optional arguments are combined into a list by the caller. This function ;;; emits the code to evaluate each argument and form them into a list. (define (LISTIFY-OPTIONAL-ARGS var argl bindings) (cond ((null? argl) (emit-lap `(SET ,(vname var) EMPTYLIST))) ((null? (cdr argl)) (exp-genc 'tos (car argl) bindings) (emit-lap `(SET ,(vname var) (CONS tos EMPTYLIST)))) (else (let ((ltemp (use-lap-temp))) (let loop ((argl (reverse argl)) (reg "EMPTYLIST")) (exp-genc 'tos (car argl) bindings) (cond ((not (null? (cdr argl))) (emit-lap `(SET ,(vname ltemp) (CONS tos ,reg))) (loop (cdr argl) (vname ltemp))) (else (emit-lap `(SET ,(vname var) (CONS tos ,reg)))))) (drop-lap-temp ltemp))))) ;;; When a tail-recursive call can be generated, the following routine is ;;; called. Tail-recursion elimination is an example of how computer ;;; scientists can gain insight by observing nature. When a cat tires of ;;; chasing its tail, does it have to "unwind" itself? (define (TAIL-CALL loc func argl id bindings) (let ((req (lambda-reqvars id)) (opt (optional-args id))) (if (or (and opt (< (length argl) (length req))) (and (null? opt) (not (eq? (length argl) (length req))))) (report-error "Incorrect number of arguments for" func) (let ((temp-state (save-lap-temps))) (tail-call-bind req opt argl bindings) (emit-lap `(GOTO ,(code-label id))) (update-condition-info id) (restore-lap-temps temp-state))))) ;;; The arguments to a tail-called function are evaluated and assigned taking ;;; care to avoid the use of a temporary for the evaluation of the last one. ;;; Note the special case where a temporary must be allocated when the value ;;; of the argument is one of the function's variables that is being rebound. ;;; Also note the special handling for binding a variable which is set!. (define (TAIL-CALL-BIND req opt argl bindings) (cond ((and (null? req) (null? opt))) ((null? req) (listify-optional-args (lookup opt bindings) argl bindings)) ((and (null? (cdr req)) (null? opt)) (let ((var (car req))) (cond ((id-set! var) (exp-genc 'tos (car argl) bindings) (emit-lap `(SET ,(let ((x (id-display var))) (if x `("DISPLAY" ,x) (vname var))) tos))) (else (exp-genc (lookup (car req) bindings) (car argl) bindings))))) (else (let ((var (car req)) (val (let ((arg (car argl))) (if (or (eq? arg opt) (memq arg (cdr req))) (let ((temp (use-lap-temp))) (exp-genc temp arg bindings) temp) (car (load-argl (list arg) bindings)))))) (tail-call-bind (cdr req) opt (cdr argl) bindings) (let ((displayx (id-display var))) (if (id-set! var) (emit-lap `(SET ,(if displayx `("DISPLAY" ,displayx) (vname var)) ,val)) (emit-lap `(SET ,(lookup var bindings) ,val)))))))) ;;; When the function is a block of lap code, then it will be evaluated here. ;;; Arguments will be looked up and then the lap code will be emitted with ;;; appropriate substitutions. (define ($LAP-GENC loc lap argl bindings) (let ((alist '()) (save-temp (save-lap-temps))) (do ((vars ($lap-vars lap) (cdr vars)) (vals (load-argl argl bindings) (cdr vals))) ((or (null? vars) (null? vals)) (if (or vals vars) (report-error "Incorrect number of arguments for LAP construct"))) (set! alist (cons (list (car vars) (car vals)) alist))) (let loop ((laps ($lap-body lap))) (cond ((cdr laps) (emit-lap (subsym (car laps) alist)) (loop (cdr laps))) (else (emit-lap `(SET ,(vname loc) ,(subsym (car laps) alist)))))) (restore-lap-temps save-temp))) ;;; Arguments are substituted into the lap code by the following function. (define (SUBSYM exp alist) (cond ((null? exp) exp) ((symbol? exp) (let ((old-new (assq exp alist))) (if old-new (vname (cadr old-new)) exp))) ((pair? exp) (cons (subsym (car exp) alist) (subsym (cdr exp) alist))) (else exp))) ;;; When a known C function is called, the following procedure emits the code ;;; to call it with converted arguments and then convert the result. (define (KNOWN-C-CALL loc func argl id bindings) (let* ((req (lambda-reqvars id)) (opt (lambda-optvars id)) (reqlen (length req)) (save-lap (save-lap-temps)) (argl (load-argl argl bindings))) (emit-extern func) (cond ((or (and (null? opt) (not (= (length argl) reqlen))) (and opt (< (length argl) reqlen))) (report-error "Incorrect number of arguments for" (id-printname func))) (else (emit-lap `(SET TOS (,(cname id) ,@(let loop ((args argl) (types (append req opt))) (if args (cons (case (car types) ((char) `(TSCP_CHAR ,(car args))) ((int) `(INT (TSCP_S2CINT ,(car args)))) ((shortint) `(SHORTINT (TSCP_S2CINT ,(car args)))) ((longint) `(LONGINT (TSCP_S2CINT ,(car args)))) ((unsigned) `(UNSIGNED (TSCP_S2CUINT ,(car args)))) ((shortunsigned) `(SHORTUNSIGNED (TSCP_S2CUINT ,(car args)))) ((longunsigned) `(LONGUNSIGNED (TSCP_S2CUINT ,(car args)))) ((pointer array) `(TSCP_POINTER ,(car args))) ((float) `(CFLOAT (TSCP_DOUBLE ,(car args)))) ((double) `(TSCP_DOUBLE ,(car args))) (else (car args))) (loop (cdr args) (or (cdr types) types))) '()))))) (emit-lap `(SET ,(vname loc) ,(case (or (eq? loc 'no-value) (id-type func)) ((#t) 'TOS) ((char) '(CHAR_TSCP TOS)) ((int shortint longint) '(S2CINT_TSCP (_S2CINT TOS))) ((unsigned shortunsigned longunsigned) '(S2CUINT_TSCP (_S2CUINT TOS))) ((pointer array) '(POINTER_TSCP TOS)) ((float) '(DOUBLE_TSCP (CDOUBLE TOS))) ((double) '(DOUBLE_TSCP TOS)) ((void) (report-warning "C procedure does not return a value:" (cname id)) (emit-lap '(SET NO-VALUE TOS)) 'FALSEVALUE) (else '(_TSCP TOS))))))) (restore-lap-temps save-lap))) ;;; When a known function is called, the minimal calling sequence necessary ;;; is generated, and the argument count can be checked at compile time. Note ;;; the special case for functions with a variable number of arguments which ;;; do not have a module name. This is to allow calls to ULTRIX or C-library ;;; routines which take a variable number of arguments. (define (KNOWN-CALL loc func argl id bindings) (let* ((req (lambda-reqvars id)) (opt (optional-args id)) (reqlen (length req)) (save-lap (save-lap-temps))) (emit-extern func) (cond ((or (and (null? opt) (not (= (length argl) reqlen))) (and opt (< (length argl) reqlen))) (report-error "Incorrect number of arguments for" (id-printname func))) ((and opt (equal? (id-module func) "")) (set! argl (load-argl argl bindings)) (emit-lap `(SET ,(vname loc) (,(cname id) ,@argl)))) (else (set! req (load-argl (list-head argl reqlen) bindings)) (if opt (listify-optional-args 'tos (list-tail argl reqlen) bindings)) (emit-lap `(SET ,(vname loc) (,(cname id) ,@req ,@(if opt '(tos) '()) ,@(if (eq? (lambda-generate id) 'closed-procedure) `((PROCEDURE_CLOSURE ,(lookup func bindings))) '())))))) (restore-lap-temps save-lap))) ;;; The most general calling sequence is when nothing is known about the ;;; procedure. If the procedure takes a fixed number of arguments, then the ;;; call will be in-line, otherwise, a special form of APPLY will be used ;;; as the trampoline. (define (UNKNOWN-CALL loc func argl bindings) (let* ((save-state (save-lap-temps)) (proc (use-lap-temp)) (argtemps (load-argl argl bindings))) (exp-genc proc func bindings) (emit-lap `(SET ,proc (UNKNOWNCALL ,(vname proc) ,(length argl)))) (emit-lap `(SET ,(vname loc) ((VIA (PROCEDURE_CODE ,(vname proc))) ,@argtemps (PROCEDURE_CLOSURE ,(vname proc))))) (restore-lap-temps save-state))) ;;; Argument lists are evaluated and loaded into temporary variables by the ;;; following function. It returns a list of variables which hold the ;;; values. (define (LOAD-ARGL argl bindings) (map (lambda (arg) (if (and (symbol? arg) (or (var-in-stack arg) (and (var-is-global arg) (not (id-type arg))) (var-is-constant arg))) (begin (emit-extern arg) (lookup arg bindings)) (let ((temp (use-lap-temp))) (exp-genc temp arg bindings) temp))) argl)) scheme2c-2012.10.14/scsc/closeana.c000066400000000000000000002405341203736146400164750ustar00rootroot00000000000000 /* SCHEME->C */ #include void closeana__init(); DEFSTATICTSCP( name_2da_2dlambda_v ); DEFSTATICTSCP( log_3f_v ); DEFSTATICTSCP( sc_2dicode_v ); DEFSTATICTSCP( assign_2dknown_2dname_v ); DEFCSTRING( t5203, "~A forces ~A to display~%" ); DEFSTATICTSCP( c4820 ); DEFSTATICTSCP( c4780 ); DEFSTATICTSCP( t5204 ); DEFSTATICTSCP( t5205 ); DEFSTATICTSCP( c4681 ); DEFSTATICTSCP( t5206 ); DEFSTATICTSCP( t5207 ); DEFSTATICTSCP( c4648 ); DEFSTATICTSCP( c4551 ); DEFSTATICTSCP( c4537 ); DEFSTATICTSCP( c4517 ); DEFSTATICTSCP( c4508 ); DEFSTATICTSCP( c4186 ); DEFSTATICTSCP( c4065 ); DEFCSTRING( t5208, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c4020 ); DEFSTATICTSCP( c4019 ); DEFSTATICTSCP( c3821 ); DEFSTATICTSCP( c3817 ); DEFSTATICTSCP( c3813 ); DEFSTATICTSCP( c3339 ); DEFSTATICTSCP( t5209 ); DEFSTATICTSCP( c3317 ); DEFSTATICTSCP( c3189 ); DEFSTATICTSCP( c3184 ); DEFSTATICTSCP( c3181 ); DEFSTATICTSCP( c3165 ); DEFSTATICTSCP( c3151 ); DEFSTATICTSCP( c3042 ); DEFCSTRING( t5210, "~A forces ~A to the display~%" ); DEFSTATICTSCP( c3015 ); DEFCSTRING( t5211, "~A must be a closed procedure~%" ); DEFSTATICTSCP( c2958 ); DEFSTATICTSCP( c2955 ); DEFSTATICTSCP( c2950 ); DEFSTATICTSCP( c2949 ); DEFSTATICTSCP( c2936 ); DEFSTATICTSCP( c2574 ); DEFSTATICTSCP( c2550 ); DEFSTATICTSCP( c2407 ); DEFSTATICTSCP( t5212 ); DEFSTATICTSCP( c2223 ); DEFSTATICTSCP( c2207 ); DEFSTATICTSCP( c2161 ); DEFSTATICTSCP( c2126 ); DEFSTATICTSCP( c2069 ); DEFSTATICTSCP( c2065 ); DEFSTATICTSCP( c2043 ); static void init_constants() { name_2da_2dlambda_v = STRINGTOSYMBOL( CSTRING_TSCP( "NAME-A-LAMBDA" ) ); CONSTANTEXP( ADR( name_2da_2dlambda_v ) ); log_3f_v = STRINGTOSYMBOL( CSTRING_TSCP( "LOG?" ) ); CONSTANTEXP( ADR( log_3f_v ) ); sc_2dicode_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-ICODE" ) ); CONSTANTEXP( ADR( sc_2dicode_v ) ); assign_2dknown_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "ASSIGN-KNOW\ N-NAME" ) ); CONSTANTEXP( ADR( assign_2dknown_2dname_v ) ); c4820 = CSTRING_TSCP( t5203 ); CONSTANTEXP( ADR( c4820 ) ); c4780 = EMPTYLIST; t5204 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED-PROCEDURE" ) ); c4780 = CONS( t5204, c4780 ); t5205 = STRINGTOSYMBOL( CSTRING_TSCP( "PROCEDURE" ) ); c4780 = CONS( t5205, c4780 ); CONSTANTEXP( ADR( c4780 ) ); c4681 = EMPTYLIST; t5206 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE-TAIL" ) ); c4681 = CONS( t5206, c4681 ); t5207 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE" ) ); c4681 = CONS( t5207, c4681 ); CONSTANTEXP( ADR( c4681 ) ); c4648 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE-TAILS" ) ); CONSTANTEXP( ADR( c4648 ) ); c4551 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE-TAIL" ) ); CONSTANTEXP( ADR( c4551 ) ); c4537 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE" ) ); CONSTANTEXP( ADR( c4537 ) ); c4517 = STRINGTOSYMBOL( CSTRING_TSCP( "PROCEDURE" ) ); CONSTANTEXP( ADR( c4517 ) ); c4508 = STRINGTOSYMBOL( CSTRING_TSCP( "NAME" ) ); CONSTANTEXP( ADR( c4508 ) ); c4186 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNAL" ) ); CONSTANTEXP( ADR( c4186 ) ); c4065 = STRINGTOSYMBOL( CSTRING_TSCP( "EXITS" ) ); CONSTANTEXP( ADR( c4065 ) ); c4020 = CSTRING_TSCP( t5208 ); CONSTANTEXP( ADR( c4020 ) ); c4019 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CAR!" ) ); CONSTANTEXP( ADR( c4019 ) ); c3821 = STRINGTOSYMBOL( CSTRING_TSCP( "REAL-CALLS" ) ); CONSTANTEXP( ADR( c3821 ) ); c3817 = STRINGTOSYMBOL( CSTRING_TSCP( "TAIL-CALLS" ) ); CONSTANTEXP( ADR( c3817 ) ); c3813 = STRINGTOSYMBOL( CSTRING_TSCP( "STR-CALLS" ) ); CONSTANTEXP( ADR( c3813 ) ); c3339 = EMPTYLIST; t5209 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE-CLOSED" ) ); c3339 = CONS( t5209, c3339 ); c3339 = CONS( c4537, c3339 ); CONSTANTEXP( ADR( c3339 ) ); c3317 = STRINGTOSYMBOL( CSTRING_TSCP( "BOUNDID" ) ); CONSTANTEXP( ADR( c3317 ) ); c3189 = STRINGTOSYMBOL( CSTRING_TSCP( "OPTVARS" ) ); CONSTANTEXP( ADR( c3189 ) ); c3184 = STRINGTOSYMBOL( CSTRING_TSCP( "CALLS" ) ); CONSTANTEXP( ADR( c3184 ) ); c3181 = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL" ) ); CONSTANTEXP( ADR( c3181 ) ); c3165 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED-PROCEDURE" ) ); CONSTANTEXP( ADR( c3165 ) ); c3151 = STRINGTOSYMBOL( CSTRING_TSCP( "GENERATE" ) ); CONSTANTEXP( ADR( c3151 ) ); c3042 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY" ) ); CONSTANTEXP( ADR( c3042 ) ); c3015 = CSTRING_TSCP( t5210 ); CONSTANTEXP( ADR( c3015 ) ); c2958 = CSTRING_TSCP( t5211 ); CONSTANTEXP( ADR( c2958 ) ); c2955 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED" ) ); CONSTANTEXP( ADR( c2955 ) ); c2950 = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL" ) ); CONSTANTEXP( ADR( c2950 ) ); c2949 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2949 ) ); c2936 = STRINGTOSYMBOL( CSTRING_TSCP( "NESTIN" ) ); CONSTANTEXP( ADR( c2936 ) ); c2574 = STRINGTOSYMBOL( CSTRING_TSCP( "REQVARS" ) ); CONSTANTEXP( ADR( c2574 ) ); c2550 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2550 ) ); c2407 = EMPTYLIST; t5212 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); c2407 = CONS( t5212, c2407 ); CONSTANTEXP( ADR( c2407 ) ); c2223 = STRINGTOSYMBOL( CSTRING_TSCP( "$IF" ) ); CONSTANTEXP( ADR( c2223 ) ); c2207 = STRINGTOSYMBOL( CSTRING_TSCP( "$CALL" ) ); CONSTANTEXP( ADR( c2207 ) ); c2161 = STRINGTOSYMBOL( CSTRING_TSCP( "$SET" ) ); CONSTANTEXP( ADR( c2161 ) ); c2126 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); CONSTANTEXP( ADR( c2126 ) ); c2069 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2069 ) ); c2065 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); CONSTANTEXP( ADR( c2065 ) ); c2043 = STRINGTOSYMBOL( CSTRING_TSCP( "$DEFINE" ) ); CONSTANTEXP( ADR( c2043 ) ); } DEFTSCP( closeana_analyze_2dclosures1a_v ); DEFCSTRING( t5213, "ANALYZE-CLOSURES1A" ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); TSCP closeana_analyze_2dclosures1a( e2027 ) TSCP e2027; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5213 ); if ( NEQ( TSCPTAG( e2027 ), PAIRTAG ) ) goto L5215; X1 = PAIR_CAR( e2027 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2043 ) ) ) goto L5217; X3 = PAIR_CAR( e2027 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2043 ) ) ); if ( FALSE( X2 ) ) goto L5222; X3 = PAIR_CDR( e2027 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5226; scrt1__24__car_2derror( X3 ); L5226: X1 = PAIR_CAR( X3 ); goto L5223; L5222: X1 = X2; L5223: X4 = PAIR_CAR( e2027 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2043 ) ) ); if ( FALSE( X3 ) ) goto L5230; X2 = scrt1_caddr( e2027 ); goto L5231; L5230: X2 = X3; L5231: if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5233; X3 = PAIR_CAR( X2 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2065 ) ) ) goto L5235; if ( TRUE( plist_get( X1, c2069 ) ) ) goto L5238; X3 = SYMBOL_VALUE( name_2da_2dlambda_v ); X3 = UNKNOWNCALL( X3, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X3 ) )( X1, X2, PROCEDURE_CLOSURE( X3 ) ) ); L5238: POPSTACKTRACE( FALSEVALUE ); L5235: POPSTACKTRACE( FALSEVALUE ); L5233: POPSTACKTRACE( FALSEVALUE ); L5217: POPSTACKTRACE( FALSEVALUE ); L5215: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_analyze_2dclosures1b_v ); DEFCSTRING( t5240, "ANALYZE-CLOSURES1B" ); EXTERNTSCP( closeana_walk_2dlambda_2did_v ); EXTERNTSCPP( closeana_da_2dslots_a659d0e7, XAL1( TSCP ) ); EXTERNTSCP( closeana_da_2dslots_a659d0e7_v ); EXTERNTSCPP( closeana_walk_2d_24tree, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana_walk_2d_24tree_v ); EXTERNTSCPP( closeana_assign_2dlambdas, XAL1( TSCP ) ); EXTERNTSCP( closeana_assign_2dlambdas_v ); EXTERNTSCPP( closeana_inherit_2dclosed, XAL1( TSCP ) ); EXTERNTSCP( closeana_inherit_2dclosed_v ); TSCP closeana_analyze_2dclosures1b( e2125 ) TSCP e2125; { PUSHSTACKTRACE( t5240 ); closeana_walk_2dlambda_2did_v = c2126; closeana_da_2dslots_a659d0e7( e2125 ); closeana_walk_2d_24tree( closeana_assign_2dlambdas_v, e2125 ); closeana_da_2dslots_a659d0e7( e2125 ); POPSTACKTRACE( closeana_walk_2d_24tree( closeana_inherit_2dclosed_v, e2125 ) ); } DEFTSCP( closeana_analyze_2dclosures2_v ); DEFCSTRING( t5242, "ANALYZE-CLOSURES2" ); EXTERNTSCP( closeana_bda_2dlist_c52ab123_v ); EXTERNTSCPP( closeana_mark_2dtail_2dcalls, XAL1( TSCP ) ); EXTERNTSCP( closeana_mark_2dtail_2dcalls_v ); EXTERNTSCPP( closeana_count_2dcalls, XAL1( TSCP ) ); EXTERNTSCP( closeana_count_2dcalls_v ); EXTERNTSCPP( closeana_generate_2dlambdas, XAL1( TSCP ) ); EXTERNTSCP( closeana_generate_2dlambdas_v ); EXTERNTSCPP( closeana_display_2dclose, XAL1( TSCP ) ); EXTERNTSCP( closeana_display_2dclose_v ); TSCP closeana_analyze_2dclosures2( e2134 ) TSCP e2134; { PUSHSTACKTRACE( t5242 ); closeana_walk_2dlambda_2did_v = c2126; closeana_bda_2dlist_c52ab123_v = EMPTYLIST; closeana_da_2dslots_a659d0e7( e2134 ); closeana_walk_2d_24tree( closeana_mark_2dtail_2dcalls_v, e2134 ); closeana_walk_2d_24tree( closeana_count_2dcalls_v, e2134 ); closeana_generate_2dlambdas( closeana_bda_2dlist_c52ab123_v ); closeana_da_2dslots_a659d0e7( e2134 ); POPSTACKTRACE( closeana_walk_2d_24tree( closeana_display_2dclose_v, e2134 ) ); } DEFTSCP( closeana_walk_2d_24tree_v ); DEFCSTRING( t5244, "WALK-$TREE" ); EXTERNTSCPP( closeana_ree_2dlist_f50a563f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana_ree_2dlist_f50a563f_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); TSCP closeana_walk_2d_24tree( f2141, l2142 ) TSCP f2141, l2142; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5244 ); L5245: if ( NEQ( TSCPTAG( l2142 ), PAIRTAG ) ) goto L5246; X1 = f2141; X1 = UNKNOWNCALL( X1, 1 ); VIA( PROCEDURE_CODE( X1 ) )( l2142, PROCEDURE_CLOSURE( X1 ) ); X1 = BOOLEAN( EQ( TSCPTAG( l2142 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5260; X2 = PAIR_CAR( l2142 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2161 ) ) ) goto L5260; X3 = PAIR_CAR( l2142 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2161 ) ) ); if ( FALSE( X2 ) ) goto L5258; l2142 = scrt1_caddr( l2142 ); GOBACK( L5245 ); L5258: l2142 = X2; GOBACK( L5245 ); L5246: POPSTACKTRACE( FALSEVALUE ); L5260: X1 = BOOLEAN( EQ( TSCPTAG( l2142 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5272; X2 = PAIR_CAR( l2142 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2043 ) ) ) goto L5272; X3 = PAIR_CAR( l2142 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2043 ) ) ); if ( FALSE( X2 ) ) goto L5270; l2142 = scrt1_caddr( l2142 ); GOBACK( L5245 ); L5270: l2142 = X2; GOBACK( L5245 ); L5272: X1 = BOOLEAN( EQ( TSCPTAG( l2142 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5297; X2 = PAIR_CAR( l2142 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2065 ) ) ) goto L5297; X2 = closeana_walk_2dlambda_2did_v; X4 = PAIR_CAR( l2142 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2065 ) ) ); if ( FALSE( X3 ) ) goto L5283; X5 = PAIR_CDR( l2142 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5287; scrt1__24__car_2derror( X5 ); L5287: X4 = PAIR_CAR( X5 ); goto L5284; L5283: X4 = X3; L5284: closeana_walk_2dlambda_2did_v = X4; X5 = PAIR_CAR( l2142 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2065 ) ) ); if ( FALSE( X4 ) ) goto L5291; X5 = PAIR_CDR( l2142 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5295; scrt1__24__cdr_2derror( X5 ); L5295: X3 = PAIR_CDR( X5 ); goto L5292; L5291: X3 = X4; L5292: closeana_ree_2dlist_f50a563f( f2141, X3 ); POPSTACKTRACE( SET( closeana_walk_2dlambda_2did_v, X2 ) ); L5297: X1 = BOOLEAN( EQ( TSCPTAG( l2142 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5314; X2 = PAIR_CAR( l2142 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2207 ) ) ) goto L5314; X4 = PAIR_CAR( l2142 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X3 ) ) goto L5307; X2 = scrt1_caddr( l2142 ); goto L5308; L5307: X2 = X3; L5308: X5 = PAIR_CAR( l2142 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X4 ) ) goto L5312; X3 = scrt1_cdddr( l2142 ); goto L5313; L5312: X3 = X4; L5313: closeana_ree_2dlist_f50a563f( f2141, X3 ); l2142 = X2; GOBACK( L5245 ); L5314: X1 = PAIR_CAR( l2142 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2223 ) ) ) goto L5315; X1 = PAIR_CDR( l2142 ); POPSTACKTRACE( closeana_ree_2dlist_f50a563f( f2141, X1 ) ); L5315: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_ree_2dlist_f50a563f_v ); DEFCSTRING( t5319, "WALK-$TREE-LIST" ); TSCP closeana_ree_2dlist_f50a563f( f2380, f2381 ) TSCP f2380, f2381; { TSCP X2, X1; PUSHSTACKTRACE( t5319 ); X1 = f2381; L5322: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L5323; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L5327; scrt1__24__car_2derror( X1 ); L5327: X2 = PAIR_CAR( X1 ); closeana_walk_2d_24tree( f2380, X2 ); X1 = PAIR_CDR( X1 ); GOBACK( L5322 ); L5323: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_walk_2dlambda_2did_v ); DEFCSTRING( t5330, "WALK-LAMBDA-ID" ); DEFTSCP( closeana_walk_2dlambda_2dids_v ); DEFCSTRING( t5331, "WALK-LAMBDA-IDS" ); DEFTSCP( closeana__2dlexical_455a78ac_v ); DEFCSTRING( t5332, "WALK-LAMBDA-LEXICAL" ); DEFTSCP( closeana_bda_2dlist_c52ab123_v ); DEFCSTRING( t5333, "CLOSE-LAMBDA-LIST" ); DEFTSCP( closeana_assign_2dlambdas_v ); DEFCSTRING( t5334, "ASSIGN-LAMBDAS" ); EXTERNTSCPP( closeana_bdas_2darg_a7a3fa97, XAL1( TSCP ) ); EXTERNTSCP( closeana_bdas_2darg_a7a3fa97_v ); EXTERNTSCPP( scrt1_cadddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadddr_v ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); TSCP closeana_assign_2dlambdas( e2410 ) TSCP e2410; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5334 ); X1 = BOOLEAN( EQ( TSCPTAG( e2410 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5385; if ( EQ( TSCPTAG( e2410 ), PAIRTAG ) ) goto L5343; scrt1__24__car_2derror( e2410 ); L5343: X2 = PAIR_CAR( e2410 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2161 ) ) ) goto L5385; X5 = PAIR_CAR( e2410 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2161 ) ) ); if ( FALSE( X4 ) ) goto L5347; X3 = scrt1_caddr( e2410 ); goto L5348; L5347: X3 = X4; L5348: if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5350; X4 = PAIR_CAR( X3 ); X2 = BOOLEAN( NEQ( _S2CUINT( X4 ), _S2CUINT( c2065 ) ) ); goto L5351; L5350: X2 = TRUEVALUE; L5351: if ( TRUE( X2 ) ) goto L5357; X6 = PAIR_CAR( e2410 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2161 ) ) ); if ( FALSE( X5 ) ) goto L5362; X6 = PAIR_CDR( e2410 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L5366; scrt1__24__car_2derror( X6 ); L5366: X4 = PAIR_CAR( X6 ); goto L5363; L5362: X4 = X5; L5363: X3 = plist_get( X4, c2550 ); X7 = PAIR_CAR( e2410 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2161 ) ) ); if ( FALSE( X6 ) ) goto L5370; X5 = scrt1_caddr( e2410 ); goto L5371; L5370: X5 = X6; L5371: if ( NEQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5373; X7 = PAIR_CAR( X5 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2065 ) ) ); goto L5374; L5373: X6 = FALSEVALUE; L5374: if ( FALSE( X6 ) ) goto L5377; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5380; scrt1__24__cdr_2derror( X5 ); L5380: X7 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L5383; scrt1__24__car_2derror( X7 ); L5383: X4 = PAIR_CAR( X7 ); goto L5378; L5377: X4 = X6; L5378: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( X4 ) ) ) goto L5357; POPSTACKTRACE( FALSEVALUE ); L5385: X1 = BOOLEAN( EQ( TSCPTAG( e2410 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5413; if ( EQ( TSCPTAG( e2410 ), PAIRTAG ) ) goto L5393; scrt1__24__car_2derror( e2410 ); L5393: X2 = PAIR_CAR( e2410 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2065 ) ) ) goto L5413; X4 = PAIR_CAR( e2410 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2065 ) ) ); if ( FALSE( X3 ) ) goto L5397; X4 = PAIR_CDR( e2410 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5401; scrt1__24__cdr_2derror( X4 ); L5401: X2 = PAIR_CDR( X4 ); goto L5398; L5397: X2 = X3; L5398: X3 = X2; L5405: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L5406; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5410; scrt1__24__car_2derror( X3 ); L5410: X4 = PAIR_CAR( X3 ); closeana_bdas_2darg_a7a3fa97( X4 ); X3 = PAIR_CDR( X3 ); GOBACK( L5405 ); L5406: POPSTACKTRACE( FALSEVALUE ); L5413: X1 = BOOLEAN( EQ( TSCPTAG( e2410 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5440; if ( EQ( TSCPTAG( e2410 ), PAIRTAG ) ) goto L5421; scrt1__24__car_2derror( e2410 ); L5421: X2 = PAIR_CAR( e2410 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2223 ) ) ) goto L5440; X4 = PAIR_CAR( e2410 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2223 ) ) ); if ( FALSE( X3 ) ) goto L5426; X4 = PAIR_CDR( e2410 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5430; scrt1__24__car_2derror( X4 ); L5430: X2 = PAIR_CAR( X4 ); goto L5427; L5426: X2 = X3; L5427: closeana_bdas_2darg_a7a3fa97( X2 ); X4 = PAIR_CAR( e2410 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2223 ) ) ); if ( FALSE( X3 ) ) goto L5434; X2 = scrt1_caddr( e2410 ); goto L5435; L5434: X2 = X3; L5435: closeana_bdas_2darg_a7a3fa97( X2 ); X4 = PAIR_CAR( e2410 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2223 ) ) ); if ( FALSE( X3 ) ) goto L5438; X2 = scrt1_cadddr( e2410 ); goto L5439; L5438: X2 = X3; L5439: POPSTACKTRACE( closeana_bdas_2darg_a7a3fa97( X2 ) ); L5440: if ( NEQ( TSCPTAG( e2410 ), PAIRTAG ) ) goto L5441; X1 = PAIR_CAR( e2410 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2207 ) ) ) goto L5443; X3 = PAIR_CAR( e2410 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X2 ) ) goto L5448; X1 = scrt1_caddr( e2410 ); goto L5449; L5448: X1 = X2; L5449: X2 = BOOLEAN( EQ( TSCPTAG( X1 ), PAIRTAG ) ); if ( FALSE( X2 ) ) goto L5490; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L5458; scrt1__24__car_2derror( X1 ); L5458: X3 = PAIR_CAR( X1 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2065 ) ) ) goto L5490; X6 = PAIR_CAR( X1 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2065 ) ) ); if ( FALSE( X5 ) ) goto L5462; X6 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L5466; scrt1__24__car_2derror( X6 ); L5466: X4 = PAIR_CAR( X6 ); goto L5463; L5462: X4 = X5; L5463: X3 = plist_get( X4, c2574 ); X6 = PAIR_CAR( e2410 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X5 ) ) goto L5470; X4 = scrt1_cdddr( e2410 ); goto L5471; L5470: X4 = X5; L5471: X5 = X3; X6 = X4; L5474: if ( FALSE( X5 ) ) goto L5475; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5478; scrt1__24__car_2derror( X5 ); L5478: X7 = PAIR_CAR( X5 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L5481; scrt1__24__car_2derror( X6 ); L5481: X8 = PAIR_CAR( X6 ); if ( NOT( AND( EQ( TSCPTAG( X8 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X8 ), SYMBOLTAG ) ) ) ) goto L5486; if ( FALSE( plist_get( X8, c2550 ) ) ) goto L5486; X9 = plist_get( X8, c2550 ); plist_put( X7, c2550, X9 ); L5486: X9 = PAIR_CDR( X5 ); X6 = PAIR_CDR( X6 ); X5 = X9; GOBACK( L5474 ); L5475: POPSTACKTRACE( FALSEVALUE ); L5443: POPSTACKTRACE( FALSEVALUE ); L5441: POPSTACKTRACE( FALSEVALUE ); L5490: X3 = PAIR_CAR( e2410 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X2 ) ) goto L5493; X1 = scrt1_cdddr( e2410 ); goto L5494; L5493: X1 = X2; L5494: X2 = X1; L5497: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L5498; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5502; scrt1__24__car_2derror( X2 ); L5502: X3 = PAIR_CAR( X2 ); closeana_bdas_2darg_a7a3fa97( X3 ); X2 = PAIR_CDR( X2 ); GOBACK( L5497 ); L5498: POPSTACKTRACE( FALSEVALUE ); L5357: X3 = PAIR_CAR( e2410 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2161 ) ) ); if ( FALSE( X2 ) ) goto L5507; X1 = scrt1_caddr( e2410 ); goto L5508; L5507: X1 = X2; L5508: POPSTACKTRACE( closeana_bdas_2darg_a7a3fa97( X1 ) ); } DEFTSCP( closeana_bdas_2darg_a7a3fa97_v ); DEFCSTRING( t5509, "ASSIGN-LAMBDAS-ARG" ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCPP( closeana_dprocedure_40e51573, XAL1( TSCP ) ); EXTERNTSCP( closeana_dprocedure_40e51573_v ); TSCP closeana_bdas_2darg_a7a3fa97( e2924 ) TSCP e2924; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5509 ); if ( NOT( AND( EQ( TSCPTAG( e2924 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2924 ), SYMBOLTAG ) ) ) ) goto L5511; X2 = plist_get( e2924, c2550 ); goto L5512; L5511: X2 = FALSEVALUE; L5512: if ( FALSE( X2 ) ) goto L5514; X1 = X2; goto L5521; L5514: if ( NEQ( TSCPTAG( e2924 ), PAIRTAG ) ) goto L5516; X4 = PAIR_CAR( e2924 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2065 ) ) ); goto L5517; L5516: X3 = FALSEVALUE; L5517: if ( FALSE( X3 ) ) goto L5520; if ( EQ( TSCPTAG( e2924 ), PAIRTAG ) ) goto L5523; scrt1__24__cdr_2derror( e2924 ); L5523: X4 = PAIR_CDR( e2924 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5526; scrt1__24__car_2derror( X4 ); L5526: X1 = PAIR_CAR( X4 ); goto L5521; L5520: X1 = X3; L5521: if ( FALSE( X1 ) ) goto L5529; X3 = plist_get( X1, c2936 ); X2 = BOOLEAN( NEQ( _S2CUINT( X3 ), _S2CUINT( c2126 ) ) ); if ( TRUE( X2 ) ) goto L5536; if ( NOT( AND( EQ( TSCPTAG( e2924 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2924 ), SYMBOLTAG ) ) ) ) goto L5543; X3 = plist_get( e2924, c2949 ); if ( EQ( _S2CUINT( X3 ), _S2CUINT( c2950 ) ) ) goto L5543; L5536: plist_put( X1, c2955, TRUEVALUE ); X3 = SYMBOL_VALUE( log_3f_v ); X3 = UNKNOWNCALL( X3, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X3 ) )( c2955, PROCEDURE_CLOSURE( X3 ) ) ) ) goto L5543; X3 = SYMBOL_VALUE( sc_2dicode_v ); X4 = CONS( X1, EMPTYLIST ); scrt6_format( X3, CONS( c2958, X4 ) ); L5543: POPSTACKTRACE( closeana_dprocedure_40e51573( X1 ) ); L5529: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_inherit_2dclosed_v ); DEFCSTRING( t5545, "INHERIT-CLOSED" ); EXTERNTSCPP( closeana__2dlexical_34c6288f, XAL1( TSCP ) ); EXTERNTSCP( closeana__2dlexical_34c6288f_v ); TSCP closeana_inherit_2dclosed( e3004 ) TSCP e3004; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t5545 ); if ( NEQ( TSCPTAG( e3004 ), PAIRTAG ) ) goto L5547; X3 = PAIR_CAR( e3004 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2065 ) ) ); goto L5548; L5547: X2 = FALSEVALUE; L5548: if ( FALSE( X2 ) ) goto L5551; if ( EQ( TSCPTAG( e3004 ), PAIRTAG ) ) goto L5554; scrt1__24__cdr_2derror( e3004 ); L5554: X3 = PAIR_CDR( e3004 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5557; scrt1__24__car_2derror( X3 ); L5557: X1 = PAIR_CAR( X3 ); goto L5552; L5551: X1 = X2; L5552: if ( FALSE( X1 ) ) goto L5560; if ( FALSE( plist_get( X1, c2955 ) ) ) goto L5562; X2 = closeana__2dlexical_34c6288f( X1 ); X3 = SYMBOL_VALUE( log_3f_v ); X3 = UNKNOWNCALL( X3, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X3 ) )( c2955, PROCEDURE_CLOSURE( X3 ) ) ) ) goto L5565; X3 = SYMBOL_VALUE( sc_2dicode_v ); X4 = CONS( X2, EMPTYLIST ); X4 = CONS( X1, X4 ); scrt6_format( X3, CONS( c3015, X4 ) ); L5565: X3 = X2; L5568: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L5569; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5573; scrt1__24__car_2derror( X3 ); L5573: X4 = PAIR_CAR( X3 ); plist_put( X4, c3042, TRUEVALUE ); X3 = PAIR_CDR( X3 ); GOBACK( L5568 ); L5569: POPSTACKTRACE( FALSEVALUE ); L5562: POPSTACKTRACE( FALSEVALUE ); L5560: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana__2dchecked_ed79e461_v ); DEFCSTRING( t5576, "INDIRECT-LAMBDA-CHECKED" ); DEFTSCP( closeana__2dlexical_34c6288f_v ); DEFCSTRING( t5577, "INDIRECT-LAMBDA-LEXICAL" ); EXTERNTSCPP( closeana_2dlexical1_2ced58a3, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( closeana_2dlexical1_2ced58a3_v ); TSCP closeana__2dlexical_34c6288f( l3077 ) TSCP l3077; { PUSHSTACKTRACE( t5577 ); closeana__2dchecked_ed79e461_v = EMPTYLIST; POPSTACKTRACE( closeana_2dlexical1_2ced58a3( l3077, EMPTYLIST, EMPTYLIST ) ); } DEFTSCP( closeana_2dlexical1_2ced58a3_v ); DEFCSTRING( t5579, "INDIRECT-LAMBDA-LEXICAL1" ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP closeana_2dlexical1_2ced58a3( l3080, l3081, b3082 ) TSCP l3080, l3081, b3082; { TSCP X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5579 ); if ( TRUE( scrt1_memq( l3080, closeana__2dchecked_ed79e461_v ) ) ) goto L5581; X3 = plist_get( l3080, c2574 ); X4 = plist_get( l3080, c3189 ); X2 = scrt1_append_2dtwo( X3, X4 ); X1 = scrt1_append_2dtwo( X2, b3082 ); X2 = plist_get( l3080, c3184 ); X2 = CONS( X2, EMPTYLIST ); X4 = plist_get( l3080, c3181 ); X5 = X4; X6 = l3081; L5587: if ( FALSE( X5 ) ) goto L5589; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5592; scrt1__24__car_2derror( X5 ); L5592: X7 = PAIR_CAR( X5 ); X8 = scrt1_memq( X7, X6 ); if ( TRUE( X8 ) ) goto L5599; X9 = scrt1_memq( X7, X1 ); if ( TRUE( X9 ) ) goto L5599; X10 = plist_get( X7, c2550 ); if ( FALSE( X10 ) ) goto L5623; X12 = plist_get( X7, c2550 ); X11 = plist_get( X12, c3151 ); if ( FALSE( X11 ) ) goto L5623; X13 = plist_get( X7, c2550 ); X12 = plist_get( X13, c3151 ); if ( EQ( _S2CUINT( X12 ), _S2CUINT( c3165 ) ) ) goto L5623; X12 = X7; if ( TRUE( scrt1_memq( X12, PAIR_CAR( X2 ) ) ) ) goto L5619; X14 = plist_get( X12, c2550 ); X13 = sc_cons( X14, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X13 ); L5619: if ( TRUE( TRUEVALUE ) ) goto L5599; goto L5623; L5589: X3 = X6; goto L5624; L5623: X8 = PAIR_CDR( X5 ); X6 = sc_cons( X7, X6 ); X5 = X8; GOBACK( L5587 ); L5599: X8 = PAIR_CDR( X5 ); X5 = X8; GOBACK( L5587 ); L5624: closeana__2dchecked_ed79e461_v = sc_cons( l3080, closeana__2dchecked_ed79e461_v ); X4 = PAIR_CAR( X2 ); X5 = X4; X6 = X3; L5630: if ( FALSE( X5 ) ) goto L5631; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5634; scrt1__24__car_2derror( X5 ); L5634: X7 = PAIR_CAR( X5 ); X8 = plist_get( X7, c2936 ); if ( NEQ( _S2CUINT( X8 ), _S2CUINT( c2126 ) ) ) goto L5637; X8 = PAIR_CDR( X5 ); X5 = X8; GOBACK( L5630 ); L5637: X8 = PAIR_CDR( X5 ); X6 = closeana_2dlexical1_2ced58a3( X7, X6, X1 ); X5 = X8; GOBACK( L5630 ); L5631: POPSTACKTRACE( X6 ); L5581: POPSTACKTRACE( l3081 ); } DEFTSCP( closeana_da_2dslots_a659d0e7_v ); DEFCSTRING( t5641, "UPDATE-LAMBDA-SLOTS" ); EXTERNTSCPP( closeana_mergeq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana_mergeq_v ); TSCP closeana_da_2dslots_a659d0e7( e3191 ) TSCP e3191; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5641 ); L5642: if ( NEQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5643; X2 = PAIR_CAR( e3191 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2161 ) ) ); goto L5644; L5643: X1 = FALSEVALUE; L5644: if ( TRUE( X1 ) ) goto L5650; if ( NEQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5657; X2 = PAIR_CAR( e3191 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2223 ) ) ) goto L5657; L5650: if ( EQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5659; scrt1__24__cdr_2derror( e3191 ); L5659: X1 = PAIR_CDR( e3191 ); X2 = X1; L5663: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L5664; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5668; scrt1__24__car_2derror( X2 ); L5668: X3 = PAIR_CAR( X2 ); closeana_da_2dslots_a659d0e7( X3 ); X2 = PAIR_CDR( X2 ); GOBACK( L5663 ); L5664: POPSTACKTRACE( FALSEVALUE ); L5657: X1 = BOOLEAN( EQ( TSCPTAG( e3191 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5685; if ( EQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5678; scrt1__24__car_2derror( e3191 ); L5678: X2 = PAIR_CAR( e3191 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2043 ) ) ) goto L5685; closeana_walk_2dlambda_2did_v = c2126; closeana_walk_2dlambda_2dids_v = c2407; closeana__2dlexical_455a78ac_v = EMPTYLIST; X3 = PAIR_CAR( e3191 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2043 ) ) ); if ( FALSE( X2 ) ) goto L5683; e3191 = scrt1_caddr( e3191 ); GOBACK( L5642 ); L5683: e3191 = X2; GOBACK( L5642 ); L5685: if ( NEQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5686; X2 = PAIR_CAR( e3191 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2065 ) ) ); goto L5687; L5686: X1 = FALSEVALUE; L5687: if ( FALSE( X1 ) ) goto L5707; if ( NEQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5695; X4 = PAIR_CAR( e3191 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2065 ) ) ); goto L5696; L5695: X3 = FALSEVALUE; L5696: if ( FALSE( X3 ) ) goto L5699; if ( EQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5702; scrt1__24__cdr_2derror( e3191 ); L5702: X4 = PAIR_CDR( e3191 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5705; scrt1__24__car_2derror( X4 ); L5705: X2 = PAIR_CAR( X4 ); goto L5700; L5699: X2 = X3; L5700: if ( TRUE( scrt1_memq( X2, closeana_walk_2dlambda_2dids_v ) ) ) goto L5707; if ( NEQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5709; X4 = PAIR_CAR( e3191 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2065 ) ) ); goto L5710; L5709: X3 = FALSEVALUE; L5710: if ( FALSE( X3 ) ) goto L5713; if ( EQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5716; scrt1__24__cdr_2derror( e3191 ); L5716: X4 = PAIR_CDR( e3191 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5719; scrt1__24__car_2derror( X4 ); L5719: X2 = PAIR_CAR( X4 ); goto L5714; L5713: X2 = X3; L5714: closeana_walk_2dlambda_2dids_v = sc_cons( X2, closeana_walk_2dlambda_2dids_v ); X2 = closeana_walk_2dlambda_2dids_v; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5722; scrt1__24__car_2derror( X2 ); L5722: closeana_walk_2dlambda_2did_v = PAIR_CAR( X2 ); plist_put( closeana_walk_2dlambda_2did_v, c3184, EMPTYLIST ); X2 = EMPTYLIST; X3 = closeana__2dlexical_455a78ac_v; X2 = CONS( X2, EMPTYLIST ); if ( NEQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5725; X6 = PAIR_CAR( e3191 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2065 ) ) ); goto L5726; L5725: X5 = FALSEVALUE; L5726: if ( FALSE( X5 ) ) goto L5729; if ( EQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5732; scrt1__24__cdr_2derror( e3191 ); L5732: X6 = PAIR_CDR( e3191 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L5735; scrt1__24__cdr_2derror( X6 ); L5735: X4 = PAIR_CDR( X6 ); goto L5730; L5729: X4 = X5; L5730: X5 = X4; L5739: if ( EQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L5740; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5744; scrt1__24__car_2derror( X5 ); L5744: X6 = PAIR_CAR( X5 ); closeana__2dlexical_455a78ac_v = EMPTYLIST; closeana_da_2dslots_a659d0e7( X6 ); X7 = closeana__2dlexical_455a78ac_v; X8 = X7; L5749: if ( EQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L5766; if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L5753; scrt1__24__car_2derror( X8 ); L5753: X10 = PAIR_CAR( X8 ); X9 = scrt1_memq( X10, PAIR_CAR( X2 ) ); if ( TRUE( X9 ) ) goto L5759; X11 = PAIR_CAR( X8 ); X10 = plist_get( X11, c3317 ); if ( EQ( _S2CUINT( X10 ), _S2CUINT( closeana_walk_2dlambda_2did_v ) ) ) goto L5759; X11 = PAIR_CAR( X8 ); X10 = sc_cons( X11, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X10 ); X8 = PAIR_CDR( X8 ); GOBACK( L5749 ); L5759: X8 = PAIR_CDR( X8 ); GOBACK( L5749 ); L5766: X5 = PAIR_CDR( X5 ); GOBACK( L5739 ); L5740: plist_put( closeana_walk_2dlambda_2did_v, c3181, PAIR_CAR( X2 ) ); closeana__2dlexical_455a78ac_v = X3; X4 = PAIR_CAR( X2 ); X5 = X4; L5771: if ( EQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L5772; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5776; scrt1__24__car_2derror( X5 ); L5776: X6 = PAIR_CAR( X5 ); closeana__2dlexical_455a78ac_v = closeana_mergeq( X6, closeana__2dlexical_455a78ac_v ); X5 = PAIR_CDR( X5 ); GOBACK( L5771 ); L5772: X2 = closeana_walk_2dlambda_2dids_v; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5781; scrt1__24__cdr_2derror( X2 ); L5781: closeana_walk_2dlambda_2dids_v = PAIR_CDR( X2 ); X2 = closeana_walk_2dlambda_2dids_v; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5784; scrt1__24__car_2derror( X2 ); L5784: POPSTACKTRACE( SET( closeana_walk_2dlambda_2did_v, PAIR_CAR( X2 ) ) ); L5707: X1 = BOOLEAN( EQ( TSCPTAG( e3191 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5839; if ( EQ( TSCPTAG( e3191 ), PAIRTAG ) ) goto L5793; scrt1__24__car_2derror( e3191 ); L5793: X2 = PAIR_CAR( e3191 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2207 ) ) ) goto L5839; X4 = PAIR_CAR( e3191 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X3 ) ) goto L5797; X2 = scrt1_caddr( e3191 ); goto L5798; L5797: X2 = X3; L5798: if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5800; X6 = PAIR_CAR( X2 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2065 ) ) ); goto L5801; L5800: X5 = FALSEVALUE; L5801: if ( FALSE( X5 ) ) goto L5804; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5807; scrt1__24__cdr_2derror( X2 ); L5807: X6 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L5810; scrt1__24__car_2derror( X6 ); L5810: X4 = PAIR_CAR( X6 ); goto L5805; L5804: X4 = X5; L5805: if ( FALSE( X4 ) ) goto L5813; X3 = X4; goto L5816; L5813: if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L5815; X3 = plist_get( X2, c2550 ); goto L5816; L5815: X3 = FALSEVALUE; L5816: if ( FALSE( X3 ) ) goto L5823; X5 = plist_get( closeana_walk_2dlambda_2did_v, c3184 ); X4 = closeana_mergeq( X3, X5 ); plist_put( closeana_walk_2dlambda_2did_v, c3184, X4 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L5823; X4 = plist_get( X3, c3151 ); if ( FALSE( scrt1_memq( X4, c3339 ) ) ) goto L5823; X4 = plist_get( X3, c2065 ); closeana_da_2dslots_a659d0e7( X4 ); L5823: closeana_da_2dslots_a659d0e7( X2 ); X6 = PAIR_CAR( e3191 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X5 ) ) goto L5827; X4 = scrt1_cdddr( e3191 ); goto L5828; L5827: X4 = X5; L5828: X5 = X4; L5831: if ( EQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L5832; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5836; scrt1__24__car_2derror( X5 ); L5836: X6 = PAIR_CAR( X5 ); closeana_da_2dslots_a659d0e7( X6 ); X5 = PAIR_CDR( X5 ); GOBACK( L5831 ); L5832: POPSTACKTRACE( FALSEVALUE ); L5839: if ( NOT( AND( EQ( TSCPTAG( e3191 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e3191 ), SYMBOLTAG ) ) ) ) goto L5840; if ( FALSE( plist_get( e3191, c3317 ) ) ) goto L5842; X1 = plist_get( e3191, c3317 ); if ( EQ( _S2CUINT( X1 ), _S2CUINT( closeana_walk_2dlambda_2did_v ) ) ) goto L5844; POPSTACKTRACE( SET( closeana__2dlexical_455a78ac_v, closeana_mergeq( e3191, closeana__2dlexical_455a78ac_v ) ) ); L5844: POPSTACKTRACE( FALSEVALUE ); L5842: POPSTACKTRACE( FALSEVALUE ); L5840: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_mergeq_v ); DEFCSTRING( t5846, "MERGEQ" ); TSCP closeana_mergeq( x3671, y3672 ) TSCP x3671, y3672; { PUSHSTACKTRACE( t5846 ); if ( EQ( _S2CUINT( x3671 ), _S2CUINT( EMPTYLIST ) ) ) goto L5848; if ( TRUE( scrt1_memq( x3671, y3672 ) ) ) goto L5850; POPSTACKTRACE( sc_cons( x3671, y3672 ) ); L5850: POPSTACKTRACE( y3672 ); L5848: POPSTACKTRACE( y3672 ); } DEFTSCP( closeana_mark_2dtail_2dcalls_v ); DEFCSTRING( t5852, "MARK-TAIL-CALLS" ); EXTERNTSCPP( closeana_mark_2dtail_2dcalls1, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana_mark_2dtail_2dcalls1_v ); EXTERNTSCPP( scrt1_last_2dpair, XAL1( TSCP ) ); EXTERNTSCP( scrt1_last_2dpair_v ); EXTERNTSCPP( closeana_lambda_2dis_2dinline, XAL1( TSCP ) ); EXTERNTSCP( closeana_lambda_2dis_2dinline_v ); TSCP closeana_mark_2dtail_2dcalls( e3679 ) TSCP e3679; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5852 ); X1 = BOOLEAN( EQ( TSCPTAG( e3679 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L5887; if ( EQ( TSCPTAG( e3679 ), PAIRTAG ) ) goto L5861; scrt1__24__car_2derror( e3679 ); L5861: X2 = PAIR_CAR( e3679 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2065 ) ) ) goto L5887; X4 = PAIR_CAR( e3679 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2065 ) ) ); if ( FALSE( X3 ) ) goto L5865; X4 = PAIR_CDR( e3679 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5869; scrt1__24__car_2derror( X4 ); L5869: X2 = PAIR_CAR( X4 ); goto L5866; L5865: X2 = X3; L5866: closeana_bda_2dlist_c52ab123_v = sc_cons( X2, closeana_bda_2dlist_c52ab123_v ); plist_put( X2, c3813, EMPTYLIST ); plist_put( X2, c3817, EMPTYLIST ); plist_put( X2, c3821, EMPTYLIST ); X3 = plist_get( X2, c2936 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2126 ) ) ) goto L5872; if ( TRUE( plist_get( X2, c3151 ) ) ) goto L5873; closeana_dprocedure_40e51573( X2 ); goto L5873; L5872: plist_put( X2, c2065, e3679 ); L5873: X7 = PAIR_CAR( e3679 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2065 ) ) ); if ( FALSE( X6 ) ) goto L5878; X7 = PAIR_CDR( e3679 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L5882; scrt1__24__cdr_2derror( X7 ); L5882: X5 = PAIR_CDR( X7 ); goto L5879; L5878: X5 = X6; L5879: X4 = scrt1_last_2dpair( X5 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L5885; scrt1__24__car_2derror( X4 ); L5885: X3 = PAIR_CAR( X4 ); POPSTACKTRACE( closeana_mark_2dtail_2dcalls1( X3, X2 ) ); L5887: if ( NEQ( TSCPTAG( e3679 ), PAIRTAG ) ) goto L5888; X1 = PAIR_CAR( e3679 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2207 ) ) ) goto L5890; X3 = PAIR_CAR( e3679 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X2 ) ) goto L5895; X1 = scrt1_caddr( e3679 ); goto L5896; L5895: X1 = X2; L5896: if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L5898; X2 = PAIR_CAR( X1 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2065 ) ) ) goto L5900; X5 = PAIR_CAR( e3679 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X4 ) ) goto L5905; X3 = scrt1_caddr( e3679 ); goto L5906; L5905: X3 = X4; L5906: if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5908; X5 = PAIR_CAR( X3 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2065 ) ) ); goto L5909; L5908: X4 = FALSEVALUE; L5909: if ( FALSE( X4 ) ) goto L5912; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5915; scrt1__24__cdr_2derror( X3 ); L5915: X5 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5918; scrt1__24__car_2derror( X5 ); L5918: X2 = PAIR_CAR( X5 ); goto L5913; L5912: X2 = X4; L5913: plist_put( X2, c2936, closeana_walk_2dlambda_2did_v ); POPSTACKTRACE( closeana_lambda_2dis_2dinline( X2 ) ); L5900: POPSTACKTRACE( FALSEVALUE ); L5898: POPSTACKTRACE( FALSEVALUE ); L5890: POPSTACKTRACE( FALSEVALUE ); L5888: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_mark_2dtail_2dcalls1_v ); DEFCSTRING( t5921, "MARK-TAIL-CALLS1" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP closeana_mark_2dtail_2dcalls1( e3900, e3901 ) TSCP e3900, e3901; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5921 ); L5922: if ( NEQ( TSCPTAG( e3900 ), PAIRTAG ) ) goto L5923; X2 = PAIR_CAR( e3900 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2207 ) ) ); goto L5924; L5923: X1 = FALSEVALUE; L5924: if ( FALSE( X1 ) ) goto L5943; if ( NEQ( TSCPTAG( e3900 ), PAIRTAG ) ) goto L5945; X2 = PAIR_CAR( e3900 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2207 ) ) ) goto L5945; X2 = PAIR_CDR( e3900 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L5939; scrt1__24__car_2derror( X2 ); L5939: if ( FALSE( PAIR_CAR( X2 ) ) ) goto L5945; L5943: if ( NEQ( TSCPTAG( e3900 ), PAIRTAG ) ) goto L5946; X1 = PAIR_CAR( e3900 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2223 ) ) ) goto L5948; X3 = PAIR_CAR( e3900 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2223 ) ) ); if ( FALSE( X2 ) ) goto L5954; X1 = scrt1_caddr( e3900 ); goto L5955; L5954: X1 = X2; L5955: closeana_mark_2dtail_2dcalls1( X1, e3901 ); X3 = PAIR_CAR( e3900 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2223 ) ) ); if ( FALSE( X2 ) ) goto L5958; X1 = scrt1_cadddr( e3900 ); goto L5959; L5958: X1 = X2; L5959: e3900 = X1; GOBACK( L5922 ); L5948: POPSTACKTRACE( FALSEVALUE ); L5946: POPSTACKTRACE( FALSEVALUE ); L5945: if ( EQ( TSCPTAG( e3900 ), PAIRTAG ) ) goto L5962; scrt1__24__cdr_2derror( e3900 ); L5962: X1 = PAIR_CDR( e3900 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L5965; scdebug_error( c4019, c4020, CONS( X1, EMPTYLIST ) ); L5965: SETGEN( PAIR_CAR( X1 ), e3901 ); X3 = PAIR_CAR( e3900 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X2 ) ) goto L5969; X1 = scrt1_caddr( e3900 ); goto L5970; L5969: X1 = X2; L5970: if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L5972; X2 = PAIR_CAR( X1 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2065 ) ) ) goto L5974; X5 = PAIR_CAR( e3900 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X4 ) ) goto L5980; X3 = scrt1_caddr( e3900 ); goto L5981; L5980: X3 = X4; L5981: if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5983; X5 = PAIR_CAR( X3 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2065 ) ) ); goto L5984; L5983: X4 = FALSEVALUE; L5984: if ( FALSE( X4 ) ) goto L5987; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L5990; scrt1__24__cdr_2derror( X3 ); L5990: X5 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L5993; scrt1__24__car_2derror( X5 ); L5993: X2 = PAIR_CAR( X5 ); goto L5988; L5987: X2 = X4; L5988: plist_put( X2, c4065, e3901 ); X7 = PAIR_CAR( e3900 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X6 ) ) goto L5997; X5 = scrt1_caddr( e3900 ); goto L5998; L5997: X5 = X6; L5998: if ( NEQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6000; X7 = PAIR_CAR( X5 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2065 ) ) ); goto L6001; L6000: X6 = FALSEVALUE; L6001: if ( FALSE( X6 ) ) goto L6004; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6007; scrt1__24__cdr_2derror( X5 ); L6007: X7 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6010; scrt1__24__cdr_2derror( X7 ); L6010: X4 = PAIR_CDR( X7 ); goto L6005; L6004: X4 = X6; L6005: X3 = scrt1_last_2dpair( X4 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6013; scrt1__24__car_2derror( X3 ); L6013: X2 = PAIR_CAR( X3 ); e3900 = X2; GOBACK( L5922 ); L5974: POPSTACKTRACE( FALSEVALUE ); L5972: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_count_2dcalls_v ); DEFCSTRING( t6015, "COUNT-CALLS" ); TSCP closeana_count_2dcalls( e4175 ) TSCP e4175; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6015 ); if ( NEQ( TSCPTAG( e4175 ), PAIRTAG ) ) goto L6017; X3 = PAIR_CAR( e4175 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2207 ) ) ) goto L6019; X4 = PAIR_CAR( e4175 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X3 ) ) goto L6024; X2 = scrt1_caddr( e4175 ); goto L6018; L6024: X2 = X3; goto L6018; L6019: X2 = FALSEVALUE; goto L6018; L6017: X2 = FALSEVALUE; L6018: if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L6027; X1 = plist_get( X2, c2550 ); goto L6028; L6027: X1 = FALSEVALUE; L6028: if ( FALSE( X1 ) ) goto L6030; if ( TRUE( plist_get( X2, c4186 ) ) ) goto L6032; if ( NEQ( TSCPTAG( e4175 ), PAIRTAG ) ) goto L6036; X5 = PAIR_CAR( e4175 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2207 ) ) ); goto L6037; L6036: X4 = FALSEVALUE; L6037: if ( FALSE( X4 ) ) goto L6040; if ( EQ( TSCPTAG( e4175 ), PAIRTAG ) ) goto L6043; scrt1__24__cdr_2derror( e4175 ); L6043: X5 = PAIR_CDR( e4175 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6046; scrt1__24__car_2derror( X5 ); L6046: X3 = PAIR_CAR( X5 ); goto L6041; L6040: X3 = X4; L6041: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( X1 ) ) ) goto L6034; X4 = plist_get( X1, c3813 ); X3 = sc_cons( closeana_walk_2dlambda_2did_v, X4 ); POPSTACKTRACE( plist_put( X1, c3813, X3 ) ); L6034: if ( NEQ( TSCPTAG( e4175 ), PAIRTAG ) ) goto L6048; X4 = PAIR_CAR( e4175 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2207 ) ) ); goto L6049; L6048: X3 = FALSEVALUE; L6049: if ( FALSE( X3 ) ) goto L6072; if ( EQ( TSCPTAG( e4175 ), PAIRTAG ) ) goto L6056; scrt1__24__cdr_2derror( e4175 ); L6056: X4 = PAIR_CDR( e4175 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6059; scrt1__24__car_2derror( X4 ); L6059: if ( FALSE( PAIR_CAR( X4 ) ) ) goto L6072; X11 = PAIR_CAR( e4175 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2207 ) ) ); if ( FALSE( X10 ) ) goto L6065; X11 = PAIR_CDR( e4175 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L6069; scrt1__24__car_2derror( X11 ); L6069: X9 = PAIR_CAR( X11 ); goto L6066; L6065: X9 = X10; L6066: X8 = sc_cons( X9, EMPTYLIST ); X7 = sc_cons( closeana_walk_2dlambda_2did_v, X8 ); X6 = X7; X7 = plist_get( X1, c3817 ); X5 = sc_cons( X6, X7 ); POPSTACKTRACE( plist_put( X1, c3817, X5 ) ); L6032: POPSTACKTRACE( FALSEVALUE ); L6030: POPSTACKTRACE( FALSEVALUE ); L6072: X3 = plist_get( X1, c3821 ); X2 = sc_cons( closeana_walk_2dlambda_2did_v, X3 ); POPSTACKTRACE( plist_put( X1, c3821, X2 ) ); } DEFTSCP( closeana_generate_2dlambdas_v ); DEFCSTRING( t6073, "GENERATE-LAMBDAS" ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt1_cadar, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadar_v ); EXTERNTSCPP( closeana_la_2dnestin_2dlb_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana_la_2dnestin_2dlb_3f_v ); EXTERNTSCPP( closeana_generate_2dtails, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana_generate_2dtails_v ); TSCP closeana_generate_2dlambdas( l4341 ) TSCP l4341; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6073 ); X1 = EMPTYLIST; X1 = CONS( X1, EMPTYLIST ); X2 = l4341; L6077: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L6078; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6082; scrt1__24__car_2derror( X2 ); L6082: X3 = PAIR_CAR( X2 ); X5 = plist_get( X3, c3821 ); X4 = plist_get( X3, c3817 ); if ( TRUE( plist_get( X3, c3151 ) ) ) goto L6121; X7 = scrt1_length( X5 ); X8 = scrt1_length( X4 ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( X8 ) ), 3 ) ) goto L6089; X6 = _TSCP( IPLUS( _S2CINT( X7 ), _S2CINT( X8 ) ) ); goto L6090; L6089: X6 = scrt2__2b_2dtwo( X7, X8 ); L6090: if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X6 ) ), 3 ) ) goto L6093; if ( EQ( _S2CUINT( _TSCP( 4 ) ), _S2CUINT( X6 ) ) ) goto L6097; goto L6098; L6093: if ( FALSE( scrt2__3d_2dtwo( _TSCP( 4 ), X6 ) ) ) goto L6098; L6097: if ( FALSE( X4 ) ) goto L6103; X6 = scrt1_cadar( X4 ); plist_put( X3, c4065, X6 ); L6103: if ( FALSE( X5 ) ) goto L6105; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6108; scrt1__24__car_2derror( X5 ); L6108: X6 = PAIR_CAR( X5 ); goto L6106; L6105: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6111; scrt1__24__car_2derror( X4 ); L6111: X7 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6114; scrt1__24__car_2derror( X7 ); L6114: X6 = PAIR_CAR( X7 ); L6106: if ( FALSE( closeana_la_2dnestin_2dlb_3f( X6, X3 ) ) ) goto L6117; closeana_dprocedure_40e51573( X3 ); goto L6121; L6117: plist_put( X3, c2936, X6 ); closeana_lambda_2dis_2dinline( X3 ); goto L6121; L6098: if ( FALSE( X5 ) ) goto L6120; closeana_dprocedure_40e51573( X3 ); goto L6121; L6120: X6 = sc_cons( X3, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X6 ); L6121: X2 = PAIR_CDR( X2 ); GOBACK( L6077 ); L6078: X3 = closeana_generate_2dtails( PAIR_CAR( X1 ), _TSCP( 4 ) ); X2 = closeana_generate_2dtails( X3, _TSCP( 8 ) ); X3 = X2; L6125: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L6126; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6130; scrt1__24__car_2derror( X3 ); L6130: X4 = PAIR_CAR( X3 ); closeana_dprocedure_40e51573( X4 ); X3 = PAIR_CDR( X3 ); GOBACK( L6125 ); L6126: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_generate_2dtails_v ); DEFCSTRING( t6133, "GENERATE-TAILS" ); EXTERNTSCPP( closeana_lf_2dtails_de466e28, XAL1( TSCP ) ); EXTERNTSCP( closeana_lf_2dtails_de466e28_v ); EXTERNTSCPP( closeana_verify_2dtails, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana_verify_2dtails_v ); TSCP closeana_generate_2dtails( u4441, p4442 ) TSCP u4441, p4442; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6133 ); L6134: X1 = EMPTYLIST; X2 = FALSEVALUE; X2 = CONS( X2, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); X3 = u4441; L6137: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L6138; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6142; scrt1__24__car_2derror( X3 ); L6142: X4 = PAIR_CAR( X3 ); X5 = closeana_lf_2dtails_de466e28( X4 ); X6 = scrt1_length( X5 ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L6148; if ( EQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L6152; goto L6153; L6148: if ( TRUE( scrt2__3d_2dtwo( X6, _TSCP( 4 ) ) ) ) goto L6152; L6153: closeana_verify_2dtails( X4, p4442 ); goto L6156; L6152: X7 = scrt1_cadar( X5 ); plist_put( X4, c4065, X7 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6159; scrt1__24__car_2derror( X5 ); L6159: X8 = PAIR_CAR( X5 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L6162; scrt1__24__car_2derror( X8 ); L6162: X7 = PAIR_CAR( X8 ); plist_put( X4, c2936, X7 ); closeana_lambda_2dis_2dinline( X4 ); L6156: if ( FALSE( plist_get( X4, c3151 ) ) ) goto L6164; X6 = TRUEVALUE; SETGEN( PAIR_CAR( X2 ), X6 ); goto L6165; L6164: X6 = sc_cons( X4, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X6 ); L6165: X3 = PAIR_CDR( X3 ); GOBACK( L6137 ); L6138: if ( FALSE( PAIR_CAR( X2 ) ) ) goto L6167; u4441 = PAIR_CAR( X1 ); GOBACK( L6134 ); L6167: POPSTACKTRACE( u4441 ); } DEFTSCP( closeana_dprocedure_40e51573_v ); DEFCSTRING( t6169, "LAMBDA-IS-PROCEDURE" ); TSCP closeana_dprocedure_40e51573( l4502 ) TSCP l4502; { TSCP X2, X1; PUSHSTACKTRACE( t6169 ); plist_put( l4502, c2065, EMPTYLIST ); if ( FALSE( plist_get( l4502, c4508 ) ) ) goto L6171; X2 = plist_get( l4502, c4508 ); X1 = SYMBOL_VALUE( assign_2dknown_2dname_v ); X1 = UNKNOWNCALL( X1, 1 ); VIA( PROCEDURE_CODE( X1 ) )( X2, PROCEDURE_CLOSURE( X1 ) ); L6171: if ( FALSE( plist_get( l4502, c2955 ) ) ) goto L6173; plist_put( l4502, c2936, c2126 ); POPSTACKTRACE( plist_put( l4502, c3151, c3165 ) ); L6173: POPSTACKTRACE( plist_put( l4502, c3151, c4517 ) ); } DEFTSCP( closeana_lambda_2dis_2dinline_v ); DEFCSTRING( t6176, "LAMBDA-IS-INLINE" ); TSCP closeana_lambda_2dis_2dinline( l4526 ) TSCP l4526; { TSCP X1; PUSHSTACKTRACE( t6176 ); if ( FALSE( plist_get( l4526, c4508 ) ) ) goto L6178; X1 = plist_get( l4526, c4508 ); plist_put( X1, c3042, FALSEVALUE ); L6178: POPSTACKTRACE( plist_put( l4526, c3151, c4537 ) ); } DEFTSCP( closeana_ine_2dtail_c88b625b_v ); DEFCSTRING( t6180, "LAMBDA-IS-INLINE-TAIL" ); TSCP closeana_ine_2dtail_c88b625b( l4540 ) TSCP l4540; { TSCP X1; PUSHSTACKTRACE( t6180 ); if ( FALSE( plist_get( l4540, c4508 ) ) ) goto L6182; X1 = plist_get( l4540, c4508 ); plist_put( X1, c3042, FALSEVALUE ); L6182: POPSTACKTRACE( plist_put( l4540, c3151, c4551 ) ); } DEFTSCP( closeana_lf_2dtails_de466e28_v ); DEFCSTRING( t6184, "REMOVE-SELF-TAILS" ); EXTERNTSCPP( closeana_ls_2dexits_350c85e5, XAL1( TSCP ) ); EXTERNTSCP( closeana_ls_2dexits_350c85e5_v ); TSCP closeana_lf_2dtails_de466e28( l4553 ) TSCP l4553; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t6184 ); X1 = plist_get( l4553, c3817 ); X2 = EMPTYLIST; L6187: X2 = CONS( X2, EMPTYLIST ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L6188; plist_put( l4553, c3817, PAIR_CAR( X2 ) ); POPSTACKTRACE( PAIR_CAR( X2 ) ); L6188: X4 = scrt1_cadar( X1 ); X3 = closeana_ls_2dexits_350c85e5( X4 ); if ( EQ( _S2CUINT( X3 ), _S2CUINT( l4553 ) ) ) goto L6192; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L6195; scrt1__24__car_2derror( X1 ); L6195: X4 = PAIR_CAR( X1 ); X3 = sc_cons( X4, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X3 ); L6192: if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L6198; scrt1__24__cdr_2derror( X1 ); L6198: X3 = PAIR_CDR( X1 ); X2 = PAIR_CAR( X2 ); X1 = X3; GOBACK( L6187 ); } DEFTSCP( closeana_verify_2dtails_v ); DEFCSTRING( t6200, "VERIFY-TAILS" ); EXTERNTSCPP( closeana_ne_2dtails_e19eeda8, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana_ne_2dtails_e19eeda8_v ); EXTERNTSCPP( closeana__2dtail_3f_8c527d1, XAL2( TSCP, TSCP ) ); EXTERNTSCP( closeana__2dtail_3f_8c527d1_v ); TSCP closeana_verify_2dtails( l4584, p4585 ) TSCP l4584, p4585; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6200 ); X1 = plist_get( l4584, c3817 ); X2 = EMPTYLIST; L6203: X2 = CONS( X2, EMPTYLIST ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L6204; X4 = scrt1_length( PAIR_CAR( X2 ) ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L6208; if ( EQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L6212; X3 = FALSEVALUE; goto L6215; L6208: if ( TRUE( scrt2__3d_2dtwo( X4, _TSCP( 4 ) ) ) ) goto L6212; X3 = FALSEVALUE; goto L6215; L6212: X5 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6217; scrt1__24__car_2derror( X5 ); L6217: X3 = PAIR_CAR( X5 ); L6215: if ( FALSE( X3 ) ) goto L6220; X4 = plist_get( X3, c4648 ); X6 = plist_get( l4584, c4648 ); X5 = sc_cons( l4584, X6 ); L6224: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L6225; plist_put( X3, c4648, X4 ); goto L6226; L6225: if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6229; scrt1__24__car_2derror( X5 ); L6229: X6 = PAIR_CAR( X5 ); plist_put( X6, c4065, X3 ); X7 = PAIR_CAR( X5 ); X6 = closeana_ne_2dtails_e19eeda8( X7, X4 ); X5 = PAIR_CDR( X5 ); X4 = X6; GOBACK( L6224 ); L6226: plist_put( l4584, c4648, EMPTYLIST ); plist_put( l4584, c2936, X3 ); POPSTACKTRACE( closeana_ine_2dtail_c88b625b( l4584 ) ); L6220: POPSTACKTRACE( FALSEVALUE ); L6204: X4 = scrt1_cadar( X1 ); X3 = closeana_ls_2dexits_350c85e5( X4 ); if ( TRUE( scrt1_memq( X3, PAIR_CAR( X2 ) ) ) ) goto L6243; if ( EQ( _S2CUINT( p4585 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L6240; X4 = scrt1_cadar( X1 ); if ( TRUE( closeana__2dtail_3f_8c527d1( X4, PAIR_CAR( X2 ) ) ) ) goto L6243; L6240: X4 = sc_cons( X3, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X4 ); L6243: if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L6245; scrt1__24__cdr_2derror( X1 ); L6245: X3 = PAIR_CDR( X1 ); X2 = PAIR_CAR( X2 ); X1 = X3; GOBACK( L6203 ); } DEFTSCP( closeana_ls_2dexits_350c85e5_v ); DEFCSTRING( t6247, "GENERATE-TAILS-EXITS" ); TSCP closeana_ls_2dexits_350c85e5( l4675 ) TSCP l4675; { TSCP X1; PUSHSTACKTRACE( t6247 ); L6248: X1 = plist_get( l4675, c3151 ); if ( FALSE( scrt1_memq( X1, c4681 ) ) ) goto L6249; if ( FALSE( plist_get( l4675, c4065 ) ) ) goto L6251; l4675 = plist_get( l4675, c4065 ); GOBACK( L6248 ); L6251: POPSTACKTRACE( l4675 ); L6249: POPSTACKTRACE( l4675 ); } DEFTSCP( closeana__2dtail_3f_8c527d1_v ); DEFCSTRING( t6253, "COULD-INLINE-TAIL?" ); TSCP closeana__2dtail_3f_8c527d1( l4688, e4689 ) TSCP l4688, e4689; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6253 ); if ( FALSE( plist_get( l4688, c3151 ) ) ) goto L6255; X1 = FALSEVALUE; goto L6256; L6255: X1 = TRUEVALUE; L6256: if ( FALSE( X1 ) ) goto L6258; X2 = plist_get( l4688, c3817 ); X3 = X2; L6262: if ( FALSE( X3 ) ) goto L6263; X5 = scrt1_cadar( X3 ); X4 = closeana_ls_2dexits_350c85e5( X5 ); X5 = plist_get( X4, c3151 ); if ( FALSE( X5 ) ) goto L6272; if ( TRUE( scrt1_memq( X4, e4689 ) ) ) goto L6272; POPSTACKTRACE( FALSEVALUE ); L6263: POPSTACKTRACE( TRUEVALUE ); L6272: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6274; scrt1__24__cdr_2derror( X3 ); L6274: X3 = PAIR_CDR( X3 ); GOBACK( L6262 ); L6258: POPSTACKTRACE( X1 ); } DEFTSCP( closeana_ne_2dtails_e19eeda8_v ); DEFCSTRING( t6276, "MERGE-INLINE-TAILS" ); TSCP closeana_ne_2dtails_e19eeda8( l4717, t4718 ) TSCP l4717, t4718; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t6276 ); if ( NEQ( _S2CUINT( t4718 ), _S2CUINT( EMPTYLIST ) ) ) goto L6278; X1 = sc_cons( l4717, EMPTYLIST ); POPSTACKTRACE( X1 ); L6278: if ( EQ( TSCPTAG( t4718 ), PAIRTAG ) ) goto L6282; scrt1__24__car_2derror( t4718 ); L6282: X2 = PAIR_CAR( t4718 ); X1 = closeana_la_2dnestin_2dlb_3f( X2, l4717 ); if ( TRUE( X1 ) ) goto L6288; X2 = PAIR_CAR( t4718 ); X3 = plist_get( l4717, c3184 ); if ( TRUE( scrt1_memq( X2, X3 ) ) ) goto L6288; X2 = PAIR_CAR( t4718 ); X4 = PAIR_CDR( t4718 ); X3 = closeana_ne_2dtails_e19eeda8( l4717, X4 ); POPSTACKTRACE( sc_cons( X2, X3 ) ); L6288: POPSTACKTRACE( sc_cons( l4717, t4718 ) ); } DEFTSCP( closeana_la_2dnestin_2dlb_3f_v ); DEFCSTRING( t6294, "LA-NESTIN-LB?" ); TSCP closeana_la_2dnestin_2dlb_3f( l4749, l4750 ) TSCP l4749, l4750; { TSCP X1; PUSHSTACKTRACE( t6294 ); L6295: if ( EQ( _S2CUINT( l4749 ), _S2CUINT( l4750 ) ) ) goto L6296; if ( EQ( _S2CUINT( l4749 ), _S2CUINT( c2126 ) ) ) goto L6298; X1 = plist_get( l4749, c2936 ); l4749 = X1; GOBACK( L6295 ); L6298: POPSTACKTRACE( FALSEVALUE ); L6296: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( closeana_display_2dclose_v ); DEFCSTRING( t6300, "DISPLAY-CLOSE" ); EXTERNTSCPP( closeana_all_2dlexical_2dvars, XAL1( TSCP ) ); EXTERNTSCP( closeana_all_2dlexical_2dvars_v ); TSCP closeana_display_2dclose( e4760 ) TSCP e4760; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6300 ); if ( NEQ( TSCPTAG( e4760 ), PAIRTAG ) ) goto L6302; X1 = PAIR_CAR( e4760 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2065 ) ) ) goto L6304; X3 = PAIR_CAR( e4760 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2065 ) ) ); if ( FALSE( X2 ) ) goto L6309; X3 = PAIR_CDR( e4760 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6313; scrt1__24__car_2derror( X3 ); L6313: X1 = PAIR_CAR( X3 ); goto L6310; L6309: X1 = X2; L6310: X2 = plist_get( X1, c3151 ); if ( FALSE( scrt1_memq( X2, c4780 ) ) ) goto L6316; X2 = closeana_all_2dlexical_2dvars( X1 ); X3 = X2; L6320: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L6321; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6325; scrt1__24__car_2derror( X3 ); L6325: X4 = PAIR_CAR( X3 ); X5 = plist_get( X4, c2550 ); if ( FALSE( X5 ) ) goto L6334; X7 = plist_get( X4, c2550 ); X6 = plist_get( X7, c3151 ); if ( EQ( _S2CUINT( X6 ), _S2CUINT( c3165 ) ) ) goto L6334; plist_put( X4, c3042, FALSEVALUE ); goto L6336; L6334: if ( TRUE( plist_get( X4, c3042 ) ) ) goto L6336; X5 = SYMBOL_VALUE( log_3f_v ); X5 = UNKNOWNCALL( X5, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X5 ) )( c2955, PROCEDURE_CLOSURE( X5 ) ) ) ) goto L6339; X5 = SYMBOL_VALUE( sc_2dicode_v ); X6 = CONS( X4, EMPTYLIST ); X6 = CONS( X1, X6 ); scrt6_format( X5, CONS( c4820, X6 ) ); L6339: plist_put( X4, c3042, TRUEVALUE ); L6336: X3 = PAIR_CDR( X3 ); GOBACK( L6320 ); L6321: POPSTACKTRACE( FALSEVALUE ); L6316: POPSTACKTRACE( FALSEVALUE ); L6304: POPSTACKTRACE( FALSEVALUE ); L6302: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( closeana_all_2dlexical_2dvars_v ); DEFCSTRING( t6342, "ALL-LEXICAL-VARS" ); TSCP closeana_all_2dlexical_2dvars( i4860 ) TSCP i4860; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6342 ); X1 = plist_get( i4860, c4648 ); X2 = plist_get( i4860, c3181 ); X3 = X2; X4 = X1; L6346: X3 = CONS( X3, EMPTYLIST ); if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L6347; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6351; scrt1__24__car_2derror( X4 ); L6351: X6 = PAIR_CAR( X4 ); X5 = plist_get( X6, c3181 ); X6 = X5; L6355: if ( EQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L6356; if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6360; scrt1__24__car_2derror( X6 ); L6360: X7 = PAIR_CAR( X6 ); X8 = plist_get( X7, c3317 ); if ( TRUE( closeana_la_2dnestin_2dlb_3f( X8, i4860 ) ) ) goto L6365; if ( TRUE( scrt1_memq( X7, PAIR_CAR( X3 ) ) ) ) goto L6365; X8 = sc_cons( X7, PAIR_CAR( X3 ) ); SETGEN( PAIR_CAR( X3 ), X8 ); L6365: X6 = PAIR_CDR( X6 ); GOBACK( L6355 ); L6356: X4 = PAIR_CDR( X4 ); X3 = PAIR_CAR( X3 ); GOBACK( L6346 ); L6347: POPSTACKTRACE( PAIR_CAR( X3 ) ); } void scrt2__init(); void scdebug__init(); void scrt6__init(); void plist__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt2__init(); scdebug__init(); scrt6__init(); plist__init(); scrt1__init(); MAXDISPLAY( 0 ); } void closeana__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(closeana SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t5213, ADR( closeana_analyze_2dclosures1a_v ), MAKEPROCEDURE( 1, 0, closeana_analyze_2dclosures1a, EMPTYLIST ) ); INITIALIZEVAR( t5240, ADR( closeana_analyze_2dclosures1b_v ), MAKEPROCEDURE( 1, 0, closeana_analyze_2dclosures1b, EMPTYLIST ) ); INITIALIZEVAR( t5242, ADR( closeana_analyze_2dclosures2_v ), MAKEPROCEDURE( 1, 0, closeana_analyze_2dclosures2, EMPTYLIST ) ); INITIALIZEVAR( t5244, ADR( closeana_walk_2d_24tree_v ), MAKEPROCEDURE( 2, 0, closeana_walk_2d_24tree, EMPTYLIST ) ); INITIALIZEVAR( t5319, ADR( closeana_ree_2dlist_f50a563f_v ), MAKEPROCEDURE( 2, 0, closeana_ree_2dlist_f50a563f, EMPTYLIST ) ); INITIALIZEVAR( t5330, ADR( closeana_walk_2dlambda_2did_v ), c2126 ); INITIALIZEVAR( t5331, ADR( closeana_walk_2dlambda_2dids_v ), c2407 ); INITIALIZEVAR( t5332, ADR( closeana__2dlexical_455a78ac_v ), EMPTYLIST ); INITIALIZEVAR( t5333, ADR( closeana_bda_2dlist_c52ab123_v ), EMPTYLIST ); INITIALIZEVAR( t5334, ADR( closeana_assign_2dlambdas_v ), MAKEPROCEDURE( 1, 0, closeana_assign_2dlambdas, EMPTYLIST ) ); INITIALIZEVAR( t5509, ADR( closeana_bdas_2darg_a7a3fa97_v ), MAKEPROCEDURE( 1, 0, closeana_bdas_2darg_a7a3fa97, EMPTYLIST ) ); INITIALIZEVAR( t5545, ADR( closeana_inherit_2dclosed_v ), MAKEPROCEDURE( 1, 0, closeana_inherit_2dclosed, EMPTYLIST ) ); INITIALIZEVAR( t5576, ADR( closeana__2dchecked_ed79e461_v ), EMPTYLIST ); INITIALIZEVAR( t5577, ADR( closeana__2dlexical_34c6288f_v ), MAKEPROCEDURE( 1, 0, closeana__2dlexical_34c6288f, EMPTYLIST ) ); INITIALIZEVAR( t5579, ADR( closeana_2dlexical1_2ced58a3_v ), MAKEPROCEDURE( 3, 0, closeana_2dlexical1_2ced58a3, EMPTYLIST ) ); INITIALIZEVAR( t5641, ADR( closeana_da_2dslots_a659d0e7_v ), MAKEPROCEDURE( 1, 0, closeana_da_2dslots_a659d0e7, EMPTYLIST ) ); INITIALIZEVAR( t5846, ADR( closeana_mergeq_v ), MAKEPROCEDURE( 2, 0, closeana_mergeq, EMPTYLIST ) ); INITIALIZEVAR( t5852, ADR( closeana_mark_2dtail_2dcalls_v ), MAKEPROCEDURE( 1, 0, closeana_mark_2dtail_2dcalls, EMPTYLIST ) ); INITIALIZEVAR( t5921, ADR( closeana_mark_2dtail_2dcalls1_v ), MAKEPROCEDURE( 2, 0, closeana_mark_2dtail_2dcalls1, EMPTYLIST ) ); INITIALIZEVAR( t6015, ADR( closeana_count_2dcalls_v ), MAKEPROCEDURE( 1, 0, closeana_count_2dcalls, EMPTYLIST ) ); INITIALIZEVAR( t6073, ADR( closeana_generate_2dlambdas_v ), MAKEPROCEDURE( 1, 0, closeana_generate_2dlambdas, EMPTYLIST ) ); INITIALIZEVAR( t6133, ADR( closeana_generate_2dtails_v ), MAKEPROCEDURE( 2, 0, closeana_generate_2dtails, EMPTYLIST ) ); INITIALIZEVAR( t6169, ADR( closeana_dprocedure_40e51573_v ), MAKEPROCEDURE( 1, 0, closeana_dprocedure_40e51573, EMPTYLIST ) ); INITIALIZEVAR( t6176, ADR( closeana_lambda_2dis_2dinline_v ), MAKEPROCEDURE( 1, 0, closeana_lambda_2dis_2dinline, EMPTYLIST ) ); INITIALIZEVAR( t6180, ADR( closeana_ine_2dtail_c88b625b_v ), MAKEPROCEDURE( 1, 0, closeana_ine_2dtail_c88b625b, EMPTYLIST ) ); INITIALIZEVAR( t6184, ADR( closeana_lf_2dtails_de466e28_v ), MAKEPROCEDURE( 1, 0, closeana_lf_2dtails_de466e28, EMPTYLIST ) ); INITIALIZEVAR( t6200, ADR( closeana_verify_2dtails_v ), MAKEPROCEDURE( 2, 0, closeana_verify_2dtails, EMPTYLIST ) ); INITIALIZEVAR( t6247, ADR( closeana_ls_2dexits_350c85e5_v ), MAKEPROCEDURE( 1, 0, closeana_ls_2dexits_350c85e5, EMPTYLIST ) ); INITIALIZEVAR( t6253, ADR( closeana__2dtail_3f_8c527d1_v ), MAKEPROCEDURE( 2, 0, closeana__2dtail_3f_8c527d1, EMPTYLIST ) ); INITIALIZEVAR( t6276, ADR( closeana_ne_2dtails_e19eeda8_v ), MAKEPROCEDURE( 2, 0, closeana_ne_2dtails_e19eeda8, EMPTYLIST ) ); INITIALIZEVAR( t6294, ADR( closeana_la_2dnestin_2dlb_3f_v ), MAKEPROCEDURE( 2, 0, closeana_la_2dnestin_2dlb_3f, EMPTYLIST ) ); INITIALIZEVAR( t6300, ADR( closeana_display_2dclose_v ), MAKEPROCEDURE( 1, 0, closeana_display_2dclose, EMPTYLIST ) ); INITIALIZEVAR( t6342, ADR( closeana_all_2dlexical_2dvars_v ), MAKEPROCEDURE( 1, 0, closeana_all_2dlexical_2dvars, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/closeana.sc000066400000000000000000000471441203736146400166620ustar00rootroot00000000000000;;; This phase of the Scheme compiler figures out whether closures must be ;;; stack or heap allocated. According to Steele's RABBIT paper, a heap ;;; allocated closure is needed for the following reasons: ;;; ;;; - the Lambda expression is used as an argument to a function. ;;; ;;; - the Lambda expression is bound to a variable which is used as an ;;; argument to a function. ;;; ;;; - the Lambda expression is bound to a variable which is used as a ;;; function within a closure. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module closeana) ;;; External and in-line definitions. (include "plist.sch") (include "expform.sch") (include "lambdaexp.sch") (include "miscexp.sch") ;;; Closure analysis before transformations is done by the following functions. ;;; The first is called to identify top-level functions which can be directly ;;; called, i.e. they are never assigned. Once this is done, then further ;;; analysis is done to identify lambda expressions that must be closed over ;;; some variables. (define (ANALYZE-CLOSURES1A exp) (if ($define? exp) (let ((var ($define-id exp)) (value ($define-exp exp))) (if (and ($lambda? value) (not (id-set! var))) (name-a-lambda var value))))) (define (ANALYZE-CLOSURES1B exp) (set! walk-lambda-id 'top-level) (update-lambda-slots exp) (walk-$tree assign-lambdas exp) (update-lambda-slots exp) (walk-$tree inherit-closed exp)) ;;; Given that the bindings of lambda functions are now known, it is possible ;;; to count the number of calls to the function. Those calls which are ;;; marked tail-recursive and actually are, will not be counted. All others ;;; will have their tail-recursive flag cleared and will be counted. When ;;; this is done, the following will be known: ;;; ;;; - all call's with the tail-recursive flag set will become branches. ;;; ;;; - all lambda expressions which are stack allocated and have 1 real-call ;;; can be open coded at the point that they are called and any variable ;;; binding can be ignored. (define (ANALYZE-CLOSURES2 exp) (set! walk-lambda-id 'top-level) (set! close-lambda-list '()) (update-lambda-slots exp) (walk-$tree mark-tail-calls exp) (walk-$tree count-calls exp) (generate-lambdas close-lambda-list) (update-lambda-slots exp) (walk-$tree display-close exp)) ;;; WALK-$TREE walks the tree for a function produced by PASS1 and calls the ;;; inspection function. During the walk, WALK-LAMBDA-ID will be set to the ;;; current lambda-id. (define (WALK-$TREE function leaf) (if (pair? leaf) (begin (function leaf) (cond (($set? leaf) (walk-$tree function ($set-exp leaf))) (($define? leaf) (walk-$tree function ($define-exp leaf))) (($lambda? leaf) (let ((old-walk-lambda-id walk-lambda-id)) (set! walk-lambda-id ($lambda-id leaf)) (walk-$tree-list function ($lambda-body leaf)) (set! walk-lambda-id old-walk-lambda-id))) (($call? leaf) (let ((func ($call-func leaf))) (walk-$tree-list function ($call-argl leaf)) (walk-$tree function func))) (($if? leaf) (walk-$tree-list function (cdr leaf))))))) (define (WALK-$TREE-LIST function forms) (for-each (lambda (leaf) (walk-$tree function leaf)) forms)) (define WALK-LAMBDA-ID 'top-level) (define WALK-LAMBDA-IDS '(top-level)) (define WALK-LAMBDA-LEXICAL '()) (define CLOSE-LAMBDA-LIST '()) ;;; ASSIGN-LAMBDAS tries to figure out if any lambda expression is ever ;;; used for something besides a function. If so, it must be "closed" on the ;;; heap. ;;; ;;; Once that information has been obtained, then the closure property is ;;; propogated by INHERIT-CLOSED. (define (ASSIGN-LAMBDAS exp) (cond (($set? exp) (if (or (not ($lambda? ($set-exp exp))) (not (eq? (id-lambda ($set-id exp)) ($lambda-id ($set-exp exp))))) (assign-lambdas-arg ($set-exp exp)))) (($lambda? exp) (for-each assign-lambdas-arg ($lambda-body exp))) (($if? exp) (assign-lambdas-arg ($if-test exp)) (assign-lambdas-arg ($if-true exp)) (assign-lambdas-arg ($if-false exp))) (($call? exp) (let ((func ($call-func exp))) (if ($lambda? func) (begin (let loop ((vars (lambda-reqvars ($lambda-id func))) (vals ($call-argl exp))) (if vars (let ((var (car vars)) (val (car vals))) (if (and (symbol? val) (id-lambda val)) (set-id-lambda! var (id-lambda val))) (loop (cdr vars) (cdr vals)))))) (for-each assign-lambdas-arg ($call-argl exp))))))) (define (ASSIGN-LAMBDAS-ARG exp) (let ((lid (or (and (symbol? exp) (id-lambda exp)) ($lambda-id exp)))) (if lid (begin (if (or (not (eq? (lambda-nestin lid) 'top-level)) (and (symbol? exp) (not (eq? (id-use exp) 'global)))) (begin (set-lambda-closed! lid #t) (if (log? 'closed) (format sc-icode "~A must be a closed procedure~%" lid)))) (lambda-is-procedure lid))))) (define (INHERIT-CLOSED exp) (let ((closed-id ($lambda-id exp))) (if (and closed-id (lambda-closed closed-id)) (let ((vars (indirect-lambda-lexical closed-id))) (if (log? 'closed) (format sc-icode "~A forces ~A to the display~%" closed-id vars)) (for-each (lambda (var) (set-id-display! var #t)) vars))))) ;;; The list of lexical variables used with-in the body of lid and all the ;;; lambda expressions which it calls. (define INDIRECT-LAMBDA-CHECKED '()) (define (INDIRECT-LAMBDA-LEXICAL lid) (set! indirect-lambda-checked '()) (indirect-lambda-lexical1 lid '() '())) (define (INDIRECT-LAMBDA-LEXICAL1 lid lexvars bound) (if (memq lid indirect-lambda-checked) lexvars (let* ((bound (append (append (lambda-reqvars lid) (lambda-optvars lid)) bound)) (calls (lambda-calls lid)) (lexvars (let loop ((mine (lambda-lexical lid)) (lexvars lexvars)) (define (ADD-TO-CALLS var) (if (not (memq var calls)) (set! calls (cons (id-lambda var)calls))) #t) (if mine (let ((var (car mine))) (if (or (memq var lexvars) (memq var bound) (and (id-lambda var) (lambda-generate (id-lambda var)) (not (eq? (lambda-generate (id-lambda var)) 'closed-procedure)) (add-to-calls var))) (loop (cdr mine) lexvars) (loop (cdr mine) (cons var lexvars)))) lexvars)))) (set! indirect-lambda-checked (cons lid indirect-lambda-checked)) (let loop ((calls calls) (lexvars lexvars)) (if calls (let ((call (car calls))) (if (eq? (lambda-nestin call) 'top-level) (loop (cdr calls) lexvars) (loop (cdr calls) (indirect-lambda-lexical1 call lexvars bound)))) lexvars))))) ;;; UPDATE-LAMBDA-SLOTS is called to update fields in the lambda records which ;;; may change because of transformations. The fields updated are ;;; LAMBDA-LEXICAL and LAMBDA-CALLS. (define (UPDATE-LAMBDA-SLOTS exp) (cond ((or ($set? exp) ($if? exp)) (for-each update-lambda-slots (cdr exp))) (($define? exp) (set! walk-lambda-id 'top-level) (set! walk-lambda-ids '(top-level)) (set! walk-lambda-lexical '()) (update-lambda-slots ($define-exp exp))) ((and ($lambda? exp) (not (memq ($lambda-id exp) walk-lambda-ids))) (set! walk-lambda-ids (cons ($lambda-id exp) walk-lambda-ids)) (set! walk-lambda-id (car walk-lambda-ids)) (set-lambda-calls! walk-lambda-id '()) (let ((save-walk-lambda-lexical walk-lambda-lexical) (lex '())) (for-each (lambda (exp) (set! walk-lambda-lexical '()) (update-lambda-slots exp) (let loop ((vars walk-lambda-lexical)) (cond ((null? vars)) ((or (memq (car vars) lex) (eq? (id-boundid (car vars)) walk-lambda-id)) (loop (cdr vars))) (else (set! lex (cons (car vars) lex)) (loop (cdr vars)))))) ($lambda-body exp)) (set-lambda-lexical! walk-lambda-id lex) (set! walk-lambda-lexical save-walk-lambda-lexical) (for-each (lambda (x) (set! walk-lambda-lexical (mergeq x walk-lambda-lexical))) lex)) (set! walk-lambda-ids (cdr walk-lambda-ids)) (set! walk-lambda-id (car walk-lambda-ids))) (($call? exp) (let* ((func ($call-func exp)) (lid (or ($lambda-id func) (and (symbol? func) (id-lambda func))))) (when lid (set-lambda-calls! walk-lambda-id (mergeq lid (lambda-calls walk-lambda-id))) (if (symbol? func) (if (memq (lambda-generate lid) '(inline inline-closed)) (update-lambda-slots (lambda-$lambda lid))))) (update-lambda-slots func) (for-each update-lambda-slots ($call-argl exp)))) ((and (symbol? exp) (id-boundid exp) (not (eq? (id-boundid exp) walk-lambda-id))) (set! walk-lambda-lexical (mergeq exp walk-lambda-lexical))))) ;;; A simple merge function based on EQ?. (define (MERGEQ x y) (cond ((null? x) y) ((memq x y) y) (else (cons x y)))) ;;; MARK-TAIL-CALLS is called to flag all function calls which exit their ;;; containing lambda expression. The flag is the id of the outer-most lambda ;;; expression that they exit. Lambda expressions which are called inline ;;; will be so noted and have their generate field set to INLINE and their ;;; nestin field set correctly at this time. Similarly, top-level functions ;;; will have their generate field set to PROCEDURE. Finally, a list of all ;;; lambda-id's will be collected in CLOSE-LAMBDA-LIST. (define (MARK-TAIL-CALLS exp) (cond (($lambda? exp) (let ((lid ($lambda-id exp))) (set! close-lambda-list (cons lid close-lambda-list)) (set-lambda-str-calls! lid '()) (set-lambda-tail-calls! lid '()) (set-lambda-real-calls! lid '()) (if (eq? (lambda-nestin lid) 'top-level) (if (not (lambda-generate lid)) (lambda-is-procedure lid)) (set-lambda-$lambda! lid exp)) (mark-tail-calls1 (car (last-pair ($lambda-body exp))) lid))) ((and ($call? exp) ($lambda? ($call-func exp))) (let ((lid ($lambda-id ($call-func exp)))) (set-lambda-nestin! lid walk-lambda-id) (lambda-is-inline lid))))) (define (MARK-TAIL-CALLS1 exp exitid) (cond ((and ($call? exp) (not ($call-tail exp))) (set-$call-tail! exp exitid) (if ($lambda? ($call-func exp)) (begin (set-lambda-exits! ($lambda-id ($call-func exp)) exitid) (mark-tail-calls1 (car (last-pair ($lambda-body ($call-func exp)))) exitid)))) (($if? exp) (mark-tail-calls1 ($if-true exp) exitid) (mark-tail-calls1 ($if-false exp) exitid)))) ;;; Calls are counted by the following function. Three lists are maintained, ;;; STR-CALLS (self-tail-recursive calls), TAIL-CALLS (other tail calls), and ;;; REAL-CALLS (other calls). The STR-CALLS and REAL-CALLS are composed of ;;; the caller's lambda-id. The TAIL-CALLS list is composed of two item ;;; entries of the form (caller-id tail-exit-id). Note that calls are only ;;; counted for lambda expressions which are internal to a function as those ;;; are the only ones that can be relocated. (define (COUNT-CALLS exp) (let* ((func (if ($call? exp) ($call-func exp) #f)) (id (if (symbol? func) (id-lambda func) #f))) (if (and id (not (id-external func))) (cond ((eq? ($call-tail exp) id) (set-lambda-str-calls! id (cons walk-lambda-id (lambda-str-calls id)))) (($call-tail exp) (set-lambda-tail-calls! id (cons (list walk-lambda-id ($call-tail exp)) (lambda-tail-calls id)))) (else (set-lambda-real-calls! id (cons walk-lambda-id (lambda-real-calls id)))))))) ;;; Once calls have been counted, it is possible to assign code generation ;;; methods to each of the lambda expressions. This is done by this function ;;; which is called with a list of lambda expressions. It makes an initial ;;; pass over the list and inspects those which don't have a code generation ;;; method. Any lambda expressions that are called once are marked INLINE. ;;; Any others which have real-calls are marked (CLOSED-)PROCEDURE, and the ;;; rest (which have several tail calls) are saved for processing by ;;; GENERATE-TAILS. Following this, any items with unknown generation methods ;;; are marked as PROCEDURE. (define (GENERATE-LAMBDAS lambda-list) (let ((unknown '())) (for-each (lambda (lid) (let ((real (lambda-real-calls lid)) (tail (lambda-tail-calls lid))) (cond ((lambda-generate lid) #t) ((= 1 (+ (length real) (length tail))) (if tail (set-lambda-exits! lid (cadar tail))) (let ((nestin (if real (car real) (caar tail)))) (if (la-nestin-lb? nestin lid) (lambda-is-procedure lid) (begin (set-lambda-nestin! lid nestin) (lambda-is-inline lid))))) (real (lambda-is-procedure lid)) (else (set! unknown (cons lid unknown)))))) lambda-list) (for-each lambda-is-procedure (generate-tails (generate-tails unknown 1) 2)))) ;;; GENERATE-TAILS attempts to turn the left overs into either INLINE or ;;; INLINE-TAIL calls. This is an iterative process and when no more ;;; conversions can be made, it will mark those left as PROCEDURE. A lambda ;;; expression may be designated INLINE-TAIL when: ;;; ;;; 1. All the callers are tail calls within the same procedure. ;;; 2. All the calls exit the same lambda expression. ;;; ;;; FSM's are defered to the second pass to prevent lambda expressions from ;;; becoming inline-tails that could be inline. (define (GENERATE-TAILS unknown pass) (let ((progress #f) (still-unknown '())) (for-each (lambda (lid) (let ((tails (remove-self-tails lid))) (if (= (length tails) 1) (begin (set-lambda-exits! lid (cadar tails)) (set-lambda-nestin! lid (caar tails)) (lambda-is-inline lid)) (verify-tails lid pass)) (if (lambda-generate lid) (set! progress #t) (set! still-unknown (cons lid still-unknown))))) unknown) (if progress (generate-tails still-unknown pass) unknown))) (define (LAMBDA-IS-PROCEDURE lid) (set-lambda-$lambda! lid '()) (if (lambda-name lid) (assign-known-name (lambda-name lid))) (if (lambda-closed lid) (begin (set-lambda-nestin! lid 'top-level) (set-lambda-generate! lid 'closed-procedure)) (set-lambda-generate! lid 'procedure))) (define (LAMBDA-IS-INLINE lid) (if (lambda-name lid) (set-id-display! (lambda-name lid) #f)) (set-lambda-generate! lid 'inline)) (define (LAMBDA-IS-INLINE-TAIL lid) (if (lambda-name lid) (set-id-display! (lambda-name lid) #f)) (set-lambda-generate! lid 'inline-tail)) (define (REMOVE-SELF-TAILS lid) (do ((tails (lambda-tail-calls lid) (cdr tails)) (newtails '())) ((null? tails) (set-lambda-tail-calls! lid newtails) newtails) (if (not (eq? (generate-tails-exits (cadar tails)) lid)) (set! newtails (cons (car tails) newtails))))) (define (VERIFY-TAILS lid pass) (do ((tails (lambda-tail-calls lid) (cdr tails)) (exits '())) ((null? tails) (let ((exits (if (= (length exits) 1) (car exits) #f))) (if exits (begin (do ((inline-tails (lambda-inline-tails exits) (merge-inline-tails (car ids) inline-tails)) (ids (cons lid (lambda-inline-tails lid)) (cdr ids))) ((null? ids) (set-lambda-inline-tails! exits inline-tails)) (set-lambda-exits! (car ids) exits)) (set-lambda-inline-tails! lid '()) (set-lambda-nestin! lid exits) (lambda-is-inline-tail lid))))) (let ((x (generate-tails-exits (cadar tails)))) (if (and (not (memq x exits)) (or (eq? pass 1) (not (could-inline-tail? (cadar tails) exits)))) (set! exits (cons x exits)))))) (define (GENERATE-TAILS-EXITS lid) (if (and (memq (lambda-generate lid) '(inline inline-tail)) (lambda-exits lid)) (generate-tails-exits (lambda-exits lid)) lid)) ;;; A lambda expression that could be inline-tailed in the current context is ;;; one whose generation method is unknown and who only tail calls items who's ;;; generation methods are unknown or a member of the exits list. (define (COULD-INLINE-TAIL? lid exits) (and (not (lambda-generate lid)) (let loop ((tails (lambda-tail-calls lid))) (if tails (let ((exit (generate-tails-exits (cadar tails)))) (if (and (lambda-generate exit) (not (memq exit exits))) #f (loop (cdr tails)))) #t)))) ;;; The INLINE-TAILS list is ordered such that lambda expressions occur before ;;; those which nest in them and before those which they call. This is ;;; required to generate correct code. (define (MERGE-INLINE-TAILS lid tails) (cond ((null? tails) (list lid)) ((or (la-nestin-lb? (car tails) lid) (memq (car tails) (lambda-calls lid))) (cons lid tails)) (else (cons (car tails) (merge-inline-tails lid (cdr tails)))))) ;;; The following boolean tests whether lambda expression "a" is nested in ;;; lambda expression "b". (define (LA-NESTIN-LB? la lb) (cond ((eq? la lb) #t) ((eq? la 'top-level) #f) (else (la-nestin-lb? (lambda-nestin la) lb)))) ;;; Once all the code generation modes for each lambda expression have been ;;; decided, the final analysis step is to decide which lexical variables must ;;; be allocated in the display. A variable must be allocated to the display ;;; if it is used by a "closed" procedure, or it is lexically referenced ;;; across a C procedure boundary. (define (DISPLAY-CLOSE exp) (if ($lambda? exp) (let ((id ($lambda-id exp))) (if (memq (lambda-generate id) '(procedure closed-procedure)) (for-each (lambda (var) (cond ((and (id-lambda var) (not (eq? (lambda-generate (id-lambda var)) 'closed-procedure))) (set-id-display! var #f)) ((not (id-display var)) (if (log? 'closed) (format sc-icode "~A forces ~A to display~%" id var)) (set-id-display! var #t)))) (all-lexical-vars id)))))) ;;; Returns a list of all lexical variables associated with a procedure, ;;; including those picked up by inline-tail calls. This was introduced as a ;;; conservative way to fix a problem. (define (ALL-LEXICAL-VARS id) (let loop ((vars (lambda-lexical id)) (inline-tails (lambda-inline-tails id))) (if (null? inline-tails) vars (begin (for-each (lambda (var) (if (and (not (la-nestin-lb? (id-boundid var) id)) (not (memq var vars))) (set! vars (cons var vars)))) (lambda-lexical (car inline-tails))) (loop vars (cdr inline-tails)))))) scheme2c-2012.10.14/scsc/compile.c000066400000000000000000002560601203736146400163410ustar00rootroot00000000000000 /* SCHEME->C */ #include void compile__init(); DEFSTATICTSCP( lexical_2dfree_2dvars_v ); DEFSTATICTSCP( lexical_2dbound_2dvars_v ); DEFSTATICTSCP( current_2dlambda_2did_v ); DEFSTATICTSCP( quote_2dconstants_v ); DEFSTATICTSCP( lap_2dcode_v ); DEFSTATICTSCP( predef_2ddefault_v ); DEFSTATICTSCP( copy_2dplist_v ); DEFSTATICTSCP( global_2dfree_2dvars_v ); DEFSTATICTSCP( make_2dalpha_2dseq_v ); DEFSTATICTSCP( lap_2dexp_v ); DEFSTATICTSCP( quote_2dexp_v ); DEFSTATICTSCP( set_21_2dexp_v ); DEFSTATICTSCP( if_2dexp_v ); DEFSTATICTSCP( define_2dexp_v ); DEFSTATICTSCP( old_2dmacro_v ); DEFSTATICTSCP( quasiquote_2dmacro_v ); DEFSTATICTSCP( cond_2dmacro_v ); DEFSTATICTSCP( case_2dmacro_v ); DEFSTATICTSCP( and_2dmacro_v ); DEFSTATICTSCP( or_2dmacro_v ); DEFSTATICTSCP( not_2dmacro_v ); DEFSTATICTSCP( begin_2dmacro_v ); DEFSTATICTSCP( let_2dmacro_v ); DEFSTATICTSCP( let_2a_2dmacro_v ); DEFSTATICTSCP( letrec_2dmacro_v ); DEFSTATICTSCP( do_2dmacro_v ); DEFSTATICTSCP( when_2dmacro_v ); DEFSTATICTSCP( unless_2dmacro_v ); DEFSTATICTSCP( quote_2dmacro_v ); DEFSTATICTSCP( lap_2dmacro_v ); DEFSTATICTSCP( define_2dmacro_v ); DEFSTATICTSCP( define_2dmacro_2dmacro_v ); DEFSTATICTSCP( define_2dconstant_2dmacro_v ); DEFSTATICTSCP( eval_2dwhen_2dmacro_v ); DEFSTATICTSCP( lambda_2dmacro_v ); DEFSTATICTSCP( lambda_2dexp_v ); DEFSTATICTSCP( load_2dplist_2dlap_v ); DEFSTATICTSCP( read_2dtext_v ); DEFSTATICTSCP( expand_2dforms_v ); DEFSTATICTSCP( analyze_2dclosures1a_v ); DEFSTATICTSCP( analyze_2dclosures1b_v ); DEFSTATICTSCP( transform_v ); DEFSTATICTSCP( analyze_2dclosures2_v ); DEFSTATICTSCP( walk_2d_24tree_v ); DEFSTATICTSCP( print_2dlambda_2dinfo_v ); DEFSTATICTSCP( generate_2dcode_v ); DEFCSTRING( t3582, "Argument is out of range: ~s" ); DEFSTATICTSCP( c3404 ); DEFSTATICTSCP( c3383 ); DEFCSTRING( t3583, "Argument(s) incorrect" ); DEFSTATICTSCP( c3377 ); DEFCSTRING( t3584, "Argument is not a CHAR: ~s" ); DEFSTATICTSCP( c3356 ); DEFCSTRING( t3585, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c3353 ); DEFSTATICTSCP( c3352 ); DEFCSTRING( t3586, "~s" ); DEFSTATICTSCP( c3313 ); DEFCSTRING( t3587, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c3312 ); DEFSTATICTSCP( c3311 ); DEFSTATICTSCP( c3217 ); DEFSTATICTSCP( c3072 ); DEFSTATICTSCP( c3069 ); DEFCSTRING( t3588, "(~S ~S ~S" ); DEFSTATICTSCP( c2989 ); DEFCSTRING( t3589, "(~S ~S" ); DEFSTATICTSCP( c2933 ); DEFCSTRING( t3590, ")" ); DEFSTATICTSCP( c2931 ); DEFCSTRING( t3591, ". " ); DEFSTATICTSCP( c2911 ); DEFCSTRING( t3592, "(" ); DEFSTATICTSCP( c2889 ); DEFSTATICTSCP( c2864 ); DEFSTATICTSCP( t3593 ); DEFSTATICTSCP( t3594 ); DEFSTATICTSCP( t3595 ); DEFSTATICTSCP( c2833 ); DEFSTATICTSCP( c2772 ); DEFCSTRING( t3596, "***** WARNING - ~a ~a" ); DEFSTATICTSCP( c2724 ); DEFCSTRING( t3597, " ~a" ); DEFSTATICTSCP( c2712 ); DEFCSTRING( t3598, "***** ERROR - ~a ~a" ); DEFSTATICTSCP( c2688 ); DEFCSTRING( t3599, " ***** Code Generation ***** */~%" ); DEFSTATICTSCP( c2674 ); DEFSTATICTSCP( c2671 ); DEFSTATICTSCP( c2637 ); DEFCSTRING( t3600, " ***** Closure Analysis *****~%" ); DEFSTATICTSCP( c2573 ); DEFCSTRING( t3601, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2563 ); DEFSTATICTSCP( c2562 ); DEFCSTRING( t3602, " ***** Transformations *****~%" ); DEFSTATICTSCP( c2483 ); DEFCSTRING( t3603, "/* ***** Expand Forms *****~%" ); DEFSTATICTSCP( c2480 ); DEFSTATICTSCP( c2473 ); DEFCSTRING( t3604, "scltext.sc" ); DEFSTATICTSCP( c2472 ); DEFSTATICTSCP( c2448 ); DEFSTATICTSCP( t3605 ); DEFSTATICTSCP( t3606 ); DEFSTATICTSCP( c2393 ); DEFCSTRING( t3607, "Duplicate option:" ); DEFSTATICTSCP( c2386 ); DEFCSTRING( t3608, "Unrecognized option:" ); DEFSTATICTSCP( c2339 ); DEFSTATICTSCP( c2333 ); DEFSTATICTSCP( c2326 ); DEFSTATICTSCP( c2309 ); DEFSTATICTSCP( c2305 ); DEFCSTRING( t3609, ".c" ); DEFSTATICTSCP( c2272 ); DEFSTATICTSCP( c2236 ); DEFSTATICTSCP( t3610 ); DEFCSTRING( t3611, ".sc" ); DEFSTATICTSCP( c2202 ); DEFCSTRING( t3612, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c2201 ); DEFSTATICTSCP( c2200 ); DEFCSTRING( t3613, "Illegal predefinition form:" ); DEFSTATICTSCP( c2176 ); DEFSTATICTSCP( c2167 ); DEFSTATICTSCP( c2165 ); DEFSTATICTSCP( c2163 ); DEFSTATICTSCP( c2161 ); DEFSTATICTSCP( c2159 ); DEFSTATICTSCP( c2158 ); DEFSTATICTSCP( c2157 ); DEFSTATICTSCP( c2156 ); DEFSTATICTSCP( c2152 ); DEFSTATICTSCP( c2150 ); DEFSTATICTSCP( c2148 ); DEFSTATICTSCP( c2146 ); DEFSTATICTSCP( c2144 ); DEFSTATICTSCP( c2142 ); DEFSTATICTSCP( c2140 ); DEFSTATICTSCP( c2138 ); DEFSTATICTSCP( c2136 ); DEFSTATICTSCP( c2134 ); DEFSTATICTSCP( c2132 ); DEFSTATICTSCP( c2130 ); DEFSTATICTSCP( c2127 ); DEFSTATICTSCP( c2126 ); DEFSTATICTSCP( c2124 ); DEFSTATICTSCP( c2122 ); DEFSTATICTSCP( c2120 ); DEFSTATICTSCP( c2118 ); DEFSTATICTSCP( c2116 ); DEFSTATICTSCP( c2115 ); DEFCSTRING( t3614, "EMPTYLIST" ); DEFSTATICTSCP( c2108 ); DEFCSTRING( t3615, "FALSEVALUE" ); DEFSTATICTSCP( c2098 ); DEFSTATICTSCP( c2094 ); DEFSTATICTSCP( c2090 ); DEFSTATICTSCP( c2089 ); DEFCSTRING( t3616, "TRUEVALUE" ); DEFSTATICTSCP( c2085 ); DEFSTATICTSCP( c2084 ); DEFSTATICTSCP( c2080 ); DEFCSTRING( t3617, "*initialize*" ); DEFSTATICTSCP( c2079 ); DEFSTATICTSCP( c2076 ); DEFSTATICTSCP( c2075 ); DEFSTATICTSCP( c2068 ); DEFSTATICTSCP( c2067 ); DEFSTATICTSCP( c2053 ); DEFSTATICTSCP( c2051 ); DEFSTATICTSCP( c2049 ); DEFSTATICTSCP( c2044 ); DEFSTATICTSCP( c2038 ); DEFSTATICTSCP( t3618 ); DEFSTATICTSCP( t3619 ); DEFSTATICTSCP( c2029 ); static void init_constants() { lexical_2dfree_2dvars_v = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL-FRE\ E-VARS" ) ); CONSTANTEXP( ADR( lexical_2dfree_2dvars_v ) ); lexical_2dbound_2dvars_v = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL-BO\ UND-VARS" ) ); CONSTANTEXP( ADR( lexical_2dbound_2dvars_v ) ); current_2dlambda_2did_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-LAM\ BDA-ID" ) ); CONSTANTEXP( ADR( current_2dlambda_2did_v ) ); quote_2dconstants_v = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE-CONSTANTS\ " ) ); CONSTANTEXP( ADR( quote_2dconstants_v ) ); lap_2dcode_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAP-CODE" ) ); CONSTANTEXP( ADR( lap_2dcode_v ) ); predef_2ddefault_v = STRINGTOSYMBOL( CSTRING_TSCP( "PREDEF-DEFAULT" ) ); CONSTANTEXP( ADR( predef_2ddefault_v ) ); copy_2dplist_v = STRINGTOSYMBOL( CSTRING_TSCP( "COPY-PLIST" ) ); CONSTANTEXP( ADR( copy_2dplist_v ) ); global_2dfree_2dvars_v = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL-FREE-\ VARS" ) ); CONSTANTEXP( ADR( global_2dfree_2dvars_v ) ); make_2dalpha_2dseq_v = STRINGTOSYMBOL( CSTRING_TSCP( "MAKE-ALPHA-SEQ\ " ) ); CONSTANTEXP( ADR( make_2dalpha_2dseq_v ) ); lap_2dexp_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAP-EXP" ) ); CONSTANTEXP( ADR( lap_2dexp_v ) ); quote_2dexp_v = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE-EXP" ) ); CONSTANTEXP( ADR( quote_2dexp_v ) ); set_21_2dexp_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET!-EXP" ) ); CONSTANTEXP( ADR( set_21_2dexp_v ) ); if_2dexp_v = STRINGTOSYMBOL( CSTRING_TSCP( "IF-EXP" ) ); CONSTANTEXP( ADR( if_2dexp_v ) ); define_2dexp_v = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-EXP" ) ); CONSTANTEXP( ADR( define_2dexp_v ) ); old_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "OLD-MACRO" ) ); CONSTANTEXP( ADR( old_2dmacro_v ) ); quasiquote_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "QUASIQUOTE-MAC\ RO" ) ); CONSTANTEXP( ADR( quasiquote_2dmacro_v ) ); cond_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "COND-MACRO" ) ); CONSTANTEXP( ADR( cond_2dmacro_v ) ); case_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "CASE-MACRO" ) ); CONSTANTEXP( ADR( case_2dmacro_v ) ); and_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "AND-MACRO" ) ); CONSTANTEXP( ADR( and_2dmacro_v ) ); or_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "OR-MACRO" ) ); CONSTANTEXP( ADR( or_2dmacro_v ) ); not_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "NOT-MACRO" ) ); CONSTANTEXP( ADR( not_2dmacro_v ) ); begin_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "BEGIN-MACRO" ) ); CONSTANTEXP( ADR( begin_2dmacro_v ) ); let_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "LET-MACRO" ) ); CONSTANTEXP( ADR( let_2dmacro_v ) ); let_2a_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "LET*-MACRO" ) ); CONSTANTEXP( ADR( let_2a_2dmacro_v ) ); letrec_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "LETREC-MACRO" ) ); CONSTANTEXP( ADR( letrec_2dmacro_v ) ); do_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "DO-MACRO" ) ); CONSTANTEXP( ADR( do_2dmacro_v ) ); when_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "WHEN-MACRO" ) ); CONSTANTEXP( ADR( when_2dmacro_v ) ); unless_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "UNLESS-MACRO" ) ); CONSTANTEXP( ADR( unless_2dmacro_v ) ); quote_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE-MACRO" ) ); CONSTANTEXP( ADR( quote_2dmacro_v ) ); lap_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAP-MACRO" ) ); CONSTANTEXP( ADR( lap_2dmacro_v ) ); define_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-MACRO" ) ); CONSTANTEXP( ADR( define_2dmacro_v ) ); define_2dmacro_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-MAC\ RO-MACRO" ) ); CONSTANTEXP( ADR( define_2dmacro_2dmacro_v ) ); define_2dconstant_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-\ CONSTANT-MACRO" ) ); CONSTANTEXP( ADR( define_2dconstant_2dmacro_v ) ); eval_2dwhen_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "EVAL-WHEN-MAC\ RO" ) ); CONSTANTEXP( ADR( eval_2dwhen_2dmacro_v ) ); lambda_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA-MACRO" ) ); CONSTANTEXP( ADR( lambda_2dmacro_v ) ); lambda_2dexp_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA-EXP" ) ); CONSTANTEXP( ADR( lambda_2dexp_v ) ); load_2dplist_2dlap_v = STRINGTOSYMBOL( CSTRING_TSCP( "LOAD-PLIST-LAP\ " ) ); CONSTANTEXP( ADR( load_2dplist_2dlap_v ) ); read_2dtext_v = STRINGTOSYMBOL( CSTRING_TSCP( "READ-TEXT" ) ); CONSTANTEXP( ADR( read_2dtext_v ) ); expand_2dforms_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXPAND-FORMS" ) ); CONSTANTEXP( ADR( expand_2dforms_v ) ); analyze_2dclosures1a_v = STRINGTOSYMBOL( CSTRING_TSCP( "ANALYZE-CLOS\ URES1A" ) ); CONSTANTEXP( ADR( analyze_2dclosures1a_v ) ); analyze_2dclosures1b_v = STRINGTOSYMBOL( CSTRING_TSCP( "ANALYZE-CLOS\ URES1B" ) ); CONSTANTEXP( ADR( analyze_2dclosures1b_v ) ); transform_v = STRINGTOSYMBOL( CSTRING_TSCP( "TRANSFORM" ) ); CONSTANTEXP( ADR( transform_v ) ); analyze_2dclosures2_v = STRINGTOSYMBOL( CSTRING_TSCP( "ANALYZE-CLOSU\ RES2" ) ); CONSTANTEXP( ADR( analyze_2dclosures2_v ) ); walk_2d_24tree_v = STRINGTOSYMBOL( CSTRING_TSCP( "WALK-$TREE" ) ); CONSTANTEXP( ADR( walk_2d_24tree_v ) ); print_2dlambda_2dinfo_v = STRINGTOSYMBOL( CSTRING_TSCP( "PRINT-LAMBD\ A-INFO" ) ); CONSTANTEXP( ADR( print_2dlambda_2dinfo_v ) ); generate_2dcode_v = STRINGTOSYMBOL( CSTRING_TSCP( "GENERATE-CODE" ) ); CONSTANTEXP( ADR( generate_2dcode_v ) ); c3404 = CSTRING_TSCP( t3582 ); CONSTANTEXP( ADR( c3404 ) ); c3383 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-REF" ) ); CONSTANTEXP( ADR( c3383 ) ); c3377 = CSTRING_TSCP( t3583 ); CONSTANTEXP( ADR( c3377 ) ); c3356 = CSTRING_TSCP( t3584 ); CONSTANTEXP( ADR( c3356 ) ); c3353 = CSTRING_TSCP( t3585 ); CONSTANTEXP( ADR( c3353 ) ); c3352 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-SET!" ) ); CONSTANTEXP( ADR( c3352 ) ); c3313 = CSTRING_TSCP( t3586 ); CONSTANTEXP( ADR( c3313 ) ); c3312 = CSTRING_TSCP( t3587 ); CONSTANTEXP( ADR( c3312 ) ); c3311 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c3311 ) ); c3217 = STRINGTOSYMBOL( CSTRING_TSCP( "<-" ) ); CONSTANTEXP( ADR( c3217 ) ); c3072 = STRINGTOSYMBOL( CSTRING_TSCP( "OPTVARS" ) ); CONSTANTEXP( ADR( c3072 ) ); c3069 = STRINGTOSYMBOL( CSTRING_TSCP( "REQVARS" ) ); CONSTANTEXP( ADR( c3069 ) ); c2989 = CSTRING_TSCP( t3588 ); CONSTANTEXP( ADR( c2989 ) ); c2933 = CSTRING_TSCP( t3589 ); CONSTANTEXP( ADR( c2933 ) ); c2931 = CSTRING_TSCP( t3590 ); CONSTANTEXP( ADR( c2931 ) ); c2911 = CSTRING_TSCP( t3591 ); CONSTANTEXP( ADR( c2911 ) ); c2889 = CSTRING_TSCP( t3592 ); CONSTANTEXP( ADR( c2889 ) ); c2864 = EMPTYLIST; t3593 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); c2864 = CONS( t3593, c2864 ); t3594 = STRINGTOSYMBOL( CSTRING_TSCP( "$IF" ) ); c2864 = CONS( t3594, c2864 ); t3595 = STRINGTOSYMBOL( CSTRING_TSCP( "$DEFINE" ) ); c2864 = CONS( t3595, c2864 ); CONSTANTEXP( ADR( c2864 ) ); c2833 = STRINGTOSYMBOL( CSTRING_TSCP( "" ) ); CONSTANTEXP( ADR( c2833 ) ); c2772 = STRINGTOSYMBOL( CSTRING_TSCP( "$CALL" ) ); CONSTANTEXP( ADR( c2772 ) ); c2724 = CSTRING_TSCP( t3596 ); CONSTANTEXP( ADR( c2724 ) ); c2712 = CSTRING_TSCP( t3597 ); CONSTANTEXP( ADR( c2712 ) ); c2688 = CSTRING_TSCP( t3598 ); CONSTANTEXP( ADR( c2688 ) ); c2674 = CSTRING_TSCP( t3599 ); CONSTANTEXP( ADR( c2674 ) ); c2671 = STRINGTOSYMBOL( CSTRING_TSCP( "TREE" ) ); CONSTANTEXP( ADR( c2671 ) ); c2637 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); CONSTANTEXP( ADR( c2637 ) ); c2573 = CSTRING_TSCP( t3600 ); CONSTANTEXP( ADR( c2573 ) ); c2563 = CSTRING_TSCP( t3601 ); CONSTANTEXP( ADR( c2563 ) ); c2562 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2562 ) ); c2483 = CSTRING_TSCP( t3602 ); CONSTANTEXP( ADR( c2483 ) ); c2480 = CSTRING_TSCP( t3603 ); CONSTANTEXP( ADR( c2480 ) ); c2473 = STRINGTOSYMBOL( CSTRING_TSCP( "SCLTEXT" ) ); CONSTANTEXP( ADR( c2473 ) ); c2472 = CSTRING_TSCP( t3604 ); CONSTANTEXP( ADR( c2472 ) ); c2448 = EMPTYLIST; t3605 = STRINGTOSYMBOL( CSTRING_TSCP( "TEST" ) ); c2448 = CONS( t3605, c2448 ); t3606 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); c2448 = CONS( t3606, c2448 ); CONSTANTEXP( ADR( c2448 ) ); c2393 = STRINGTOSYMBOL( CSTRING_TSCP( "SC-DONE" ) ); CONSTANTEXP( ADR( c2393 ) ); c2386 = CSTRING_TSCP( t3607 ); CONSTANTEXP( ADR( c2386 ) ); c2339 = CSTRING_TSCP( t3608 ); CONSTANTEXP( ADR( c2339 ) ); c2333 = STRINGTOSYMBOL( CSTRING_TSCP( "PREDEF" ) ); CONSTANTEXP( ADR( c2333 ) ); c2326 = STRINGTOSYMBOL( CSTRING_TSCP( "NOTRACE" ) ); CONSTANTEXP( ADR( c2326 ) ); c2309 = STRINGTOSYMBOL( CSTRING_TSCP( "LOG" ) ); CONSTANTEXP( ADR( c2309 ) ); c2305 = STRINGTOSYMBOL( CSTRING_TSCP( "ERROR" ) ); CONSTANTEXP( ADR( c2305 ) ); c2272 = CSTRING_TSCP( t3609 ); CONSTANTEXP( ADR( c2272 ) ); c2236 = EMPTYLIST; c2236 = CONS( c2333, c2236 ); t3610 = STRINGTOSYMBOL( CSTRING_TSCP( "PROFILE" ) ); c2236 = CONS( t3610, c2236 ); c2236 = CONS( c2309, c2236 ); c2236 = CONS( c2305, c2236 ); CONSTANTEXP( ADR( c2236 ) ); c2202 = CSTRING_TSCP( t3611 ); CONSTANTEXP( ADR( c2202 ) ); c2201 = CSTRING_TSCP( t3612 ); CONSTANTEXP( ADR( c2201 ) ); c2200 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c2200 ) ); c2176 = CSTRING_TSCP( t3613 ); CONSTANTEXP( ADR( c2176 ) ); c2167 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2167 ) ); c2165 = STRINGTOSYMBOL( CSTRING_TSCP( "EVAL-WHEN" ) ); CONSTANTEXP( ADR( c2165 ) ); c2163 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-CONSTANT" ) ); CONSTANTEXP( ADR( c2163 ) ); c2161 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-MACRO" ) ); CONSTANTEXP( ADR( c2161 ) ); c2159 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-C-EXTERNAL" ) ); CONSTANTEXP( ADR( c2159 ) ); c2158 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-EXTERNAL" ) ); CONSTANTEXP( ADR( c2158 ) ); c2157 = STRINGTOSYMBOL( CSTRING_TSCP( "INCLUDE" ) ); CONSTANTEXP( ADR( c2157 ) ); c2156 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); CONSTANTEXP( ADR( c2156 ) ); c2152 = STRINGTOSYMBOL( CSTRING_TSCP( "UNLESS" ) ); CONSTANTEXP( ADR( c2152 ) ); c2150 = STRINGTOSYMBOL( CSTRING_TSCP( "WHEN" ) ); CONSTANTEXP( ADR( c2150 ) ); c2148 = STRINGTOSYMBOL( CSTRING_TSCP( "DO" ) ); CONSTANTEXP( ADR( c2148 ) ); c2146 = STRINGTOSYMBOL( CSTRING_TSCP( "LETREC" ) ); CONSTANTEXP( ADR( c2146 ) ); c2144 = STRINGTOSYMBOL( CSTRING_TSCP( "LET*" ) ); CONSTANTEXP( ADR( c2144 ) ); c2142 = STRINGTOSYMBOL( CSTRING_TSCP( "LET" ) ); CONSTANTEXP( ADR( c2142 ) ); c2140 = STRINGTOSYMBOL( CSTRING_TSCP( "BEGIN" ) ); CONSTANTEXP( ADR( c2140 ) ); c2138 = STRINGTOSYMBOL( CSTRING_TSCP( "NOT" ) ); CONSTANTEXP( ADR( c2138 ) ); c2136 = STRINGTOSYMBOL( CSTRING_TSCP( "OR" ) ); CONSTANTEXP( ADR( c2136 ) ); c2134 = STRINGTOSYMBOL( CSTRING_TSCP( "AND" ) ); CONSTANTEXP( ADR( c2134 ) ); c2132 = STRINGTOSYMBOL( CSTRING_TSCP( "CASE" ) ); CONSTANTEXP( ADR( c2132 ) ); c2130 = STRINGTOSYMBOL( CSTRING_TSCP( "COND" ) ); CONSTANTEXP( ADR( c2130 ) ); c2127 = STRINGTOSYMBOL( CSTRING_TSCP( "MACRO" ) ); CONSTANTEXP( ADR( c2127 ) ); c2126 = STRINGTOSYMBOL( CSTRING_TSCP( "QUASIQUOTE" ) ); CONSTANTEXP( ADR( c2126 ) ); c2124 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE" ) ); CONSTANTEXP( ADR( c2124 ) ); c2122 = STRINGTOSYMBOL( CSTRING_TSCP( "IF" ) ); CONSTANTEXP( ADR( c2122 ) ); c2120 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2120 ) ); c2118 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2118 ) ); c2116 = STRINGTOSYMBOL( CSTRING_TSCP( "EXPAND" ) ); CONSTANTEXP( ADR( c2116 ) ); c2115 = STRINGTOSYMBOL( CSTRING_TSCP( "LAP" ) ); CONSTANTEXP( ADR( c2115 ) ); c2108 = CSTRING_TSCP( t3614 ); CONSTANTEXP( ADR( c2108 ) ); c2098 = CSTRING_TSCP( t3615 ); CONSTANTEXP( ADR( c2098 ) ); c2094 = STRINGTOSYMBOL( CSTRING_TSCP( "VALUE" ) ); CONSTANTEXP( ADR( c2094 ) ); c2090 = STRINGTOSYMBOL( CSTRING_TSCP( "CONSTANT" ) ); CONSTANTEXP( ADR( c2090 ) ); c2089 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2089 ) ); c2085 = CSTRING_TSCP( t3616 ); CONSTANTEXP( ADR( c2085 ) ); c2084 = STRINGTOSYMBOL( CSTRING_TSCP( "VNAME" ) ); CONSTANTEXP( ADR( c2084 ) ); c2080 = STRINGTOSYMBOL( CSTRING_TSCP( "NULL-PROPERTY" ) ); CONSTANTEXP( ADR( c2080 ) ); c2079 = CSTRING_TSCP( t3617 ); CONSTANTEXP( ADR( c2079 ) ); c2076 = STRINGTOSYMBOL( CSTRING_TSCP( "CONS" ) ); CONSTANTEXP( ADR( c2076 ) ); c2075 = STRINGTOSYMBOL( CSTRING_TSCP( "$_UNDEFINED" ) ); CONSTANTEXP( ADR( c2075 ) ); c2068 = STRINGTOSYMBOL( CSTRING_TSCP( "INITIAL-SCC" ) ); CONSTANTEXP( ADR( c2068 ) ); c2067 = STRINGTOSYMBOL( CSTRING_TSCP( "SCC" ) ); CONSTANTEXP( ADR( c2067 ) ); c2053 = STRINGTOSYMBOL( CSTRING_TSCP( "EMPTY-LIST-ALPHA" ) ); CONSTANTEXP( ADR( c2053 ) ); c2051 = STRINGTOSYMBOL( CSTRING_TSCP( "FALSE-ALPHA" ) ); CONSTANTEXP( ADR( c2051 ) ); c2049 = STRINGTOSYMBOL( CSTRING_TSCP( "TRUE-ALPHA" ) ); CONSTANTEXP( ADR( c2049 ) ); c2044 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); CONSTANTEXP( ADR( c2044 ) ); c2038 = EMPTYLIST; c2038 = CONS( c2671, c2038 ); c2038 = CONS( c2167, c2038 ); c2038 = CONS( transform_v, c2038 ); t3618 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED" ) ); c2038 = CONS( t3618, c2038 ); c2038 = CONS( c2116, c2038 ); c2038 = CONS( c2127, c2038 ); t3619 = STRINGTOSYMBOL( CSTRING_TSCP( "SOURCE" ) ); c2038 = CONS( t3619, c2038 ); CONSTANTEXP( ADR( c2038 ) ); c2029 = EMPTYLIST; c2029 = CONS( EMPTYSTRING, c2029 ); CONSTANTEXP( ADR( c2029 ) ); } DEFTSCP( compile_sc_2dinput_v ); DEFCSTRING( t3620, "SC-INPUT" ); DEFTSCP( compile_sc_2dsplice_v ); DEFCSTRING( t3621, "SC-SPLICE" ); DEFTSCP( compile_sc_2dsource_2dname_v ); DEFCSTRING( t3622, "SC-SOURCE-NAME" ); DEFTSCP( compile_sc_2dinclude_2ddirs_v ); DEFCSTRING( t3623, "SC-INCLUDE-DIRS" ); DEFTSCP( compile_sc_2dicode_v ); DEFCSTRING( t3624, "SC-ICODE" ); DEFTSCP( compile_sc_2derror_v ); DEFCSTRING( t3625, "SC-ERROR" ); DEFTSCP( compile_sc_2derror_2dcnt_v ); DEFCSTRING( t3626, "SC-ERROR-CNT" ); DEFTSCP( compile_sc_2dlog_v ); DEFCSTRING( t3627, "SC-LOG" ); DEFTSCP( compile_sc_2dstack_2dtrace_v ); DEFCSTRING( t3628, "SC-STACK-TRACE" ); DEFTSCP( compile_sc_2dinterpreter_v ); DEFCSTRING( t3629, "SC-INTERPRETER" ); DEFTSCP( compile_sc_2dlog_2ddefault_v ); DEFCSTRING( t3630, "SC-LOG-DEFAULT" ); DEFTSCP( compile_module_2dname_v ); DEFCSTRING( t3631, "MODULE-NAME" ); EXTERNTSCP( sc_emptystring ); DEFTSCP( compile_e_2dupcase_6e1220a4_v ); DEFCSTRING( t3632, "MODULE-NAME-UPCASE" ); DEFTSCP( compile_main_2dprogram_2dname_v ); DEFCSTRING( t3633, "MAIN-PROGRAM-NAME" ); DEFTSCP( compile_heap_2dsize_v ); DEFCSTRING( t3634, "HEAP-SIZE" ); DEFTSCP( compile_ine_2dname_3e60377e_v ); DEFCSTRING( t3635, "CURRENT-DEFINE-NAME" ); DEFTSCP( compile_top_2dlevel_2dsymbols_v ); DEFCSTRING( t3636, "TOP-LEVEL-SYMBOLS" ); DEFTSCP( compile_with_2dmodules_v ); DEFCSTRING( t3637, "WITH-MODULES" ); DEFTSCP( compile_restore_2dplist_v ); DEFCSTRING( t3638, "RESTORE-PLIST" ); DEFTSCP( compile_true_2dalpha_v ); DEFCSTRING( t3639, "TRUE-ALPHA" ); DEFTSCP( compile_false_2dalpha_v ); DEFCSTRING( t3640, "FALSE-ALPHA" ); DEFTSCP( compile_empty_2dlist_2dalpha_v ); DEFCSTRING( t3641, "EMPTY-LIST-ALPHA" ); DEFTSCP( compile_cons_2dalpha_v ); DEFCSTRING( t3642, "CONS-ALPHA" ); DEFTSCP( compile_undefined_2dalpha_v ); DEFCSTRING( t3643, "UNDEFINED-ALPHA" ); DEFTSCP( compile_initialize_2dcompile_v ); DEFCSTRING( t3644, "INITIALIZE-COMPILE" ); EXTERNTSCPP( compile_create_2dplist, XAL1( TSCP ) ); EXTERNTSCP( compile_create_2dplist_v ); TSCP compile_l2072( c3650 ) TSCP c3650; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "compile_l2072 [inside INITIALIZE-COMPILE]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c3650, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3650, 1 ); SETGENTL( SYMBOL_VALUE( global_2dfree_2dvars_v ), DISPLAY( 1 ) ); SETGENTL( SYMBOL_VALUE( make_2dalpha_2dseq_v ), DISPLAY( 0 ) ); X4 = SYMBOL_VALUE( copy_2dplist_v ); X4 = UNKNOWNCALL( X4, 2 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( c2068, c2067, PROCEDURE_CLOSURE( X4 ) ); DISPLAY( 1 ) = X1; DISPLAY( 0 ) = X2; POPSTACKTRACE( X3 ); } EXTERNTSCPP( expform_bound, XAL1( TSCP ) ); EXTERNTSCP( expform_bound_v ); TSCP compile_initialize_2dcompile( ) { TSCP X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SDVAL; PUSHSTACKTRACE( t3644 ); SETGENTL( SYMBOL_VALUE( lexical_2dfree_2dvars_v ), EMPTYLIST ); SETGENTL( SYMBOL_VALUE( lexical_2dbound_2dvars_v ), EMPTYLIST ); SETGENTL( SYMBOL_VALUE( current_2dlambda_2did_v ), c2044 ); SETGENTL( SYMBOL_VALUE( quote_2dconstants_v ), EMPTYLIST ); SETGENTL( SYMBOL_VALUE( lap_2dcode_v ), EMPTYLIST ); compile_sc_2dlog_v = EMPTYLIST; compile_sc_2dstack_2dtrace_v = TRUEVALUE; compile_sc_2dinterpreter_v = FALSEVALUE; if ( FALSE( compile_restore_2dplist_v ) ) goto L3646; X1 = compile_restore_2dplist_v; X1 = UNKNOWNCALL( X1, 0 ); VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ); goto L3647; L3646: X1 = SYMBOL_VALUE( predef_2ddefault_v ); compile_create_2dplist( X1 ); X1 = SYMBOL_VALUE( copy_2dplist_v ); X1 = UNKNOWNCALL( X1, 2 ); VIA( PROCEDURE_CODE( X1 ) )( c2067, c2068, PROCEDURE_CLOSURE( X1 ) ); DISPLAY( 0 ) = SYMBOL_VALUE( make_2dalpha_2dseq_v ); DISPLAY( 1 ) = SYMBOL_VALUE( global_2dfree_2dvars_v ); compile_restore_2dplist_v = MAKEPROCEDURE( 0, 0, compile_l2072, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 1 ), DISPLAY( 0 ) ) ); L3647: compile_sc_2dinput_v = EMPTYLIST; compile_sc_2dsplice_v = EMPTYLIST; compile_sc_2dinclude_2ddirs_v = c2029; compile_sc_2dicode_v = EMPTYLIST; compile_sc_2derror_v = EMPTYLIST; compile_sc_2derror_2dcnt_v = _TSCP( 0 ); compile_main_2dprogram_2dname_v = EMPTYLIST; compile_heap_2dsize_v = _TSCP( 0 ); compile_ine_2dname_3e60377e_v = c2044; compile_top_2dlevel_2dsymbols_v = TRUEVALUE; compile_with_2dmodules_v = EMPTYLIST; compile_undefined_2dalpha_v = expform_bound( c2075 ); compile_cons_2dalpha_v = expform_bound( c2076 ); SDVAL = SET( compile_module_2dname_v, sc_emptystring ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; POPSTACKTRACE( SDVAL ); } DEFTSCP( compile_create_2dplist_v ); DEFCSTRING( t3652, "CREATE-PLIST" ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt5_open_2dinput_2dfile, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2dinput_2dfile_v ); EXTERNTSCPP( scrt6_eof_2dobject_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_eof_2dobject_3f_v ); EXTERNTSCPP( compile_report_2derror, XAL2( TSCP, TSCP ) ); EXTERNTSCP( compile_report_2derror_v ); EXTERNTSCPP( scrt5_close_2dport, XAL1( TSCP ) ); EXTERNTSCP( scrt5_close_2dport_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt2_max_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_max_2dtwo_v ); TSCP compile_create_2dplist( p2078 ) TSCP p2078; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3652 ); compile_module_2dname_v = c2079; X1 = SYMBOL_VALUE( copy_2dplist_v ); X1 = UNKNOWNCALL( X1, 2 ); VIA( PROCEDURE_CODE( X1 ) )( c2080, c2067, PROCEDURE_CLOSURE( X1 ) ); SETGENTL( SYMBOL_VALUE( global_2dfree_2dvars_v ), EMPTYLIST ); SETGENTL( SYMBOL_VALUE( make_2dalpha_2dseq_v ), _TSCP( 0 ) ); plist_put( c2049, c2084, c2085 ); plist_put( c2049, c2089, c2090 ); plist_put( c2049, c2094, TRUEVALUE ); plist_put( c2051, c2084, c2098 ); plist_put( c2051, c2089, c2090 ); plist_put( c2051, c2094, FALSEVALUE ); plist_put( c2053, c2084, c2108 ); plist_put( c2053, c2089, c2090 ); plist_put( c2053, c2094, EMPTYLIST ); X1 = SYMBOL_VALUE( lap_2dexp_v ); plist_put( c2115, c2116, X1 ); X1 = SYMBOL_VALUE( quote_2dexp_v ); plist_put( c2118, c2116, X1 ); X1 = SYMBOL_VALUE( set_21_2dexp_v ); plist_put( c2120, c2116, X1 ); X1 = SYMBOL_VALUE( if_2dexp_v ); plist_put( c2122, c2116, X1 ); X1 = SYMBOL_VALUE( define_2dexp_v ); plist_put( c2124, c2116, X1 ); X3 = SYMBOL_VALUE( quasiquote_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2126, c2127, X1 ); X3 = SYMBOL_VALUE( cond_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2130, c2127, X1 ); X3 = SYMBOL_VALUE( case_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2132, c2127, X1 ); X3 = SYMBOL_VALUE( and_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2134, c2127, X1 ); X3 = SYMBOL_VALUE( or_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2136, c2127, X1 ); X3 = SYMBOL_VALUE( not_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2138, c2127, X1 ); X3 = SYMBOL_VALUE( begin_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2140, c2127, X1 ); X3 = SYMBOL_VALUE( let_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2142, c2127, X1 ); X3 = SYMBOL_VALUE( let_2a_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2144, c2127, X1 ); X3 = SYMBOL_VALUE( letrec_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2146, c2127, X1 ); X3 = SYMBOL_VALUE( do_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2148, c2127, X1 ); X3 = SYMBOL_VALUE( when_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2150, c2127, X1 ); X3 = SYMBOL_VALUE( unless_2dmacro_v ); X2 = SYMBOL_VALUE( old_2dmacro_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ); plist_put( c2152, c2127, X1 ); X1 = SYMBOL_VALUE( quote_2dmacro_v ); plist_put( c2118, c2127, X1 ); X1 = SYMBOL_VALUE( lap_2dmacro_v ); plist_put( c2115, c2127, X1 ); X1 = SYMBOL_VALUE( quote_2dmacro_v ); plist_put( c2156, c2127, X1 ); X1 = SYMBOL_VALUE( quote_2dmacro_v ); plist_put( c2157, c2127, X1 ); X1 = SYMBOL_VALUE( quote_2dmacro_v ); plist_put( c2158, c2127, X1 ); X1 = SYMBOL_VALUE( quote_2dmacro_v ); plist_put( c2159, c2127, X1 ); X1 = SYMBOL_VALUE( define_2dmacro_v ); plist_put( c2124, c2127, X1 ); X1 = SYMBOL_VALUE( define_2dmacro_2dmacro_v ); plist_put( c2161, c2127, X1 ); X1 = SYMBOL_VALUE( define_2dconstant_2dmacro_v ); plist_put( c2163, c2127, X1 ); X1 = SYMBOL_VALUE( eval_2dwhen_2dmacro_v ); plist_put( c2165, c2127, X1 ); X1 = SYMBOL_VALUE( lambda_2dmacro_v ); plist_put( c2167, c2127, X1 ); X1 = SYMBOL_VALUE( lambda_2dexp_v ); plist_put( c2167, c2116, X1 ); X1 = SYMBOL_VALUE( load_2dplist_2dlap_v ); X1 = UNKNOWNCALL( X1, 0 ); VIA( PROCEDURE_CODE( X1 ) )( PROCEDURE_CLOSURE( X1 ) ); X2 = scrt5_open_2dinput_2dfile( p2078 ); X1 = sc_cons( X2, EMPTYLIST ); compile_sc_2dinput_v = X1; X2 = SYMBOL_VALUE( read_2dtext_v ); X2 = UNKNOWNCALL( X2, 0 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( PROCEDURE_CLOSURE( X2 ) ); if ( TRUE( scrt6_eof_2dobject_3f( X1 ) ) ) goto L3656; compile_report_2derror( c2176, CONS( X1, EMPTYLIST ) ); L3656: X2 = compile_sc_2dinput_v; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3659; scrt1__24__car_2derror( X2 ); L3659: X1 = PAIR_CAR( X2 ); scrt5_close_2dport( X1 ); compile_sc_2dinput_v = EMPTYLIST; X1 = SYMBOL_VALUE( make_2dalpha_2dseq_v ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 8000 ) ) ), 3 ) ) goto L3662; if ( LTE( _S2CINT( X1 ), _S2CINT( _TSCP( 8000 ) ) ) ) goto L3664; X2 = X1; goto L3663; L3664: X2 = _TSCP( 8000 ); goto L3663; L3662: X2 = scrt2_max_2dtwo( X1, _TSCP( 8000 ) ); L3663: SETGENTL( SYMBOL_VALUE( make_2dalpha_2dseq_v ), X2 ); compile_undefined_2dalpha_v = expform_bound( c2075 ); compile_cons_2dalpha_v = expform_bound( c2076 ); POPSTACKTRACE( SET( compile_module_2dname_v, sc_emptystring ) ); } DEFTSCP( compile_sc_v ); DEFCSTRING( t3666, "SC" ); EXTERNTSCPP( compile_string_2ddowncase, XAL1( TSCP ) ); EXTERNTSCP( compile_string_2ddowncase_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( scrt5_output_2dport_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt5_output_2dport_3f_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( scrt5_open_2doutput_2dfile, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2doutput_2dfile_v ); EXTERNTSCPP( compile_docompile, XAL0( ) ); EXTERNTSCP( compile_docompile_v ); EXTERNTSCPP( compile_close_2dsc_2dfiles, XAL0( ) ); EXTERNTSCP( compile_close_2dsc_2dfiles_v ); TSCP compile_sc( i2191, o2192 ) TSCP i2191, o2192; { TSCP X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3666 ); i2191 = CONS( i2191, EMPTYLIST ); o2192 = CONS( o2192, EMPTYLIST ); compile_initialize_2dcompile( ); if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( i2191 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( i2191 ) ), SYMBOLTAG ) ) ) ) goto L3668; X3 = PAIR_CAR( i2191 ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) goto L3671; scdebug_error( c2200, c2201, CONS( X3, EMPTYLIST ) ); L3671: X2 = SYMBOL_NAME( X3 ); X1 = compile_string_2ddowncase( X2 ); SETGEN( PAIR_CAR( i2191 ), X1 ); L3668: X1 = CONS( c2202, EMPTYLIST ); compile_sc_2dsource_2dname_v = scrt3_string_2dappend( CONS( PAIR_CAR( i2191 ), X1 ) ); X2 = scrt5_open_2dinput_2dfile( compile_sc_2dsource_2dname_v ); X1 = sc_cons( X2, EMPTYLIST ); compile_sc_2dinput_v = X1; X1 = PAIR_CAR( o2192 ); if ( FALSE( X1 ) ) goto L3690; X3 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3681; scrt1__24__car_2derror( X3 ); L3681: X2 = PAIR_CAR( X3 ); if ( FALSE( scrt5_output_2dport_3f( X2 ) ) ) goto L3690; X2 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3685; scrt1__24__car_2derror( X2 ); L3685: compile_sc_2dicode_v = PAIR_CAR( X2 ); X3 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3688; scrt1__24__cdr_2derror( X3 ); L3688: X2 = PAIR_CDR( X3 ); SETGEN( PAIR_CAR( o2192 ), X2 ); goto L3691; L3690: X2 = BOOLEAN( EQ( _S2CUINT( PAIR_CAR( o2192 ) ), _S2CUINT( EMPTYLIST ) ) ); if ( TRUE( X2 ) ) goto L3696; X4 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3701; scrt1__24__car_2derror( X4 ); L3701: X3 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3696; X4 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3707; scrt1__24__car_2derror( X4 ); L3707: X3 = PAIR_CAR( X4 ); if ( TRUE( scrt1_memq( X3, c2236 ) ) ) goto L3696; X5 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3710; scrt1__24__car_2derror( X5 ); L3710: X4 = PAIR_CAR( X5 ); X3 = BOOLEAN( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), SYMBOLTAG ) ) ); if ( TRUE( X3 ) ) goto L3716; X5 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3720; scrt1__24__car_2derror( X5 ); L3720: X4 = PAIR_CAR( X5 ); if ( NOT( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), STRINGTAG ) ) ) ) goto L3691; L3716: X3 = CONS( c2272, EMPTYLIST ); X6 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3726; scrt1__24__car_2derror( X6 ); L3726: X5 = PAIR_CAR( X6 ); if ( NOT( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), SYMBOLTAG ) ) ) ) goto L3723; X7 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3729; scrt1__24__car_2derror( X7 ); L3729: X6 = PAIR_CAR( X7 ); if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), SYMBOLTAG ) ) ) goto L3732; scdebug_error( c2200, c2201, CONS( X6, EMPTYLIST ) ); L3732: X5 = SYMBOL_NAME( X6 ); X4 = compile_string_2ddowncase( X5 ); goto L3724; L3723: X5 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3735; scrt1__24__car_2derror( X5 ); L3735: X4 = PAIR_CAR( X5 ); L3724: X2 = scrt3_string_2dappend( CONS( X4, X3 ) ); compile_sc_2dicode_v = scrt5_open_2doutput_2dfile( X2 ); X3 = PAIR_CAR( o2192 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3738; scrt1__24__cdr_2derror( X3 ); L3738: X2 = PAIR_CDR( X3 ); SETGEN( PAIR_CAR( o2192 ), X2 ); goto L3691; L3696: X3 = CONS( c2272, EMPTYLIST ); X2 = scrt3_string_2dappend( CONS( PAIR_CAR( i2191 ), X3 ) ); compile_sc_2dicode_v = scrt5_open_2doutput_2dfile( X2 ); L3691: X1 = PAIR_CAR( o2192 ); X2 = EMPTYLIST; X3 = EMPTYLIST; L3741: X2 = CONS( X2, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); if ( NEQ( _S2CUINT( PAIR_CAR( X1 ) ), _S2CUINT( EMPTYLIST ) ) ) goto L3742; compile_docompile( ); goto L3743; L3742: X5 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3746; scrt1__24__car_2derror( X5 ); L3746: X4 = PAIR_CAR( X5 ); SETGEN( PAIR_CAR( X2 ), X4 ); if ( FALSE( scrt1_memq( PAIR_CAR( X2 ), X3 ) ) ) goto L3748; compile_report_2derror( c2386, CONS( PAIR_CAR( X2 ), EMPTYLIST ) ); goto L3768; L3748: if ( NEQ( _S2CUINT( PAIR_CAR( X2 ) ), _S2CUINT( c2305 ) ) ) goto L3750; compile_sc_2derror_v = TRUEVALUE; goto L3768; L3750: if ( NEQ( _S2CUINT( PAIR_CAR( X2 ) ), _S2CUINT( c2309 ) ) ) goto L3752; compile_sc_2dlog_v = compile_sc_2dlog_2ddefault_v; goto L3768; L3752: X4 = BOOLEAN( EQ( TSCPTAG( PAIR_CAR( X2 ) ), PAIRTAG ) ); if ( FALSE( X4 ) ) goto L3767; X6 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3761; scrt1__24__car_2derror( X6 ); L3761: X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2309 ) ) ) goto L3767; X5 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3765; scrt1__24__cdr_2derror( X5 ); L3765: compile_sc_2dlog_v = PAIR_CDR( X5 ); X5 = c2309; SETGEN( PAIR_CAR( X2 ), X5 ); goto L3768; L3767: if ( NEQ( _S2CUINT( PAIR_CAR( X2 ) ), _S2CUINT( c2326 ) ) ) goto L3769; compile_sc_2dstack_2dtrace_v = FALSEVALUE; goto L3768; L3769: X5 = BOOLEAN( EQ( _S2CUINT( PAIR_CAR( X2 ) ), _S2CUINT( c2333 ) ) ); if ( FALSE( X5 ) ) goto L3810; X6 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3776; scrt1__24__cdr_2derror( X6 ); L3776: if ( FALSE( PAIR_CDR( X6 ) ) ) goto L3810; X8 = CONS( c2202, EMPTYLIST ); X11 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L3785; scrt1__24__cdr_2derror( X11 ); L3785: X12 = PAIR_CDR( X11 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L3788; scrt1__24__car_2derror( X12 ); L3788: X10 = PAIR_CAR( X12 ); if ( NOT( AND( EQ( TSCPTAG( X10 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X10 ), SYMBOLTAG ) ) ) ) goto L3781; X12 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L3792; scrt1__24__cdr_2derror( X12 ); L3792: X13 = PAIR_CDR( X12 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L3795; scrt1__24__car_2derror( X13 ); L3795: X11 = PAIR_CAR( X13 ); if ( AND( EQ( TSCPTAG( X11 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X11 ), SYMBOLTAG ) ) ) goto L3798; scdebug_error( c2200, c2201, CONS( X11, EMPTYLIST ) ); L3798: X10 = SYMBOL_NAME( X11 ); X9 = compile_string_2ddowncase( X10 ); goto L3782; L3781: X10 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3802; scrt1__24__cdr_2derror( X10 ); L3802: X11 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L3805; scrt1__24__car_2derror( X11 ); L3805: X9 = PAIR_CAR( X11 ); L3782: X7 = scrt3_string_2dappend( CONS( X9, X8 ) ); compile_create_2dplist( X7 ); X8 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3808; scrt1__24__cdr_2derror( X8 ); L3808: X7 = PAIR_CDR( X8 ); SETGEN( PAIR_CAR( X1 ), X7 ); goto L3768; L3810: compile_report_2derror( c2339, CONS( PAIR_CAR( X2 ), EMPTYLIST ) ); L3768: X5 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3812; scrt1__24__cdr_2derror( X5 ); L3812: X4 = PAIR_CDR( X5 ); X3 = sc_cons( PAIR_CAR( X2 ), X3 ); X2 = PAIR_CAR( X2 ); X1 = X4; GOBACK( L3741 ); L3743: compile_close_2dsc_2dfiles( ); POPSTACKTRACE( c2393 ); } DEFTSCP( compile_close_2dsc_2dfiles_v ); DEFCSTRING( t3814, "CLOSE-SC-FILES" ); EXTERNTSCPP( scrt5_current_2doutput_2dport, XAL0( ) ); EXTERNTSCP( scrt5_current_2doutput_2dport_v ); TSCP compile_c2396( f2419 ) TSCP f2419; { TSCP X1; PUSHSTACKTRACE( "CIFO [inside CLOSE-SC-FILES]" ); if ( FALSE( f2419 ) ) goto L3817; X1 = scrt5_current_2doutput_2dport( ); if ( EQ( _S2CUINT( f2419 ), _S2CUINT( X1 ) ) ) goto L3819; POPSTACKTRACE( scrt5_close_2dport( f2419 ) ); L3819: POPSTACKTRACE( FALSEVALUE ); L3817: POPSTACKTRACE( FALSEVALUE ); } TSCP compile_close_2dsc_2dfiles( ) { TSCP X3, X2, X1; PUSHSTACKTRACE( t3814 ); X1 = compile_sc_2dinput_v; X2 = X1; L3824: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3825; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3829; scrt1__24__car_2derror( X2 ); L3829: X3 = PAIR_CAR( X2 ); compile_c2396( X3 ); X2 = PAIR_CDR( X2 ); GOBACK( L3824 ); L3825: compile_sc_2dinput_v = EMPTYLIST; compile_sc_2dsplice_v = EMPTYLIST; compile_sc_2dinclude_2ddirs_v = c2029; compile_c2396( compile_sc_2dicode_v ); POPSTACKTRACE( SET( compile_sc_2dicode_v, EMPTYLIST ) ); } DEFTSCP( compile_scl_v ); DEFCSTRING( t3832, "SCL" ); EXTERNTSCPP( scrt6_write, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_write_v ); EXTERNTSCPP( scrt6_newline, XAL1( TSCP ) ); EXTERNTSCP( scrt6_newline_v ); EXTERNTSCPP( scrt5_close_2doutput_2dport, XAL1( TSCP ) ); EXTERNTSCP( scrt5_close_2doutput_2dport_v ); TSCP compile_scl( e2429 ) TSCP e2429; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3832 ); X1 = c2473; X1 = CONS( X1, EMPTYLIST ); if ( FALSE( e2429 ) ) goto L3854; if ( EQ( TSCPTAG( e2429 ), PAIRTAG ) ) goto L3841; scrt1__24__car_2derror( e2429 ); L3841: X2 = PAIR_CAR( e2429 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3854; X2 = scrt5_open_2doutput_2dfile( c2472 ); scrt6_write( c2448, CONS( X2, EMPTYLIST ) ); scrt6_newline( CONS( X2, EMPTYLIST ) ); X3 = e2429; L3845: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3846; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3851; scrt1__24__car_2derror( X3 ); L3851: X4 = PAIR_CAR( X3 ); scrt6_write( X4, CONS( X2, EMPTYLIST ) ); scrt6_newline( CONS( X2, EMPTYLIST ) ); X3 = PAIR_CDR( X3 ); GOBACK( L3845 ); L3846: scrt5_close_2doutput_2dport( X2 ); goto L3856; L3854: if ( FALSE( e2429 ) ) goto L3856; if ( EQ( TSCPTAG( e2429 ), PAIRTAG ) ) goto L3859; scrt1__24__car_2derror( e2429 ); L3859: X2 = PAIR_CAR( e2429 ); SETGEN( PAIR_CAR( X1 ), X2 ); L3856: X2 = CONS( c2309, EMPTYLIST ); POPSTACKTRACE( compile_sc( PAIR_CAR( X1 ), CONS( scrt5_current_2doutput_2dport( ), X2 ) ) ); } DEFTSCP( compile_log_3f_v ); DEFCSTRING( t3861, "LOG?" ); TSCP compile_log_3f( e2476 ) TSCP e2476; { PUSHSTACKTRACE( t3861 ); POPSTACKTRACE( scrt1_memq( e2476, compile_sc_2dlog_v ) ); } DEFTSCP( compile_docompile_v ); DEFCSTRING( t3863, "DOCOMPILE" ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCPP( compile_pp_24t_2dlist, XAL2( TSCP, TSCP ) ); EXTERNTSCP( compile_pp_24t_2dlist_v ); TSCP compile_l2620( l2621, c3932 ) TSCP l2621, c3932; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( "compile_l2620 [inside DOCOMPILE]" ); if ( NEQ( TSCPTAG( l2621 ), PAIRTAG ) ) goto L3934; X1 = PAIR_CAR( l2621 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2637 ) ) ) goto L3936; X4 = PAIR_CAR( l2621 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2637 ) ) ); if ( FALSE( X3 ) ) goto L3942; X4 = PAIR_CDR( l2621 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3946; scrt1__24__car_2derror( X4 ); L3946: X2 = PAIR_CAR( X4 ); goto L3943; L3942: X2 = X3; L3943: X1 = SYMBOL_VALUE( print_2dlambda_2dinfo_v ); X1 = UNKNOWNCALL( X1, 2 ); VIA( PROCEDURE_CODE( X1 ) )( X2, compile_sc_2dicode_v, PROCEDURE_CLOSURE( X1 ) ); POPSTACKTRACE( scrt6_newline( CONS( compile_sc_2dicode_v, EMPTYLIST ) ) ); L3936: POPSTACKTRACE( FALSEVALUE ); L3934: POPSTACKTRACE( FALSEVALUE ); } EXTERNTSCPP( compile__2d_24tree_b5ec3baf, XAL2( TSCP, TSCP ) ); EXTERNTSCP( compile__2d_24tree_b5ec3baf_v ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); TSCP compile_docompile( ) { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3863 ); X1 = EMPTYLIST; X1 = CONS( X1, EMPTYLIST ); if ( FALSE( compile_sc_2dlog_v ) ) goto L3866; scrt6_format( compile_sc_2dicode_v, CONS( c2480, EMPTYLIST ) ); L3866: X3 = SYMBOL_VALUE( expand_2dforms_v ); X3 = UNKNOWNCALL( X3, 0 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( PROCEDURE_CLOSURE( X3 ) ); SETGEN( PAIR_CAR( X1 ), X2 ); if ( FALSE( compile_log_3f( c2116 ) ) ) goto L3868; compile_pp_24t_2dlist( PAIR_CAR( X1 ), compile_sc_2dicode_v ); L3868: if ( FALSE( compile_sc_2dlog_v ) ) goto L3870; scrt6_format( compile_sc_2dicode_v, CONS( c2483, EMPTYLIST ) ); L3870: X2 = PAIR_CAR( X1 ); X3 = SYMBOL_VALUE( analyze_2dclosures1a_v ); X4 = X2; L3874: if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3875; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3879; scrt1__24__car_2derror( X4 ); L3879: X6 = PAIR_CAR( X4 ); X5 = X3; X5 = UNKNOWNCALL( X5, 1 ); VIA( PROCEDURE_CODE( X5 ) )( X6, PROCEDURE_CLOSURE( X5 ) ); X4 = PAIR_CDR( X4 ); GOBACK( L3874 ); L3875: X2 = PAIR_CAR( X1 ); X3 = SYMBOL_VALUE( analyze_2dclosures1b_v ); X4 = X2; L3884: if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3885; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3889; scrt1__24__car_2derror( X4 ); L3889: X6 = PAIR_CAR( X4 ); X5 = X3; X5 = UNKNOWNCALL( X5, 1 ); VIA( PROCEDURE_CODE( X5 ) )( X6, PROCEDURE_CLOSURE( X5 ) ); X4 = PAIR_CDR( X4 ); GOBACK( L3884 ); L3885: X3 = PAIR_CAR( X1 ); X4 = SYMBOL_VALUE( transform_v ); X5 = X3; X6 = EMPTYLIST; X7 = EMPTYLIST; L3894: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L3895; X2 = X6; goto L3902; L3895: if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3898; scrt1__24__car_2derror( X5 ); L3898: X11 = PAIR_CAR( X5 ); X10 = X4; X10 = UNKNOWNCALL( X10, 1 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( X11, PROCEDURE_CLOSURE( X10 ) ); X8 = sc_cons( X9, EMPTYLIST ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L3901; X9 = PAIR_CDR( X5 ); X7 = X8; X6 = X8; X5 = X9; GOBACK( L3894 ); L3901: X9 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3906; scdebug_error( c2562, c2563, CONS( X7, EMPTYLIST ) ); L3906: X7 = SETGEN( PAIR_CDR( X7 ), X8 ); X5 = X9; GOBACK( L3894 ); L3902: SETGEN( PAIR_CAR( X1 ), X2 ); if ( FALSE( compile_sc_2dlog_v ) ) goto L3908; scrt6_format( compile_sc_2dicode_v, CONS( c2573, EMPTYLIST ) ); L3908: X2 = PAIR_CAR( X1 ); X3 = SYMBOL_VALUE( analyze_2dclosures2_v ); X4 = X2; L3912: if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3913; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3917; scrt1__24__car_2derror( X4 ); L3917: X6 = PAIR_CAR( X4 ); X5 = X3; X5 = UNKNOWNCALL( X5, 1 ); VIA( PROCEDURE_CODE( X5 ) )( X6, PROCEDURE_CLOSURE( X5 ) ); X4 = PAIR_CDR( X4 ); GOBACK( L3912 ); L3913: if ( FALSE( compile_log_3f( c2167 ) ) ) goto L3925; X2 = PAIR_CAR( X1 ); X3 = X2; L3924: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3925; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3929; scrt1__24__car_2derror( X3 ); L3929: X4 = PAIR_CAR( X3 ); X6 = MAKEPROCEDURE( 1, 0, compile_l2620, EMPTYLIST ); X5 = SYMBOL_VALUE( walk_2d_24tree_v ); X5 = UNKNOWNCALL( X5, 2 ); VIA( PROCEDURE_CODE( X5 ) )( X6, X4, PROCEDURE_CLOSURE( X5 ) ); X3 = PAIR_CDR( X3 ); GOBACK( L3924 ); L3925: if ( FALSE( compile_log_3f( c2671 ) ) ) goto L3949; compile_pp_24t_2dlist( PAIR_CAR( X1 ), compile_sc_2dicode_v ); scrt6_newline( CONS( compile_sc_2dicode_v, EMPTYLIST ) ); X2 = SYMBOL_VALUE( quote_2dconstants_v ); compile__2d_24tree_b5ec3baf( X2, compile_sc_2dicode_v ); scrt6_newline( CONS( compile_sc_2dicode_v, EMPTYLIST ) ); L3949: if ( FALSE( compile_sc_2dlog_v ) ) goto L3952; scrt6_format( compile_sc_2dicode_v, CONS( c2674, EMPTYLIST ) ); L3952: X2 = compile_sc_2derror_2dcnt_v; if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L3956; if ( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3960; POPSTACKTRACE( FALSEVALUE ); L3956: if ( TRUE( scrt2_zero_3f( X2 ) ) ) goto L3960; POPSTACKTRACE( FALSEVALUE ); L3960: X2 = SYMBOL_VALUE( generate_2dcode_v ); X2 = UNKNOWNCALL( X2, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( PAIR_CAR( X1 ), PROCEDURE_CLOSURE( X2 ) ) ); } DEFTSCP( compile_report_2derror_v ); DEFCSTRING( t3963, "REPORT-ERROR" ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); TSCP compile_report_2derror( m2686, l2687 ) TSCP m2686, l2687; { TSCP X2, X1; PUSHSTACKTRACE( t3963 ); if ( TRUE( compile_sc_2derror_v ) ) goto L3965; compile_sc_2derror_v = scrt5_current_2doutput_2dport( ); L3965: X1 = CONS( m2686, EMPTYLIST ); X1 = CONS( compile_ine_2dname_3e60377e_v, X1 ); scrt6_format( compile_sc_2derror_v, CONS( c2688, X1 ) ); X1 = l2687; L3968: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3969; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3973; scrt1__24__car_2derror( X1 ); L3973: X2 = CONS( PAIR_CAR( X1 ), EMPTYLIST ); scrt6_format( compile_sc_2derror_v, CONS( c2712, X2 ) ); X1 = PAIR_CDR( X1 ); GOBACK( L3968 ); L3969: scrt6_newline( CONS( compile_sc_2derror_v, EMPTYLIST ) ); X1 = compile_sc_2derror_2dcnt_v; if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X1 ) ), 3 ) ) goto L3977; X2 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X1 ) ) ); goto L3978; L3977: X2 = scrt2__2b_2dtwo( _TSCP( 4 ), X1 ); L3978: POPSTACKTRACE( SET( compile_sc_2derror_2dcnt_v, X2 ) ); } DEFTSCP( compile_report_2dwarning_v ); DEFCSTRING( t3979, "REPORT-WARNING" ); TSCP compile_report_2dwarning( m2722, l2723 ) TSCP m2722, l2723; { TSCP X2, X1; PUSHSTACKTRACE( t3979 ); if ( TRUE( compile_sc_2derror_v ) ) goto L3981; compile_sc_2derror_v = scrt5_current_2doutput_2dport( ); L3981: X1 = CONS( m2722, EMPTYLIST ); X1 = CONS( compile_ine_2dname_3e60377e_v, X1 ); scrt6_format( compile_sc_2derror_v, CONS( c2724, X1 ) ); X1 = l2723; L3984: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3985; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3989; scrt1__24__car_2derror( X1 ); L3989: X2 = CONS( PAIR_CAR( X1 ), EMPTYLIST ); scrt6_format( compile_sc_2derror_v, CONS( c2712, X2 ) ); X1 = PAIR_CDR( X1 ); GOBACK( L3984 ); L3985: POPSTACKTRACE( scrt6_newline( CONS( compile_sc_2derror_v, EMPTYLIST ) ) ); } DEFTSCP( compile__2d_24tree_b5ec3baf_v ); DEFCSTRING( t3992, "PRETTY-PRINT-$TREE" ); EXTERNTSCPP( scrt6_write_2dcount, XAL1( TSCP ) ); EXTERNTSCP( scrt6_write_2dcount_v ); EXTERNTSCPP( scrt6_write_2dwidth, XAL1( TSCP ) ); EXTERNTSCP( scrt6_write_2dwidth_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( compile_bda_2dbind_8f865e9, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( compile_bda_2dbind_8f865e9_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); EXTERNTSCPP( compile_print_2din, XAL2( TSCP, TSCP ) ); EXTERNTSCP( compile_print_2din_v ); EXTERNTSCPP( scrt2__3e_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_3d_2dtwo_v ); EXTERNTSCPP( compile_2dcount_21_4d4ecab9, XAL2( TSCP, TSCP ) ); EXTERNTSCP( compile_2dcount_21_4d4ecab9_v ); EXTERNTSCPP( scrt6_display, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_display_v ); TSCP compile__2d_24tree_b5ec3baf( t2749, o2750 ) TSCP t2749, o2750; { TSCP X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3992 ); L3993: X3 = scrt6_write_2dcount( CONS( o2750, EMPTYLIST ) ); X4 = scrt6_write_2dwidth( CONS( o2750, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( X3 ) ), 3 ) ) goto L3995; X1 = _TSCP( IDIFFERENCE( _S2CINT( X4 ), _S2CINT( X3 ) ) ); goto L3996; L3995: X1 = scrt2__2d_2dtwo( X4, X3 ); L3996: X2 = scrt6_write_2dcount( CONS( o2750, EMPTYLIST ) ); if ( NEQ( TSCPTAG( t2749 ), PAIRTAG ) ) goto L3998; X4 = PAIR_CAR( t2749 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2772 ) ) ); goto L3999; L3998: X3 = FALSEVALUE; L3999: if ( FALSE( X3 ) ) goto L4076; if ( NEQ( TSCPTAG( t2749 ), PAIRTAG ) ) goto L4005; X6 = PAIR_CAR( t2749 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2772 ) ) ); goto L4006; L4005: X5 = FALSEVALUE; L4006: if ( FALSE( X5 ) ) goto L4009; X4 = scrt1_caddr( t2749 ); goto L4010; L4009: X4 = X5; L4010: if ( NEQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4076; X5 = PAIR_CAR( X4 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2637 ) ) ) goto L4076; if ( NEQ( TSCPTAG( t2749 ), PAIRTAG ) ) goto L4018; X8 = PAIR_CAR( t2749 ); X7 = BOOLEAN( EQ( _S2CUINT( X8 ), _S2CUINT( c2772 ) ) ); goto L4019; L4018: X7 = FALSEVALUE; L4019: if ( FALSE( X7 ) ) goto L4022; X6 = scrt1_caddr( t2749 ); goto L4023; L4022: X6 = X7; L4023: if ( NEQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4025; X8 = PAIR_CAR( X6 ); X7 = BOOLEAN( EQ( _S2CUINT( X8 ), _S2CUINT( c2637 ) ) ); goto L4026; L4025: X7 = FALSEVALUE; L4026: if ( FALSE( X7 ) ) goto L4029; if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4032; scrt1__24__cdr_2derror( X6 ); L4032: X8 = PAIR_CDR( X6 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L4035; scrt1__24__car_2derror( X8 ); L4035: X5 = PAIR_CAR( X8 ); goto L4030; L4029: X5 = X7; L4030: X9 = plist_get( X5, c3069 ); X10 = plist_get( X5, c3072 ); if ( NEQ( TSCPTAG( t2749 ), PAIRTAG ) ) goto L4038; X13 = PAIR_CAR( t2749 ); X12 = BOOLEAN( EQ( _S2CUINT( X13 ), _S2CUINT( c2772 ) ) ); goto L4039; L4038: X12 = FALSEVALUE; L4039: if ( FALSE( X12 ) ) goto L4042; X11 = scrt1_cdddr( t2749 ); goto L4043; L4042: X11 = X12; L4043: X8 = compile_bda_2dbind_8f865e9( X9, X10, X11 ); if ( NEQ( TSCPTAG( t2749 ), PAIRTAG ) ) goto L4044; X14 = PAIR_CAR( t2749 ); X13 = BOOLEAN( EQ( _S2CUINT( X14 ), _S2CUINT( c2772 ) ) ); goto L4045; L4044: X13 = FALSEVALUE; L4045: if ( FALSE( X13 ) ) goto L4048; X12 = scrt1_caddr( t2749 ); goto L4049; L4048: X12 = X13; L4049: if ( NEQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L4051; X14 = PAIR_CAR( X12 ); X13 = BOOLEAN( EQ( _S2CUINT( X14 ), _S2CUINT( c2637 ) ) ); goto L4052; L4051: X13 = FALSEVALUE; L4052: if ( FALSE( X13 ) ) goto L4055; if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L4058; scrt1__24__cdr_2derror( X12 ); L4058: X14 = PAIR_CDR( X12 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L4061; scrt1__24__cdr_2derror( X14 ); L4061: X11 = PAIR_CDR( X14 ); goto L4056; L4055: X11 = X13; L4056: X12 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X10 = scrt1_append_2dtwo( X11, X12 ); X9 = scrt1_cons_2a( X10, EMPTYLIST ); X7 = CONS( scrt1_append_2dtwo( X8, X9 ), EMPTYLIST ); X7 = CONS( X5, X7 ); if ( NEQ( TSCPTAG( t2749 ), PAIRTAG ) ) goto L4063; X9 = PAIR_CAR( t2749 ); X8 = BOOLEAN( EQ( _S2CUINT( X9 ), _S2CUINT( c2772 ) ) ); goto L4064; L4063: X8 = FALSEVALUE; L4064: if ( FALSE( X8 ) ) goto L4067; if ( EQ( TSCPTAG( t2749 ), PAIRTAG ) ) goto L4070; scrt1__24__cdr_2derror( t2749 ); L4070: X10 = PAIR_CDR( t2749 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L4073; scrt1__24__car_2derror( X10 ); L4073: X9 = PAIR_CAR( X10 ); goto L4068; L4067: X9 = X8; L4068: X6 = scrt1_cons_2a( c2833, CONS( X9, X7 ) ); t2749 = X6; GOBACK( L3993 ); L4076: X3 = BOOLEAN( NEQ( TSCPTAG( t2749 ), PAIRTAG ) ); if ( TRUE( X3 ) ) goto L4081; X4 = compile_print_2din( t2749, X1 ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4084; if ( GTE( _S2CINT( X4 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L4081; goto L4089; L4084: if ( TRUE( scrt2__3e_3d_2dtwo( X4, _TSCP( 0 ) ) ) ) goto L4081; L4089: if ( EQ( TSCPTAG( t2749 ), PAIRTAG ) ) goto L4093; scrt1__24__car_2derror( t2749 ); L4093: X4 = PAIR_CAR( t2749 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2833 ) ) ); if ( FALSE( X3 ) ) goto L4115; X7 = PAIR_CAR( t2749 ); X10 = PAIR_CDR( t2749 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L4102; scrt1__24__car_2derror( X10 ); L4102: X9 = PAIR_CAR( X10 ); X11 = scrt1_caddr( t2749 ); X10 = sc_cons( X11, EMPTYLIST ); X8 = sc_cons( X9, X10 ); X6 = sc_cons( X7, X8 ); X5 = X6; X4 = compile_print_2din( X5, X1 ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4107; if ( GTE( _S2CINT( X4 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L4111; goto L4115; L4107: if ( FALSE( scrt2__3e_3d_2dtwo( X4, _TSCP( 0 ) ) ) ) goto L4115; L4111: X3 = CONS( scrt1_caddr( t2749 ), EMPTYLIST ); X4 = PAIR_CDR( t2749 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4119; scrt1__24__car_2derror( X4 ); L4119: X3 = CONS( PAIR_CAR( X4 ), X3 ); X3 = CONS( PAIR_CAR( t2749 ), X3 ); scrt6_format( o2750, CONS( c2989, X3 ) ); X3 = scrt1_cdddr( t2749 ); X4 = X3; L4124: if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L4125; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4129; scrt1__24__car_2derror( X4 ); L4129: X5 = PAIR_CAR( X4 ); scrt6_newline( CONS( o2750, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4132; X6 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4133; L4132: X6 = scrt2__2b_2dtwo( X2, _TSCP( 4 ) ); L4133: compile_2dcount_21_4d4ecab9( o2750, X6 ); compile__2d_24tree_b5ec3baf( X5, o2750 ); X4 = PAIR_CDR( X4 ); GOBACK( L4124 ); L4125: POPSTACKTRACE( scrt6_format( o2750, CONS( c2931, EMPTYLIST ) ) ); L4115: X4 = PAIR_CAR( t2749 ); X3 = scrt1_memq( X4, c2864 ); if ( FALSE( X3 ) ) goto L4156; X7 = PAIR_CAR( t2749 ); X10 = PAIR_CDR( t2749 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L4143; scrt1__24__car_2derror( X10 ); L4143: X9 = PAIR_CAR( X10 ); X8 = sc_cons( X9, EMPTYLIST ); X6 = sc_cons( X7, X8 ); X5 = X6; X4 = compile_print_2din( X5, X1 ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4148; if ( GTE( _S2CINT( X4 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L4152; goto L4156; L4148: if ( FALSE( scrt2__3e_3d_2dtwo( X4, _TSCP( 0 ) ) ) ) goto L4156; L4152: X4 = PAIR_CDR( t2749 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4160; scrt1__24__car_2derror( X4 ); L4160: X3 = CONS( PAIR_CAR( X4 ), EMPTYLIST ); X3 = CONS( PAIR_CAR( t2749 ), X3 ); scrt6_format( o2750, CONS( c2933, X3 ) ); X4 = PAIR_CDR( t2749 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4165; scrt1__24__cdr_2derror( X4 ); L4165: X3 = PAIR_CDR( X4 ); X4 = X3; L4169: if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L4170; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4174; scrt1__24__car_2derror( X4 ); L4174: X5 = PAIR_CAR( X4 ); scrt6_newline( CONS( o2750, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 20 ) ) ), 3 ) ) goto L4177; X6 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 20 ) ) ) ); goto L4178; L4177: X6 = scrt2__2b_2dtwo( X2, _TSCP( 20 ) ); L4178: compile_2dcount_21_4d4ecab9( o2750, X6 ); compile__2d_24tree_b5ec3baf( X5, o2750 ); X4 = PAIR_CDR( X4 ); GOBACK( L4169 ); L4170: POPSTACKTRACE( scrt6_format( o2750, CONS( c2931, EMPTYLIST ) ) ); L4156: scrt6_format( o2750, CONS( c2889, EMPTYLIST ) ); X3 = PAIR_CAR( t2749 ); compile__2d_24tree_b5ec3baf( X3, o2750 ); X3 = PAIR_CDR( t2749 ); X4 = X3; L4185: if ( NEQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4186; scrt6_newline( CONS( o2750, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L4189; X5 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L4190; L4189: X5 = scrt2__2b_2dtwo( X2, _TSCP( 8 ) ); L4190: compile_2dcount_21_4d4ecab9( o2750, X5 ); X5 = PAIR_CAR( X4 ); compile__2d_24tree_b5ec3baf( X5, o2750 ); X4 = PAIR_CDR( X4 ); GOBACK( L4185 ); L4186: if ( FALSE( X4 ) ) goto L4193; scrt6_newline( CONS( o2750, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L4196; X5 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L4197; L4196: X5 = scrt2__2b_2dtwo( X2, _TSCP( 8 ) ); L4197: compile_2dcount_21_4d4ecab9( o2750, X5 ); scrt6_display( c2911, CONS( o2750, EMPTYLIST ) ); compile__2d_24tree_b5ec3baf( X4, o2750 ); L4193: POPSTACKTRACE( scrt6_format( o2750, CONS( c2931, EMPTYLIST ) ) ); L4081: POPSTACKTRACE( scrt6_write( t2749, CONS( o2750, EMPTYLIST ) ) ); } DEFTSCP( compile_bda_2dbind_8f865e9_v ); DEFCSTRING( t4198, "PP$T-LAMBDA-BIND" ); TSCP compile_bda_2dbind_8f865e9( r3205, o3206, v3207 ) TSCP r3205, o3206, v3207; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4198 ); if ( NEQ( _S2CUINT( r3205 ), _S2CUINT( EMPTYLIST ) ) ) goto L4200; if ( FALSE( o3206 ) ) goto L4202; if ( EQ( TSCPTAG( o3206 ), PAIRTAG ) ) goto L4205; scrt1__24__car_2derror( o3206 ); L4205: X2 = PAIR_CAR( o3206 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( v3207, X3 ); X1 = scrt1_cons_2a( X2, CONS( c3217, X3 ) ); POPSTACKTRACE( scrt1_cons_2a( X1, CONS( EMPTYLIST, EMPTYLIST ) ) ); L4202: POPSTACKTRACE( EMPTYLIST ); L4200: if ( EQ( TSCPTAG( r3205 ), PAIRTAG ) ) goto L4208; scrt1__24__car_2derror( r3205 ); L4208: X2 = PAIR_CAR( r3205 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( v3207 ), PAIRTAG ) ) goto L4211; scrt1__24__car_2derror( v3207 ); L4211: X3 = CONS( PAIR_CAR( v3207 ), X3 ); X1 = scrt1_cons_2a( X2, CONS( c3217, X3 ) ); X3 = PAIR_CDR( r3205 ); X4 = PAIR_CDR( v3207 ); X2 = compile_bda_2dbind_8f865e9( X3, o3206, X4 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); } DEFTSCP( compile_pp_24t_2dlist_v ); DEFCSTRING( t4215, "PP$T-LIST" ); TSCP compile_pp_24t_2dlist( f3235, o3236 ) TSCP f3235, o3236; { TSCP X2, X1; PUSHSTACKTRACE( t4215 ); X1 = f3235; L4218: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L4219; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4224; scrt1__24__car_2derror( X1 ); L4224: X2 = PAIR_CAR( X1 ); compile__2d_24tree_b5ec3baf( X2, o3236 ); scrt6_newline( CONS( o3236, EMPTYLIST ) ); X1 = PAIR_CDR( X1 ); GOBACK( L4218 ); L4219: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( compile_2dcount_21_4d4ecab9_v ); DEFCSTRING( t4227, "SET-WRITE-COUNT!" ); EXTERNTSCPP( scrt2__3c_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_3d_2dtwo_v ); EXTERNTSCPP( scrt6_write_2dchar, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_write_2dchar_v ); TSCP compile_2dcount_21_4d4ecab9( o3261, c3262 ) TSCP o3261, c3262; { TSCP X2, X1; PUSHSTACKTRACE( t4227 ); X2 = scrt6_write_2dcount( CONS( o3261, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( c3262 ), _S2CINT( X2 ) ), 3 ) ) goto L4231; X1 = _TSCP( IDIFFERENCE( _S2CINT( c3262 ), _S2CINT( X2 ) ) ); goto L4232; L4231: X1 = scrt2__2d_2dtwo( c3262, X2 ); L4232: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4235; if ( GT( _S2CINT( X1 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L4239; POPSTACKTRACE( FALSEVALUE ); L4235: if ( FALSE( scrt2__3c_3d_2dtwo( X1, _TSCP( 0 ) ) ) ) goto L4239; POPSTACKTRACE( FALSEVALUE ); L4239: scrt6_write_2dchar( _TSCP( 8210 ), CONS( o3261, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4243; X1 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L4232 ); L4243: X1 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); GOBACK( L4232 ); } DEFTSCP( compile_print_2din_v ); DEFCSTRING( t4245, "PRINT-IN" ); EXTERNTSCPP( scrt2_negative_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_negative_3f_v ); EXTERNTSCPP( scrt4_vector_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt4_vector_2d_3elist_v ); TSCP compile_print_2din( s3288, l3289 ) TSCP s3288, l3289; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4245 ); L4246: s3288 = CONS( s3288, EMPTYLIST ); if ( NEQ( TSCPTAG( l3289 ), FIXNUMTAG ) ) goto L4248; if ( GTE( _S2CINT( l3289 ), 0 ) ) goto L4252; POPSTACKTRACE( l3289 ); L4248: if ( FALSE( scrt2_negative_3f( l3289 ) ) ) goto L4252; POPSTACKTRACE( l3289 ); L4252: if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( s3288 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( s3288 ) ), VECTORTAG ) ) ) ) goto L4256; X1 = scrt4_vector_2d_3elist( PAIR_CAR( s3288 ) ); SETGEN( PAIR_CAR( s3288 ), X1 ); L4256: if ( NEQ( TSCPTAG( PAIR_CAR( s3288 ) ), PAIRTAG ) ) goto L4258; X2 = PAIR_CAR( s3288 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4261; scrt1__24__cdr_2derror( X2 ); L4261: X1 = PAIR_CDR( X2 ); X4 = PAIR_CAR( s3288 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4264; scrt1__24__car_2derror( X4 ); L4264: X3 = PAIR_CAR( X4 ); X2 = compile_print_2din( X3, l3289 ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4267; l3289 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4268; L4267: l3289 = scrt2__2d_2dtwo( X2, _TSCP( 4 ) ); L4268: s3288 = X1; GOBACK( L4246 ); L4258: X2 = scrt6_format( c3313, CONS( PAIR_CAR( s3288 ), EMPTYLIST ) ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) goto L4270; scdebug_error( c3311, c3312, CONS( X2, EMPTYLIST ) ); L4270: X1 = C_FIXED( STRING_LENGTH( X2 ) ); if ( BITAND( BITOR( _S2CINT( l3289 ), _S2CINT( X1 ) ), 3 ) ) goto L4273; POPSTACKTRACE( _TSCP( IDIFFERENCE( _S2CINT( l3289 ), _S2CINT( X1 ) ) ) ); L4273: POPSTACKTRACE( scrt2__2d_2dtwo( l3289, X1 ) ); } DEFTSCP( compile_string_2ddowncase_v ); DEFCSTRING( t4275, "STRING-DOWNCASE" ); EXTERNTSCPP( sc_make_2dstring, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dstring_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt3_char_2ddowncase, XAL1( TSCP ) ); EXTERNTSCP( scrt3_char_2ddowncase_v ); TSCP compile_string_2ddowncase( s3329 ) TSCP s3329; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4275 ); if ( AND( EQ( TSCPTAG( s3329 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( s3329 ), STRINGTAG ) ) ) goto L4279; scdebug_error( c3311, c3312, CONS( s3329, EMPTYLIST ) ); L4279: X2 = C_FIXED( STRING_LENGTH( s3329 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4282; X1 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4283; L4282: X1 = scrt2__2d_2dtwo( X2, _TSCP( 4 ) ); L4283: X3 = C_FIXED( STRING_LENGTH( s3329 ) ); X2 = sc_make_2dstring( X3, EMPTYLIST ); L4285: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( -4 ) ) ), 3 ) ) goto L4287; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L4291; POPSTACKTRACE( X2 ); L4287: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( -4 ) ) ) ) goto L4291; POPSTACKTRACE( X2 ); L4291: if ( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L4296; scdebug_error( c3383, c3353, CONS( X1, EMPTYLIST ) ); L4296: X5 = BOOLEAN( LT( _S2CINT( X1 ), 0 ) ); if ( TRUE( X5 ) ) goto L4302; X6 = C_FIXED( STRING_LENGTH( s3329 ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X6 ) ), 3 ) ) goto L4306; if ( GTE( _S2CINT( X1 ), _S2CINT( X6 ) ) ) goto L4302; goto L4313; L4306: if ( FALSE( scrt2__3e_3d_2dtwo( X1, X6 ) ) ) goto L4313; L4302: scdebug_error( c3383, c3404, CONS( X1, EMPTYLIST ) ); L4313: X4 = C_CHAR( STRING_CHAR( s3329, X1 ) ); X3 = scrt3_char_2ddowncase( X4 ); if ( EQ( TSCPIMMEDIATETAG( X3 ), CHARACTERTAG ) ) goto L4315; scdebug_error( c3352, c3356, CONS( X3, EMPTYLIST ) ); L4315: X4 = BOOLEAN( LT( _S2CINT( X1 ), 0 ) ); if ( TRUE( X4 ) ) goto L4321; if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) goto L4323; scdebug_error( c3311, c3312, CONS( X2, EMPTYLIST ) ); L4323: X5 = C_FIXED( STRING_LENGTH( X2 ) ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( X5 ) ), 3 ) ) goto L4327; if ( GTE( _S2CINT( X1 ), _S2CINT( X5 ) ) ) goto L4321; goto L4334; L4327: if ( FALSE( scrt2__3e_3d_2dtwo( X1, X5 ) ) ) goto L4334; L4321: scdebug_error( c3352, c3377, EMPTYLIST ); L4334: STRING_CHAR( X2, X1 ) = CHAR_C( X3 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4335; X3 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4336; L4335: X3 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); L4336: X1 = X3; GOBACK( L4285 ); } DEFTSCP( compile_list_2dhead_v ); DEFCSTRING( t4337, "LIST-HEAD" ); EXTERNTSCPP( compile_list_2dhead, XAL2( TSCP, TSCP ) ); EXTERNTSCP( compile_list_2dhead_v ); TSCP compile_list_2dhead( l3427, n3428 ) TSCP l3427, n3428; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4337 ); if ( NEQ( TSCPTAG( n3428 ), FIXNUMTAG ) ) goto L4340; if ( NEQ( _S2CUINT( n3428 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4344; POPSTACKTRACE( EMPTYLIST ); L4340: if ( FALSE( scrt2_zero_3f( n3428 ) ) ) goto L4344; POPSTACKTRACE( EMPTYLIST ); L4344: if ( EQ( TSCPTAG( l3427 ), PAIRTAG ) ) goto L4348; scrt1__24__car_2derror( l3427 ); L4348: X1 = PAIR_CAR( l3427 ); X3 = PAIR_CDR( l3427 ); if ( BITAND( BITOR( _S2CINT( n3428 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4351; X4 = _TSCP( IDIFFERENCE( _S2CINT( n3428 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4352; L4351: X4 = scrt2__2d_2dtwo( n3428, _TSCP( 4 ) ); L4352: X2 = compile_list_2dhead( X3, X4 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); } void scrt4__init(); void scrt3__init(); void scdebug__init(); void scrt2__init(); void scrt1__init(); void scrt6__init(); void scrt5__init(); void plist__init(); void expform__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt4__init(); scrt3__init(); scdebug__init(); scrt2__init(); scrt1__init(); scrt6__init(); scrt5__init(); plist__init(); expform__init(); MAXDISPLAY( 2 ); } void compile__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(compile SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3620, ADR( compile_sc_2dinput_v ), EMPTYLIST ); INITIALIZEVAR( t3621, ADR( compile_sc_2dsplice_v ), EMPTYLIST ); INITIALIZEVAR( t3622, ADR( compile_sc_2dsource_2dname_v ), EMPTYLIST ); INITIALIZEVAR( t3623, ADR( compile_sc_2dinclude_2ddirs_v ), c2029 ); INITIALIZEVAR( t3624, ADR( compile_sc_2dicode_v ), EMPTYLIST ); INITIALIZEVAR( t3625, ADR( compile_sc_2derror_v ), EMPTYLIST ); INITIALIZEVAR( t3626, ADR( compile_sc_2derror_2dcnt_v ), _TSCP( 0 ) ); INITIALIZEVAR( t3627, ADR( compile_sc_2dlog_v ), EMPTYLIST ); INITIALIZEVAR( t3628, ADR( compile_sc_2dstack_2dtrace_v ), TRUEVALUE ); INITIALIZEVAR( t3629, ADR( compile_sc_2dinterpreter_v ), FALSEVALUE ); INITIALIZEVAR( t3630, ADR( compile_sc_2dlog_2ddefault_v ), c2038 ); INITIALIZEVAR( t3631, ADR( compile_module_2dname_v ), sc_emptystring ); INITIALIZEVAR( t3632, ADR( compile_e_2dupcase_6e1220a4_v ), sc_emptystring ); INITIALIZEVAR( t3633, ADR( compile_main_2dprogram_2dname_v ), EMPTYLIST ); INITIALIZEVAR( t3634, ADR( compile_heap_2dsize_v ), _TSCP( 0 ) ); INITIALIZEVAR( t3635, ADR( compile_ine_2dname_3e60377e_v ), c2044 ); INITIALIZEVAR( t3636, ADR( compile_top_2dlevel_2dsymbols_v ), TRUEVALUE ); INITIALIZEVAR( t3637, ADR( compile_with_2dmodules_v ), EMPTYLIST ); INITIALIZEVAR( t3638, ADR( compile_restore_2dplist_v ), FALSEVALUE ); INITIALIZEVAR( t3639, ADR( compile_true_2dalpha_v ), c2049 ); INITIALIZEVAR( t3640, ADR( compile_false_2dalpha_v ), c2051 ); INITIALIZEVAR( t3641, ADR( compile_empty_2dlist_2dalpha_v ), c2053 ); INITIALIZEVAR( t3642, ADR( compile_cons_2dalpha_v ), EMPTYLIST ); INITIALIZEVAR( t3643, ADR( compile_undefined_2dalpha_v ), EMPTYLIST ); INITIALIZEVAR( t3644, ADR( compile_initialize_2dcompile_v ), MAKEPROCEDURE( 0, 0, compile_initialize_2dcompile, EMPTYLIST ) ); INITIALIZEVAR( t3652, ADR( compile_create_2dplist_v ), MAKEPROCEDURE( 1, 0, compile_create_2dplist, EMPTYLIST ) ); INITIALIZEVAR( t3666, ADR( compile_sc_v ), MAKEPROCEDURE( 1, 1, compile_sc, EMPTYLIST ) ); INITIALIZEVAR( t3814, ADR( compile_close_2dsc_2dfiles_v ), MAKEPROCEDURE( 0, 0, compile_close_2dsc_2dfiles, EMPTYLIST ) ); INITIALIZEVAR( t3832, ADR( compile_scl_v ), MAKEPROCEDURE( 0, 1, compile_scl, EMPTYLIST ) ); INITIALIZEVAR( t3861, ADR( compile_log_3f_v ), MAKEPROCEDURE( 1, 0, compile_log_3f, EMPTYLIST ) ); INITIALIZEVAR( t3863, ADR( compile_docompile_v ), MAKEPROCEDURE( 0, 0, compile_docompile, EMPTYLIST ) ); INITIALIZEVAR( t3963, ADR( compile_report_2derror_v ), MAKEPROCEDURE( 1, 1, compile_report_2derror, EMPTYLIST ) ); INITIALIZEVAR( t3979, ADR( compile_report_2dwarning_v ), MAKEPROCEDURE( 1, 1, compile_report_2dwarning, EMPTYLIST ) ); INITIALIZEVAR( t3992, ADR( compile__2d_24tree_b5ec3baf_v ), MAKEPROCEDURE( 2, 0, compile__2d_24tree_b5ec3baf, EMPTYLIST ) ); INITIALIZEVAR( t4198, ADR( compile_bda_2dbind_8f865e9_v ), MAKEPROCEDURE( 3, 0, compile_bda_2dbind_8f865e9, EMPTYLIST ) ); INITIALIZEVAR( t4215, ADR( compile_pp_24t_2dlist_v ), MAKEPROCEDURE( 2, 0, compile_pp_24t_2dlist, EMPTYLIST ) ); INITIALIZEVAR( t4227, ADR( compile_2dcount_21_4d4ecab9_v ), MAKEPROCEDURE( 2, 0, compile_2dcount_21_4d4ecab9, EMPTYLIST ) ); INITIALIZEVAR( t4245, ADR( compile_print_2din_v ), MAKEPROCEDURE( 2, 0, compile_print_2din, EMPTYLIST ) ); INITIALIZEVAR( t4275, ADR( compile_string_2ddowncase_v ), MAKEPROCEDURE( 1, 0, compile_string_2ddowncase, EMPTYLIST ) ); INITIALIZEVAR( t4337, ADR( compile_list_2dhead_v ), MAKEPROCEDURE( 2, 0, compile_list_2dhead, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/compile.sc000066400000000000000000000410711203736146400165160ustar00rootroot00000000000000;;; The top level of the Scheme compiler is implemented by this module. The ;;; variables that are used outside this module are: ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module compile) ;;; External and in-line declarations. (include "plist.sch") (include "expform.sch") (include "lambdaexp.sch") (include "miscexp.sch") ;;; Top-level variables. (define SC-INPUT '()) ; List of open input files. (define SC-SPLICE '()) ; List of forms to "splice" into input. (define SC-SOURCE-NAME '()) ; Initial source file name. (define SC-INCLUDE-DIRS '("")) ; List of directories for include to search. (define SC-ICODE '()) ; C written to this file. (define SC-ERROR '()) ; true -> log errors to ICODE file. ; false -> log errors to STANDARD-OUPUT. (define SC-ERROR-CNT 0) ; # of error messages reported. (define SC-LOG '()) ; List of events to log to the SC-ICODE file. ; The possible events are: ; ; SOURCE - source text. ; MACRO - source following macro expansion. ; EXPAND - initial tree. ; CLOSED - closed procedures and variables ; TRANSFORM - tree following boolean transform. ; LAMBDA - lambda analysis information. ; TREE - final tree and constants. ; LAP - lap code. ; PEEP - peep-hole optimization. (define SC-STACK-TRACE #t) ; true -> emit stack tracing code ; false -> don't emit stack tracing code. (define SC-INTERPRETER #f) ; true -> building an interpreter, so ignore ; main clause in module. ; false -> process module normally. (define SC-LOG-DEFAULT '(source macro expand closed transform lambda tree)) ; Default list of events to log. (define MODULE-NAME "") ; Module name. (define MODULE-NAME-UPCASE "") ; Upper case version of the module name. (define MAIN-PROGRAM-NAME '()) ; Main program name. (define HEAP-SIZE 0) ; Default size of heap. (define CURRENT-DEFINE-NAME 'top-level) ; Name of current DEFINE being processed. (define TOP-LEVEL-SYMBOLS #t) ; List of top-level symbols. (define WITH-MODULES '()) ; List of additional modules used. (define RESTORE-PLIST #f) ; Function to restore default initial values. (define TRUE-ALPHA 'true-alpha) ; Alpha variable for #t (define FALSE-ALPHA 'false-alpha) ; Alpha variable for #f (define EMPTY-LIST-ALPHA 'empty-list-alpha) ; Alpha variable for () (define CONS-ALPHA '()) ; Alpha variable for cons (define UNDEFINED-ALPHA '()) ; Alpha variable for undefined value ;;; Initialization of the entire compiler is triggered by the following ;;; function. It is normally called once at the start of each compilation. (define (INITIALIZE-COMPILE) ;;; Initialize the variables in expand.sc (set! lexical-free-vars '()) (set! lexical-bound-vars '()) (set! current-lambda-id 'top-level) ;;; Initialize the variables in miscexp.sc (set! quote-constants '()) ;;; Initialize the variables in lap.sc (set! lap-code '()) ;;; Initialize some of the variables in compile.sc (set! sc-log '()) (set! sc-stack-trace #t) (set! sc-interpreter #f) ;;; Initialize the property list. (if restore-plist (restore-plist) (begin (create-plist predef-default) (copy-plist 'scc 'initial-scc) (set! restore-plist (let ((init-globals global-free-vars) (init-seq make-alpha-seq)) (lambda () (set! global-free-vars init-globals) (set! make-alpha-seq init-seq) (copy-plist 'initial-scc 'scc)))))) ;;; Initialize the rest of the variables in compile.sc (set! sc-input '()) (set! sc-splice '()) (set! sc-include-dirs '("")) (set! sc-icode '()) (set! sc-error '()) (set! sc-error-cnt 0) (set! main-program-name '()) (set! heap-size 0) (set! current-define-name 'top-level) (set! top-level-symbols #t) (set! with-modules '()) (set! undefined-alpha (bound '$_undefined)) (set! cons-alpha (bound 'cons)) (set! module-name "")) ;;; As property list initialization takes a while, it is done only once and a ;;; copy is saved. (define (CREATE-PLIST predef-file) (set! module-name "*initialize*") (copy-plist 'null-property 'scc) (set! global-free-vars '()) (set! make-alpha-seq 0) ;;; Initialize for #T, #F, and (). (set-id-vname! 'true-alpha "TRUEVALUE") (set-id-use! 'true-alpha 'constant) (set-id-value! 'true-alpha #t) (set-id-vname! 'false-alpha "FALSEVALUE") (set-id-use! 'false-alpha 'constant) (set-id-value! 'false-alpha #f) (set-id-vname! 'empty-list-alpha "EMPTYLIST") (set-id-use! 'empty-list-alpha 'constant) (set-id-value! 'empty-list-alpha '()) ;;; Initialize for miscexp.t (put 'lap 'expand lap-exp ) (put 'quote 'expand quote-exp ) (put 'set! 'expand set!-exp ) (put 'if 'expand if-exp ) (put 'define 'expand define-exp) ;;; Initialize for macros.t (put 'quasiquote 'macro (old-macro quasiquote-macro)) (put 'cond 'macro (old-macro cond-macro)) (put 'case 'macro (old-macro case-macro)) (put 'and 'macro (old-macro and-macro)) (put 'or 'macro (old-macro or-macro)) (put 'not 'macro (old-macro not-macro)) (put 'begin 'macro (old-macro begin-macro)) (put 'let 'macro (old-macro let-macro)) (put 'let* 'macro (old-macro let*-macro)) (put 'letrec 'macro (old-macro letrec-macro)) (put 'do 'macro (old-macro do-macro)) (put 'when 'macro (old-macro when-macro)) (put 'unless 'macro (old-macro unless-macro)) (put 'quote 'macro quote-macro) (put 'lap 'macro lap-macro) (put 'module 'macro quote-macro) (put 'include 'macro quote-macro) (put 'define-external 'macro quote-macro) (put 'define-c-external 'macro quote-macro) (put 'define 'macro define-macro) (put 'define-macro 'macro define-macro-macro) (put 'define-constant 'macro define-constant-macro) (put 'eval-when 'macro eval-when-macro) (put 'lambda 'macro lambda-macro) ;;; Initialize for lambdaexp.sc (put 'lambda 'expand lambda-exp) ;;; Initialize for lap.sc (load-plist-lap) ;;; Initialize using the predef file (set! sc-input (list (open-input-file predef-file))) (let ((x (read-text))) (if (not (eof-object? x)) (report-error "Illegal predefinition form:" x))) (close-port (car sc-input)) (set! sc-input '()) (set! make-alpha-seq (max make-alpha-seq 2000)) ;;; Initialize alpha variables which point into the predef file. (set! undefined-alpha (bound '$_undefined)) (set! cons-alpha (bound 'cons)) (set! module-name "")) ;;; The compiler is invoked by the procedure SC which takes the following ;;; required argument: ;;; ;;; input source file name to compile. The suffix ".sc" is ;;; added to it to form the actual file name. ;;; ;;; and the following optional arguments: ;;; ;;; icode file for C intermediate code. If it is supplied, ;;; then the suffix ".c" will be added to form the file ;;; name. If it is not supplied then it will be ;;; constructed by appending the suffix ".c" to the source ;;; file name. ;;; ;;; ERROR error messages are to be written to the icode file. If ;;; it is not supplied, then errors will be written to the ;;; standard output device. ;;; ;;; LOG log the default events to the icode file. If it is ;;; not specified, then no events will be logged. ;;; ;;; (LOG events...) log the specified events to the icode file. If it is ;;; not specified, then no events will be logged. ;;; ;;; NOTRACE don't emit code for stack back stack. If it is not ;;; specified, then stack trace back code will be emitted. ;;; ;;; PREDEF file source file for predefined functions. If it is ;;; specified, then a suffix of ".sc" will be ;;; appended. If is is not specified, then the "standard" ;;; predefinition file will be used. (define (SC input . output) (initialize-compile) (if (symbol? input) (set! input (string-downcase (symbol->string input)))) (set! sc-source-name (string-append input ".sc")) (set! sc-input (list (open-input-file sc-source-name))) (cond ((and output (output-port? (car output))) (set! sc-icode (car output)) (set! output (cdr output))) ((or (null? output) (pair? (car output)) (memq (car output) '(error log profile predef))) (set! sc-icode (open-output-file (string-append input ".c")))) ((or (symbol? (car output)) (string? (car output))) (set! sc-icode (open-output-file (string-append (if (symbol? (car output)) (string-downcase (symbol->string (car output))) (car output)) ".c"))) (set! output (cdr output)))) (do ((output output (cdr output)) (flag '()) (options '() (cons flag options))) ((null? output) (docompile)) (set! flag (car output)) (cond ((memq flag options) (report-error "Duplicate option:" flag)) ((eq? flag 'error) (set! sc-error #t)) ((eq? flag 'log) (set! sc-log sc-log-default)) ((and (pair? flag) (eq? (car flag) 'log)) (set! sc-log (cdr flag)) (set! flag 'log)) ((eq? flag 'notrace) (set! sc-stack-trace #f)) ((and (eq? flag 'predef) (cdr output)) (create-plist (string-append (if (symbol? (cadr output)) (string-downcase (symbol->string (cadr output))) (cadr output)) ".sc")) (set! output (cdr output))) (else (report-error "Unrecognized option:" flag)))) (close-sc-files) 'sc-done) ;;; The following function is called to assure that all the files used by SC ;;; are closed. (define (CLOSE-SC-FILES) (let ((cifo (lambda (f) (if (and f (not (eq? f (current-output-port)))) (close-port f))))) (for-each cifo sc-input) (set! sc-input '()) (set! sc-splice '()) (set! sc-include-dirs '("")) (cifo sc-icode) (set! sc-icode '()))) ;;; SCL is an alternative to SC and is provided for testing. It allows one to ;;; specify a list of expressions to compile. They will be written to the file ;;; "scltext.sc" and then SC will be invoked. The default logging will be ;;; enabled. (define (SCL . expl) (let ((file 'scltext)) (cond ((and expl (pair? (car expl))) (let ((port (open-output-file "scltext.sc"))) (write '(module test) port) (newline port) (for-each (lambda (exp) (write exp port) (newline port)) expl) (close-output-port port))) (expl (set! file (car expl)))) (sc file (current-output-port) 'log))) ;;; Event logging is tested for the by the following boolean. (define (LOG? event) (memq event sc-log)) ;;; Once all the files are open, the actual compilation is directed by the ;;; following function. (define (DOCOMPILE) (let ((forms '())) (if sc-log (format sc-icode "/* ***** Expand Forms *****~%")) (set! forms (expand-forms)) (if (log? 'expand) (pp$t-list forms sc-icode)) (if sc-log (format sc-icode " ***** Transformations *****~%")) (for-each analyze-closures1a forms) (for-each analyze-closures1b forms) (set! forms (map transform forms)) (if sc-log (format sc-icode " ***** Closure Analysis *****~%")) (for-each analyze-closures2 forms) (if (log? 'lambda) (for-each (lambda (tree) (walk-$tree (lambda (l) (if ($lambda? l) (begin (print-lambda-info ($lambda-id l) sc-icode) (newline sc-icode)))) tree)) forms)) (if (log? 'tree) (begin (pp$t-list forms sc-icode) (newline sc-icode) (pretty-print-$tree quote-constants sc-icode) (newline sc-icode))) (if sc-log (format sc-icode " ***** Code Generation ***** */~%")) (if (zero? sc-error-cnt) (generate-code forms)))) ;;; Error messages are written in a standard form to the error file by the ;;; following function. It will also keep a count of the number of errors. (define (REPORT-ERROR msg . ls) (if (not sc-error) (set! sc-error (current-output-port))) (format sc-error "***** ERROR - ~a ~a" current-define-name msg) (for-each (lambda (l) (format sc-error " ~a" l)) ls) (newline sc-error) (set! sc-error-cnt (+ 1 sc-error-cnt))) ;;; Warning messages are written in a standard form to the error file by the ;;; following function. (define (REPORT-WARNING msg . ls) (if (not sc-error) (set! sc-error (current-output-port))) (format sc-error "***** WARNING - ~a ~a" current-define-name msg) (for-each (lambda (l) (format sc-error " ~a" l)) ls) (newline sc-error)) ;;; $TREE pretty-printer. (define (PRETTY-PRINT-$TREE tree out) (let ((indent (write-count out)) (left (- (write-width out) (write-count out)))) (cond ((and ($call? tree) ($lambda? ($call-func tree))) (let ((lid ($lambda-id ($call-func tree)))) (pretty-print-$tree `( ,($call-tail tree) ,lid ,@(pp$t-lambda-bind (lambda-reqvars lid) (lambda-optvars lid) ($call-argl tree)) ,@($lambda-body ($call-func tree))) out))) ((or (not (pair? tree)) (>= (print-in tree left) 0)) (write tree out)) ((and (eq? (car tree) ') (>= (print-in (list (car tree) (cadr tree) (caddr tree)) left) 0)) (format out "(~S ~S ~S" (car tree) (cadr tree) (caddr tree)) (for-each (lambda (x) (newline out) (set-write-count! out (+ indent 1)) (pretty-print-$tree x out)) (cdddr tree)) (format out ")")) ((and (memq (car tree) '($define $if $lambda)) (>= (print-in (list (car tree) (cadr tree)) left) 0)) (format out "(~S ~S" (car tree) (cadr tree)) (for-each (lambda (x) (newline out) (set-write-count! out (+ indent 5)) (pretty-print-$tree x out)) (cddr tree)) (format out ")")) (else (format out "(") (pretty-print-$tree (car tree) out) (let loop ((tree (cdr tree))) (cond ((pair? tree) (newline out) (set-write-count! out (+ indent 2)) (pretty-print-$tree (car tree) out) (loop (cdr tree))) (tree (newline out) (set-write-count! out (+ indent 2)) (display ". " out) (pretty-print-$tree tree out)))) (format out ")"))))) (define (PP$T-LAMBDA-BIND reqvars optvars vals) (cond ((null? reqvars) (if optvars `((,(car optvars) <- ,vals)) '())) (else (cons `(,(car reqvars) <- ,(car vals)) (pp$t-lambda-bind (cdr reqvars) optvars (cdr vals)))))) (define (PP$T-LIST forms out) (for-each (lambda (form) (pretty-print-$tree form out) (newline out)) forms)) ;;; Space out to a certain column on an output port. (define (SET-WRITE-COUNT! out cnt) (do ((i (- cnt (write-count out)) (- i 1))) ((<= i 0)) (write-char #\space out))) ;;; See if an object "s" will print in "len" characters or less. It will ;;; return the number of characters left, or a negative number if the object ;;; won't fit. (define (PRINT-IN s len) (if (not (negative? len)) (begin (if (vector? s) (set! s (vector->list s))) (if (pair? s) (print-in (cdr s) (- (print-in (car s) len) 1)) (- len (string-length (format "~s" s))))) len)) ;;; Down case a string. (define (STRING-DOWNCASE s) (do ((i (- (string-length s) 1) (- i 1)) (t (make-string (string-length s)))) ((= i -1) t) (string-set! t i (char-downcase (string-ref s i))))) ;;; Return the first "n" items of list "l". (define (LIST-HEAD l n) (if (zero? n) '() (cons (car l) (list-head (cdr l) (- n 1))))) scheme2c-2012.10.14/scsc/expform.c000066400000000000000000003374701203736146400163760ustar00rootroot00000000000000 /* SCHEME->C */ #include void expform__init(); DEFSTATICTSCP( read_2dtext_v ); DEFSTATICTSCP( current_2ddefine_2dname_v ); DEFSTATICTSCP( report_2dwarning_v ); DEFSTATICTSCP( quote_2dconstants_v ); DEFSTATICTSCP( islist_v ); DEFSTATICTSCP( call_2dexp_v ); DEFSTATICTSCP( module_2dname_v ); DEFSTATICTSCP( report_2derror_v ); DEFSTATICTSCP( downshift_v ); DEFSTATICTSCP( find_2dquote_2dconstant_v ); DEFSTATICTSCP( c3507 ); DEFSTATICTSCP( t3728 ); DEFCSTRING( t3729, "syntax:" ); DEFSTATICTSCP( c3506 ); DEFCSTRING( t3730, "Illegal" ); DEFSTATICTSCP( c3505 ); DEFCSTRING( t3731, "~A~A" ); DEFSTATICTSCP( c3420 ); DEFSTATICTSCP( c3360 ); DEFSTATICTSCP( t3732 ); DEFSTATICTSCP( t3733 ); DEFSTATICTSCP( t3734 ); DEFSTATICTSCP( t3735 ); DEFSTATICTSCP( t3736 ); DEFSTATICTSCP( c3359 ); DEFSTATICTSCP( c3355 ); DEFSTATICTSCP( t3737 ); DEFSTATICTSCP( t3738 ); DEFSTATICTSCP( t3739 ); DEFCSTRING( t3740, "Duplicately defined symbol:" ); DEFSTATICTSCP( c3297 ); DEFSTATICTSCP( c3279 ); DEFSTATICTSCP( c3262 ); DEFSTATICTSCP( c3168 ); DEFSTATICTSCP( c3167 ); DEFCSTRING( t3741, "0" ); DEFSTATICTSCP( c3166 ); DEFCSTRING( t3742, "0123456789abcdef" ); DEFSTATICTSCP( c3101 ); DEFCSTRING( t3743, "Index is not in bounds: ~s" ); DEFSTATICTSCP( c2976 ); DEFCSTRING( t3744, "Argument is not a VECTOR: ~s" ); DEFSTATICTSCP( c2970 ); DEFSTATICTSCP( c2969 ); DEFCSTRING( t3745, "~a_~a_~a" ); DEFSTATICTSCP( c2904 ); DEFCSTRING( t3746, "Argument(s) incorrect" ); DEFSTATICTSCP( c2903 ); DEFCSTRING( t3747, "Argument is not a CHAR: ~s" ); DEFSTATICTSCP( c2882 ); DEFSTATICTSCP( c2879 ); DEFCSTRING( t3748, "Argument not a CHAR: ~s" ); DEFSTATICTSCP( c2801 ); DEFSTATICTSCP( c2800 ); DEFCSTRING( t3749, "Argument not an unsigned 8-bit INTEGER: ~s" ); DEFSTATICTSCP( c2789 ); DEFSTATICTSCP( c2788 ); DEFSTATICTSCP( c2689 ); DEFSTATICTSCP( c2680 ); DEFCSTRING( t3750, "Argument(s) not CHAR: ~s ~s" ); DEFSTATICTSCP( c2669 ); DEFSTATICTSCP( c2668 ); DEFCSTRING( t3751, "Argument is out of range: ~s" ); DEFSTATICTSCP( c2661 ); DEFCSTRING( t3752, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2640 ); DEFSTATICTSCP( c2639 ); DEFCSTRING( t3753, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c2632 ); DEFSTATICTSCP( c2631 ); DEFCSTRING( t3754, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c2611 ); DEFSTATICTSCP( c2610 ); DEFSTATICTSCP( c2561 ); DEFSTATICTSCP( c2542 ); DEFCSTRING( t3755, "_" ); DEFSTATICTSCP( c2508 ); DEFSTATICTSCP( c2475 ); DEFSTATICTSCP( c2434 ); DEFSTATICTSCP( c2421 ); DEFSTATICTSCP( c2408 ); DEFSTATICTSCP( c2395 ); DEFSTATICTSCP( c2382 ); DEFSTATICTSCP( c2369 ); DEFSTATICTSCP( c2356 ); DEFSTATICTSCP( c2343 ); DEFSTATICTSCP( c2330 ); DEFSTATICTSCP( c2317 ); DEFSTATICTSCP( c2304 ); DEFSTATICTSCP( c2291 ); DEFSTATICTSCP( c2254 ); DEFSTATICTSCP( c2229 ); DEFCSTRING( t3756, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2213 ); DEFSTATICTSCP( c2212 ); DEFSTATICTSCP( c2177 ); DEFSTATICTSCP( c2172 ); DEFSTATICTSCP( c2169 ); DEFSTATICTSCP( c2150 ); DEFCSTRING( t3757, "_v" ); DEFSTATICTSCP( c2101 ); DEFSTATICTSCP( c2099 ); DEFCSTRING( t3758, "Variable assumed to be TOP-LEVEL:" ); DEFSTATICTSCP( c2089 ); DEFSTATICTSCP( c2086 ); DEFSTATICTSCP( c2082 ); DEFSTATICTSCP( c2078 ); DEFSTATICTSCP( c2077 ); DEFSTATICTSCP( c2029 ); static void init_constants() { read_2dtext_v = STRINGTOSYMBOL( CSTRING_TSCP( "READ-TEXT" ) ); CONSTANTEXP( ADR( read_2dtext_v ) ); current_2ddefine_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-D\ EFINE-NAME" ) ); CONSTANTEXP( ADR( current_2ddefine_2dname_v ) ); report_2dwarning_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-WARNING" ) ); CONSTANTEXP( ADR( report_2dwarning_v ) ); quote_2dconstants_v = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE-CONSTANTS\ " ) ); CONSTANTEXP( ADR( quote_2dconstants_v ) ); islist_v = STRINGTOSYMBOL( CSTRING_TSCP( "ISLIST" ) ); CONSTANTEXP( ADR( islist_v ) ); call_2dexp_v = STRINGTOSYMBOL( CSTRING_TSCP( "CALL-EXP" ) ); CONSTANTEXP( ADR( call_2dexp_v ) ); module_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE-NAME" ) ); CONSTANTEXP( ADR( module_2dname_v ) ); report_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-ERROR" ) ); CONSTANTEXP( ADR( report_2derror_v ) ); downshift_v = STRINGTOSYMBOL( CSTRING_TSCP( "DOWNSHIFT" ) ); CONSTANTEXP( ADR( downshift_v ) ); find_2dquote_2dconstant_v = STRINGTOSYMBOL( CSTRING_TSCP( "FIND-QUOT\ E-CONSTANT" ) ); CONSTANTEXP( ADR( find_2dquote_2dconstant_v ) ); c3507 = EMPTYLIST; c3507 = CONS( TRUEVALUE, c3507 ); t3728 = STRINGTOSYMBOL( CSTRING_TSCP( "BEGIN" ) ); c3507 = CONS( t3728, c3507 ); CONSTANTEXP( ADR( c3507 ) ); c3506 = CSTRING_TSCP( t3729 ); CONSTANTEXP( ADR( c3506 ) ); c3505 = CSTRING_TSCP( t3730 ); CONSTANTEXP( ADR( c3505 ) ); c3420 = CSTRING_TSCP( t3731 ); CONSTANTEXP( ADR( c3420 ) ); c3360 = EMPTYLIST; t3732 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSUREP" ) ); c3360 = CONS( t3732, c3360 ); t3733 = STRINGTOSYMBOL( CSTRING_TSCP( "TEMPORARY" ) ); c3360 = CONS( t3733, c3360 ); t3734 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); c3360 = CONS( t3734, c3360 ); t3735 = STRINGTOSYMBOL( CSTRING_TSCP( "CONSTANT" ) ); c3360 = CONS( t3735, c3360 ); t3736 = STRINGTOSYMBOL( CSTRING_TSCP( "LABEL" ) ); c3360 = CONS( t3736, c3360 ); CONSTANTEXP( ADR( c3360 ) ); c3359 = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL" ) ); CONSTANTEXP( ADR( c3359 ) ); c3355 = EMPTYLIST; t3737 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); c3355 = CONS( t3737, c3355 ); t3738 = STRINGTOSYMBOL( CSTRING_TSCP( "MACRO" ) ); c3355 = CONS( t3738, c3355 ); t3739 = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL" ) ); c3355 = CONS( t3739, c3355 ); CONSTANTEXP( ADR( c3355 ) ); c3297 = CSTRING_TSCP( t3740 ); CONSTANTEXP( ADR( c3297 ) ); c3279 = STRINGTOSYMBOL( CSTRING_TSCP( "MACRO" ) ); CONSTANTEXP( ADR( c3279 ) ); c3262 = EMPTYLIST; c3262 = CONS( c3359, c3262 ); c3262 = CONS( c3279, c3262 ); c3262 = CONS( t3739, c3262 ); CONSTANTEXP( ADR( c3262 ) ); c3168 = EMPTYLIST; c3168 = CONS( _TSCP( 245300 ), c3168 ); c3168 = CONS( _TSCP( 228460 ), c3168 ); c3168 = CONS( _TSCP( 146052 ), c3168 ); c3168 = CONS( _TSCP( 194780 ), c3168 ); c3168 = CONS( _TSCP( 44624 ), c3168 ); c3168 = CONS( _TSCP( 27656 ), c3168 ); c3168 = CONS( _TSCP( 76512 ), c3168 ); c3168 = CONS( _TSCP( 125112 ), c3168 ); c3168 = CONS( _TSCP( 106236 ), c3168 ); c3168 = CONS( _TSCP( 89252 ), c3168 ); c3168 = CONS( _TSCP( 6732 ), c3168 ); c3168 = CONS( _TSCP( 55316 ), c3168 ); c3168 = CONS( _TSCP( 167576 ), c3168 ); c3168 = CONS( _TSCP( 150720 ), c3168 ); c3168 = CONS( _TSCP( 199208 ), c3168 ); c3168 = CONS( _TSCP( 247920 ), c3168 ); c3168 = CONS( _TSCP( 262052 ), c3168 ); c3168 = CONS( _TSCP( 212476 ), c3168 ); c3168 = CONS( _TSCP( 162580 ), c3168 ); c3168 = CONS( _TSCP( 178508 ), c3168 ); c3168 = CONS( _TSCP( 61376 ), c3168 ); c3168 = CONS( _TSCP( 11672 ), c3168 ); c3168 = CONS( _TSCP( 93040 ), c3168 ); c3168 = CONS( _TSCP( 108840 ), c3168 ); c3168 = CONS( _TSCP( 122732 ), c3168 ); c3168 = CONS( _TSCP( 73012 ), c3168 ); c3168 = CONS( _TSCP( 23516 ), c3168 ); c3168 = CONS( _TSCP( 39300 ), c3168 ); c3168 = CONS( _TSCP( 184072 ), c3168 ); c3168 = CONS( _TSCP( 134480 ), c3168 ); c3168 = CONS( _TSCP( 215992 ), c3168 ); c3168 = CONS( _TSCP( 231904 ), c3168 ); c3168 = CONS( _TSCP( 212244 ), c3168 ); c3168 = CONS( _TSCP( 261964 ), c3168 ); c3168 = CONS( _TSCP( 178596 ), c3168 ); c3168 = CONS( _TSCP( 162812 ), c3168 ); c3168 = CONS( _TSCP( 11632 ), c3168 ); c3168 = CONS( _TSCP( 61224 ), c3168 ); c3168 = CONS( _TSCP( 108992 ), c3168 ); c3168 = CONS( _TSCP( 93080 ), c3168 ); c3168 = CONS( _TSCP( 73180 ), c3168 ); c3168 = CONS( _TSCP( 122756 ), c3168 ); c3168 = CONS( _TSCP( 39276 ), c3168 ); c3168 = CONS( _TSCP( 23348 ), c3168 ); c3168 = CONS( _TSCP( 134584 ), c3168 ); c3168 = CONS( _TSCP( 184288 ), c3168 ); c3168 = CONS( _TSCP( 231688 ), c3168 ); c3168 = CONS( _TSCP( 215888 ), c3168 ); c3168 = CONS( _TSCP( 228484 ), c3168 ); c3168 = CONS( _TSCP( 245468 ), c3168 ); c3168 = CONS( _TSCP( 194612 ), c3168 ); c3168 = CONS( _TSCP( 146028 ), c3168 ); c3168 = CONS( _TSCP( 27872 ), c3168 ); c3168 = CONS( _TSCP( 44728 ), c3168 ); c3168 = CONS( _TSCP( 125008 ), c3168 ); c3168 = CONS( _TSCP( 76296 ), c3168 ); c3168 = CONS( _TSCP( 89164 ), c3168 ); c3168 = CONS( _TSCP( 106004 ), c3168 ); c3168 = CONS( _TSCP( 55548 ), c3168 ); c3168 = CONS( _TSCP( 6820 ), c3168 ); c3168 = CONS( _TSCP( 150568 ), c3168 ); c3168 = CONS( _TSCP( 167536 ), c3168 ); c3168 = CONS( _TSCP( 247960 ), c3168 ); c3168 = CONS( _TSCP( 199360 ), c3168 ); c3168 = CONS( _TSCP( 178292 ), c3168 ); c3168 = CONS( _TSCP( 162348 ), c3168 ); c3168 = CONS( _TSCP( 212164 ), c3168 ); c3168 = CONS( _TSCP( 261788 ), c3168 ); c3168 = CONS( _TSCP( 108560 ), c3168 ); c3168 = CONS( _TSCP( 92744 ), c3168 ); c3168 = CONS( _TSCP( 11424 ), c3168 ); c3168 = CONS( _TSCP( 61176 ), c3168 ); c3168 = CONS( _TSCP( 39100 ), c3168 ); c3168 = CONS( _TSCP( 23268 ), c3168 ); c3168 = CONS( _TSCP( 72716 ), c3168 ); c3168 = CONS( _TSCP( 122452 ), c3168 ); c3168 = CONS( _TSCP( 231640 ), c3168 ); c3168 = CONS( _TSCP( 215680 ), c3168 ); c3168 = CONS( _TSCP( 134248 ), c3168 ); c3168 = CONS( _TSCP( 183856 ), c3168 ); c3168 = CONS( _TSCP( 195044 ), c3168 ); c3168 = CONS( _TSCP( 146364 ), c3168 ); c3168 = CONS( _TSCP( 228692 ), c3168 ); c3168 = CONS( _TSCP( 245516 ), c3168 ); c3168 = CONS( _TSCP( 125312 ), c3168 ); c3168 = CONS( _TSCP( 76760 ), c3168 ); c3168 = CONS( _TSCP( 27952 ), c3168 ); c3168 = CONS( _TSCP( 44904 ), c3168 ); c3168 = CONS( _TSCP( 55596 ), c3168 ); c3168 = CONS( _TSCP( 7028 ), c3168 ); c3168 = CONS( _TSCP( 89500 ), c3168 ); c3168 = CONS( _TSCP( 106436 ), c3168 ); c3168 = CONS( _TSCP( 248136 ), c3168 ); c3168 = CONS( _TSCP( 199440 ), c3168 ); c3168 = CONS( _TSCP( 151032 ), c3168 ); c3168 = CONS( _TSCP( 167840 ), c3168 ); c3168 = CONS( _TSCP( 146260 ), c3168 ); c3168 = CONS( _TSCP( 194828 ), c3168 ); c3168 = CONS( _TSCP( 245732 ), c3168 ); c3168 = CONS( _TSCP( 228796 ), c3168 ); c3168 = CONS( _TSCP( 76592 ), c3168 ); c3168 = CONS( _TSCP( 125288 ), c3168 ); c3168 = CONS( _TSCP( 44928 ), c3168 ); c3168 = CONS( _TSCP( 28120 ), c3168 ); c3168 = CONS( _TSCP( 7068 ), c3168 ); c3168 = CONS( _TSCP( 55748 ), c3168 ); c3168 = CONS( _TSCP( 106284 ), c3168 ); c3168 = CONS( _TSCP( 89460 ), c3168 ); c3168 = CONS( _TSCP( 199672 ), c3168 ); c3168 = CONS( _TSCP( 248224 ), c3168 ); c3168 = CONS( _TSCP( 167752 ), c3168 ); c3168 = CONS( _TSCP( 150800 ), c3168 ); c3168 = CONS( _TSCP( 162500 ), c3168 ); c3168 = CONS( _TSCP( 178332 ), c3168 ); c3168 = CONS( _TSCP( 261748 ), c3168 ); c3168 = CONS( _TSCP( 212012 ), c3168 ); c3168 = CONS( _TSCP( 92832 ), c3168 ); c3168 = CONS( _TSCP( 108792 ), c3168 ); c3168 = CONS( _TSCP( 60944 ), c3168 ); c3168 = CONS( _TSCP( 11336 ), c3168 ); c3168 = CONS( _TSCP( 23052 ), c3168 ); c3168 = CONS( _TSCP( 38996 ), c3168 ); c3168 = CONS( _TSCP( 122556 ), c3168 ); c3168 = CONS( _TSCP( 72932 ), c3168 ); c3168 = CONS( _TSCP( 215656 ), c3168 ); c3168 = CONS( _TSCP( 231472 ), c3168 ); c3168 = CONS( _TSCP( 184024 ), c3168 ); c3168 = CONS( _TSCP( 134272 ), c3168 ); c3168 = CONS( _TSCP( 111284 ), c3168 ); c3168 = CONS( _TSCP( 94444 ), c3168 ); c3168 = CONS( _TSCP( 13828 ), c3168 ); c3168 = CONS( _TSCP( 62556 ), c3168 ); c3168 = CONS( _TSCP( 172752 ), c3168 ); c3168 = CONS( _TSCP( 155784 ), c3168 ); c3168 = CONS( _TSCP( 206432 ), c3168 ); c3168 = CONS( _TSCP( 255032 ), c3168 ); c3168 = CONS( _TSCP( 234108 ), c3168 ); c3168 = CONS( _TSCP( 217124 ), c3168 ); c3168 = CONS( _TSCP( 136908 ), c3168 ); c3168 = CONS( _TSCP( 185492 ), c3168 ); c3168 = CONS( _TSCP( 33304 ), c3168 ); c3168 = CONS( _TSCP( 16448 ), c3168 ); c3168 = CONS( _TSCP( 67240 ), c3168 ); c3168 = CONS( _TSCP( 115952 ), c3168 ); c3168 = CONS( _TSCP( 127780 ), c3168 ); c3168 = CONS( _TSCP( 78204 ), c3168 ); c3168 = CONS( _TSCP( 30612 ), c3168 ); c3168 = CONS( _TSCP( 46540 ), c3168 ); c3168 = CONS( _TSCP( 189248 ), c3168 ); c3168 = CONS( _TSCP( 139544 ), c3168 ); c3168 = CONS( _TSCP( 223216 ), c3168 ); c3168 = CONS( _TSCP( 239016 ), c3168 ); c3168 = CONS( _TSCP( 250860 ), c3168 ); c3168 = CONS( _TSCP( 201140 ), c3168 ); c3168 = CONS( _TSCP( 153436 ), c3168 ); c3168 = CONS( _TSCP( 169220 ), c3168 ); c3168 = CONS( _TSCP( 50056 ), c3168 ); c3168 = CONS( _TSCP( 464 ), c3168 ); c3168 = CONS( _TSCP( 83768 ), c3168 ); c3168 = CONS( _TSCP( 99680 ), c3168 ); c3168 = CONS( _TSCP( 78228 ), c3168 ); c3168 = CONS( _TSCP( 127948 ), c3168 ); c3168 = CONS( _TSCP( 46372 ), c3168 ); c3168 = CONS( _TSCP( 30588 ), c3168 ); c3168 = CONS( _TSCP( 139760 ), c3168 ); c3168 = CONS( _TSCP( 189352 ), c3168 ); c3168 = CONS( _TSCP( 238912 ), c3168 ); c3168 = CONS( _TSCP( 223000 ), c3168 ); c3168 = CONS( _TSCP( 201052 ), c3168 ); c3168 = CONS( _TSCP( 250628 ), c3168 ); c3168 = CONS( _TSCP( 169452 ), c3168 ); c3168 = CONS( _TSCP( 153524 ), c3168 ); c3168 = CONS( _TSCP( 312 ), c3168 ); c3168 = CONS( _TSCP( 50016 ), c3168 ); c3168 = CONS( _TSCP( 99720 ), c3168 ); c3168 = CONS( _TSCP( 83920 ), c3168 ); c3168 = CONS( _TSCP( 94212 ), c3168 ); c3168 = CONS( _TSCP( 111196 ), c3168 ); c3168 = CONS( _TSCP( 62644 ), c3168 ); c3168 = CONS( _TSCP( 14060 ), c3168 ); c3168 = CONS( _TSCP( 155744 ), c3168 ); c3168 = CONS( _TSCP( 172600 ), c3168 ); c3168 = CONS( _TSCP( 255184 ), c3168 ); c3168 = CONS( _TSCP( 206472 ), c3168 ); c3168 = CONS( _TSCP( 217292 ), c3168 ); c3168 = CONS( _TSCP( 234132 ), c3168 ); c3168 = CONS( _TSCP( 185468 ), c3168 ); c3168 = CONS( _TSCP( 136740 ), c3168 ); c3168 = CONS( _TSCP( 16552 ), c3168 ); c3168 = CONS( _TSCP( 33520 ), c3168 ); c3168 = CONS( _TSCP( 115736 ), c3168 ); c3168 = CONS( _TSCP( 67136 ), c3168 ); c3168 = CONS( _TSCP( 46324 ), c3168 ); c3168 = CONS( _TSCP( 30380 ), c3168 ); c3168 = CONS( _TSCP( 77892 ), c3168 ); c3168 = CONS( _TSCP( 127516 ), c3168 ); c3168 = CONS( _TSCP( 238736 ), c3168 ); c3168 = CONS( _TSCP( 222920 ), c3168 ); c3168 = CONS( _TSCP( 139296 ), c3168 ); c3168 = CONS( _TSCP( 189048 ), c3168 ); c3168 = CONS( _TSCP( 169020 ), c3168 ); c3168 = CONS( _TSCP( 153188 ), c3168 ); c3168 = CONS( _TSCP( 200844 ), c3168 ); c3168 = CONS( _TSCP( 250580 ), c3168 ); c3168 = CONS( _TSCP( 99416 ), c3168 ); c3168 = CONS( _TSCP( 83456 ), c3168 ); c3168 = CONS( _TSCP( 232 ), c3168 ); c3168 = CONS( _TSCP( 49840 ), c3168 ); c3168 = CONS( _TSCP( 62820 ), c3168 ); c3168 = CONS( _TSCP( 14140 ), c3168 ); c3168 = CONS( _TSCP( 94676 ), c3168 ); c3168 = CONS( _TSCP( 111500 ), c3168 ); c3168 = CONS( _TSCP( 255232 ), c3168 ); c3168 = CONS( _TSCP( 206680 ), c3168 ); c3168 = CONS( _TSCP( 156080 ), c3168 ); c3168 = CONS( _TSCP( 173032 ), c3168 ); c3168 = CONS( _TSCP( 185772 ), c3168 ); c3168 = CONS( _TSCP( 137204 ), c3168 ); c3168 = CONS( _TSCP( 217372 ), c3168 ); c3168 = CONS( _TSCP( 234308 ), c3168 ); c3168 = CONS( _TSCP( 116168 ), c3168 ); c3168 = CONS( _TSCP( 67472 ), c3168 ); c3168 = CONS( _TSCP( 16760 ), c3168 ); c3168 = CONS( _TSCP( 33568 ), c3168 ); c3168 = CONS( _TSCP( 14292 ), c3168 ); c3168 = CONS( _TSCP( 62860 ), c3168 ); c3168 = CONS( _TSCP( 111460 ), c3168 ); c3168 = CONS( _TSCP( 94524 ), c3168 ); c3168 = CONS( _TSCP( 206768 ), c3168 ); c3168 = CONS( _TSCP( 255464 ), c3168 ); c3168 = CONS( _TSCP( 172800 ), c3168 ); c3168 = CONS( _TSCP( 155992 ), c3168 ); c3168 = CONS( _TSCP( 136988 ), c3168 ); c3168 = CONS( _TSCP( 185668 ), c3168 ); c3168 = CONS( _TSCP( 234412 ), c3168 ); c3168 = CONS( _TSCP( 217588 ), c3168 ); c3168 = CONS( _TSCP( 67448 ), c3168 ); c3168 = CONS( _TSCP( 116000 ), c3168 ); c3168 = CONS( _TSCP( 33736 ), c3168 ); c3168 = CONS( _TSCP( 16784 ), c3168 ); c3168 = CONS( _TSCP( 30276 ), c3168 ); c3168 = CONS( _TSCP( 46108 ), c3168 ); c3168 = CONS( _TSCP( 127732 ), c3168 ); c3168 = CONS( _TSCP( 77996 ), c3168 ); c3168 = CONS( _TSCP( 222752 ), c3168 ); c3168 = CONS( _TSCP( 238712 ), c3168 ); c3168 = CONS( _TSCP( 189072 ), c3168 ); c3168 = CONS( _TSCP( 139464 ), c3168 ); c3168 = CONS( _TSCP( 153228 ), c3168 ); c3168 = CONS( _TSCP( 169172 ), c3168 ); c3168 = CONS( _TSCP( 250428 ), c3168 ); c3168 = CONS( _TSCP( 200804 ), c3168 ); c3168 = CONS( _TSCP( 83688 ), c3168 ); c3168 = CONS( _TSCP( 99504 ), c3168 ); c3168 = CONS( _TSCP( 49752 ), c3168 ); c3168 = CONS( _TSCP( 0 ), c3168 ); c3168 = LISTTOVECTOR( c3168 ); CONSTANTEXP( ADR( c3168 ) ); c3167 = EMPTYLIST; c3167 = CONS( _TSCP( 46088 ), c3167 ); c3167 = CONS( _TSCP( 92180 ), c3167 ); c3167 = CONS( _TSCP( 199728 ), c3167 ); c3167 = CONS( _TSCP( 184364 ), c3167 ); c3167 = CONS( _TSCP( 43452 ), c3167 ); c3167 = CONS( _TSCP( 95648 ), c3167 ); c3167 = CONS( _TSCP( 201092 ), c3167 ); c3167 = CONS( _TSCP( 183704 ), c3167 ); c3167 = CONS( _TSCP( 36708 ), c3167 ); c3167 = CONS( _TSCP( 86904 ), c3167 ); c3167 = CONS( _TSCP( 210780 ), c3167 ); c3167 = CONS( _TSCP( 191296 ), c3167 ); c3167 = CONS( _TSCP( 37584 ), c3167 ); c3167 = CONS( _TSCP( 85708 ), c3167 ); c3167 = CONS( _TSCP( 207592 ), c3167 ); c3167 = CONS( _TSCP( 194292 ), c3167 ); c3167 = CONS( _TSCP( 49876 ), c3167 ); c3167 = CONS( _TSCP( 73416 ), c3167 ); c3167 = CONS( _TSCP( 228076 ), c3167 ); c3167 = CONS( _TSCP( 173808 ), c3167 ); c3167 = CONS( _TSCP( 57184 ), c3167 ); c3167 = CONS( _TSCP( 66428 ), c3167 ); c3167 = CONS( _TSCP( 223064 ), c3167 ); c3167 = CONS( _TSCP( 179012 ), c3167 ); c3167 = CONS( _TSCP( 63928 ), c3167 ); c3167 = CONS( _TSCP( 75172 ), c3167 ); c3167 = CONS( _TSCP( 213376 ), c3167 ); c3167 = CONS( _TSCP( 171420 ), c3167 ); c3167 = CONS( _TSCP( 58380 ), c3167 ); c3167 = CONS( _TSCP( 79888 ), c3167 ); c3167 = CONS( _TSCP( 220212 ), c3167 ); c3167 = CONS( _TSCP( 163880 ), c3167 ); c3167 = CONS( _TSCP( 22960 ), c3167 ); c3167 = CONS( _TSCP( 99756 ), c3167 ); c3167 = CONS( _TSCP( 254344 ), c3167 ); c3167 = CONS( _TSCP( 146836 ), c3167 ); c3167 = CONS( _TSCP( 17412 ), c3167 ); c3167 = CONS( _TSCP( 104472 ), c3167 ); c3167 = CONS( _TSCP( 261180 ), c3167 ); c3167 = CONS( _TSCP( 139296 ), c3167 ); c3167 = CONS( _TSCP( 25308 ), c3167 ); c3167 = CONS( _TSCP( 114368 ), c3167 ); c3167 = CONS( _TSCP( 252644 ), c3167 ); c3167 = CONS( _TSCP( 132856 ), c3167 ); c3167 = CONS( _TSCP( 32616 ), c3167 ); c3167 = CONS( _TSCP( 107380 ), c3167 ); c3167 = CONS( _TSCP( 247632 ), c3167 ); c3167 = CONS( _TSCP( 138060 ), c3167 ); c3167 = CONS( _TSCP( 12140 ), c3167 ); c3167 = CONS( _TSCP( 127856 ), c3167 ); c3167 = CONS( _TSCP( 235348 ), c3167 ); c3167 = CONS( _TSCP( 150344 ), c3167 ); c3167 = CONS( _TSCP( 13016 ), c3167 ); c3167 = CONS( _TSCP( 126660 ), c3167 ); c3167 = CONS( _TSCP( 232160 ), c3167 ); c3167 = CONS( _TSCP( 153340 ), c3167 ); c3167 = CONS( _TSCP( 5120 ), c3167 ); c3167 = CONS( _TSCP( 116764 ), c3167 ); c3167 = CONS( _TSCP( 240696 ), c3167 ); c3167 = CONS( _TSCP( 159780 ), c3167 ); c3167 = CONS( _TSCP( 2484 ), c3167 ); c3167 = CONS( _TSCP( 120232 ), c3167 ); c3167 = CONS( _TSCP( 242060 ), c3167 ); c3167 = CONS( _TSCP( 159120 ), c3167 ); c3167 = CONS( _TSCP( 94072 ), c3167 ); c3167 = CONS( _TSCP( 45924 ), c3167 ); c3167 = CONS( _TSCP( 186176 ), c3167 ); c3167 = CONS( _TSCP( 199516 ), c3167 ); c3167 = CONS( _TSCP( 94924 ), c3167 ); c3167 = CONS( _TSCP( 44752 ), c3167 ); c3167 = CONS( _TSCP( 183028 ), c3167 ); c3167 = CONS( _TSCP( 202472 ), c3167 ); c3167 = CONS( _TSCP( 87060 ), c3167 ); c3167 = CONS( _TSCP( 34824 ), c3167 ); c3167 = CONS( _TSCP( 191532 ), c3167 ); c3167 = CONS( _TSCP( 208944 ), c3167 ); c3167 = CONS( _TSCP( 84384 ), c3167 ); c3167 = CONS( _TSCP( 38332 ), c3167 ); c3167 = CONS( _TSCP( 192920 ), c3167 ); c3167 = CONS( _TSCP( 208260 ), c3167 ); c3167 = CONS( _TSCP( 72100 ), c3167 ); c3167 = CONS( _TSCP( 50616 ), c3167 ); c3167 = CONS( _TSCP( 172444 ), c3167 ); c3167 = CONS( _TSCP( 228736 ), c3167 ); c3167 = CONS( _TSCP( 66576 ), c3167 ); c3167 = CONS( _TSCP( 55308 ), c3167 ); c3167 = CONS( _TSCP( 179240 ), c3167 ); c3167 = CONS( _TSCP( 221236 ), c3167 ); c3167 = CONS( _TSCP( 74440 ), c3167 ); c3167 = CONS( _TSCP( 65236 ), c3167 ); c3167 = CONS( _TSCP( 170736 ), c3167 ); c3167 = CONS( _TSCP( 214764 ), c3167 ); c3167 = CONS( _TSCP( 81788 ), c3167 ); c3167 = CONS( _TSCP( 58208 ), c3167 ); c3167 = CONS( _TSCP( 165700 ), c3167 ); c3167 = CONS( _TSCP( 219992 ), c3167 ); c3167 = CONS( _TSCP( 99008 ), c3167 ); c3167 = CONS( _TSCP( 24284 ), c3167 ); c3167 = CONS( _TSCP( 146168 ), c3167 ); c3167 = CONS( _TSCP( 255716 ), c3167 ); c3167 = CONS( _TSCP( 106356 ), c3167 ); c3167 = CONS( _TSCP( 17256 ), c3167 ); c3167 = CONS( _TSCP( 141132 ), c3167 ); c3167 = CONS( _TSCP( 260944 ), c3167 ); c3167 = CONS( _TSCP( 113068 ), c3167 ); c3167 = CONS( _TSCP( 26032 ), c3167 ); c3167 = CONS( _TSCP( 131476 ), c3167 ); c3167 = CONS( _TSCP( 253320 ), c3167 ); c3167 = CONS( _TSCP( 107544 ), c3167 ); c3167 = CONS( _TSCP( 30724 ), c3167 ); c3167 = CONS( _TSCP( 138272 ), c3167 ); c3167 = CONS( _TSCP( 245820 ), c3167 ); c3167 = CONS( _TSCP( 128028 ), c3167 ); c3167 = CONS( _TSCP( 10240 ), c3167 ); c3167 = CONS( _TSCP( 150564 ), c3167 ); c3167 = CONS( _TSCP( 233528 ), c3167 ); c3167 = CONS( _TSCP( 125352 ), c3167 ); c3167 = CONS( _TSCP( 13748 ), c3167 ); c3167 = CONS( _TSCP( 151952 ), c3167 ); c3167 = CONS( _TSCP( 232844 ), c3167 ); c3167 = CONS( _TSCP( 118640 ), c3167 ); c3167 = CONS( _TSCP( 4972 ), c3167 ); c3167 = CONS( _TSCP( 161608 ), c3167 ); c3167 = CONS( _TSCP( 240468 ), c3167 ); c3167 = CONS( _TSCP( 119492 ), c3167 ); c3167 = CONS( _TSCP( 3800 ), c3167 ); c3167 = CONS( _TSCP( 158460 ), c3167 ); c3167 = CONS( _TSCP( 243424 ), c3167 ); c3167 = CONS( _TSCP( 197352 ), c3167 ); c3167 = CONS( _TSCP( 188148 ), c3167 ); c3167 = CONS( _TSCP( 47824 ), c3167 ); c3167 = CONS( _TSCP( 91852 ), c3167 ); c3167 = CONS( _TSCP( 204636 ), c3167 ); c3167 = CONS( _TSCP( 181056 ), c3167 ); c3167 = CONS( _TSCP( 42852 ), c3167 ); c3167 = CONS( _TSCP( 97144 ), c3167 ); c3167 = CONS( _TSCP( 211332 ), c3167 ); c3167 = CONS( _TSCP( 189848 ), c3167 ); c3167 = CONS( _TSCP( 33212 ), c3167 ); c3167 = CONS( _TSCP( 89504 ), c3167 ); c3167 = CONS( _TSCP( 205872 ), c3167 ); c3167 = CONS( _TSCP( 194604 ), c3167 ); c3167 = CONS( _TSCP( 39944 ), c3167 ); c3167 = CONS( _TSCP( 81940 ), c3167 ); c3167 = CONS( _TSCP( 226356 ), c3167 ); c3167 = CONS( _TSCP( 174120 ), c3167 ); c3167 = CONS( _TSCP( 52236 ), c3167 ); c3167 = CONS( _TSCP( 69648 ), c3167 ); c3167 = CONS( _TSCP( 223616 ), c3167 ); c3167 = CONS( _TSCP( 177564 ), c3167 ); c3167 = CONS( _TSCP( 53688 ), c3167 ); c3167 = CONS( _TSCP( 69028 ), c3167 ); c3167 = CONS( _TSCP( 216920 ), c3167 ); c3167 = CONS( _TSCP( 168772 ), c3167 ); c3167 = CONS( _TSCP( 63328 ), c3167 ); c3167 = CONS( _TSCP( 76668 ), c3167 ); c3167 = CONS( _TSCP( 217836 ), c3167 ); c3167 = CONS( _TSCP( 167664 ), c3167 ); c3167 = CONS( _TSCP( 60116 ), c3167 ); c3167 = CONS( _TSCP( 79560 ), c3167 ); c3167 = CONS( _TSCP( 257872 ), c3167 ); c3167 = CONS( _TSCP( 144204 ), c3167 ); c3167 = CONS( _TSCP( 22376 ), c3167 ); c3167 = CONS( _TSCP( 101236 ), c3167 ); c3167 = CONS( _TSCP( 258788 ), c3167 ); c3167 = CONS( _TSCP( 143096 ), c3167 ); c3167 = CONS( _TSCP( 19164 ), c3167 ); c3167 = CONS( _TSCP( 104128 ), c3167 ); c3167 = CONS( _TSCP( 250940 ), c3167 ); c3167 = CONS( _TSCP( 133152 ), c3167 ); c3167 = CONS( _TSCP( 27652 ), c3167 ); c3167 = CONS( _TSCP( 110616 ), c3167 ); c3167 = CONS( _TSCP( 248200 ), c3167 ); c3167 = CONS( _TSCP( 136596 ), c3167 ); c3167 = CONS( _TSCP( 29104 ), c3167 ); c3167 = CONS( _TSCP( 109996 ), c3167 ); c3167 = CONS( _TSCP( 235916 ), c3167 ); c3167 = CONS( _TSCP( 148880 ), c3167 ); c3167 = CONS( _TSCP( 8628 ), c3167 ); c3167 = CONS( _TSCP( 130472 ), c3167 ); c3167 = CONS( _TSCP( 230456 ), c3167 ); c3167 = CONS( _TSCP( 153636 ), c3167 ); c3167 = CONS( _TSCP( 15360 ), c3167 ); c3167 = CONS( _TSCP( 122908 ), c3167 ); c3167 = CONS( _TSCP( 238304 ), c3167 ); c3167 = CONS( _TSCP( 163580 ), c3167 ); c3167 = CONS( _TSCP( 6872 ), c3167 ); c3167 = CONS( _TSCP( 116420 ), c3167 ); c3167 = CONS( _TSCP( 245588 ), c3167 ); c3167 = CONS( _TSCP( 156488 ), c3167 ); c3167 = CONS( _TSCP( 1900 ), c3167 ); c3167 = CONS( _TSCP( 121712 ), c3167 ); c3167 = CONS( _TSCP( 186776 ), c3167 ); c3167 = CONS( _TSCP( 198020 ), c3167 ); c3167 = CONS( _TSCP( 90528 ), c3167 ); c3167 = CONS( _TSCP( 48572 ), c3167 ); c3167 = CONS( _TSCP( 181292 ), c3167 ); c3167 = CONS( _TSCP( 202800 ), c3167 ); c3167 = CONS( _TSCP( 97300 ), c3167 ); c3167 = CONS( _TSCP( 40968 ), c3167 ); c3167 = CONS( _TSCP( 189172 ), c3167 ); c3167 = CONS( _TSCP( 212712 ), c3167 ); c3167 = CONS( _TSCP( 88780 ), c3167 ); c3167 = CONS( _TSCP( 34512 ), c3167 ); c3167 = CONS( _TSCP( 196416 ), c3167 ); c3167 = CONS( _TSCP( 205660 ), c3167 ); c3167 = CONS( _TSCP( 83832 ), c3167 ); c3167 = CONS( _TSCP( 39780 ), c3167 ); c3167 = CONS( _TSCP( 175940 ), c3167 ); c3167 = CONS( _TSCP( 226136 ), c3167 ); c3167 = CONS( _TSCP( 71548 ), c3167 ); c3167 = CONS( _TSCP( 52064 ), c3167 ); c3167 = CONS( _TSCP( 176880 ), c3167 ); c3167 = CONS( _TSCP( 225004 ), c3167 ); c3167 = CONS( _TSCP( 68296 ), c3167 ); c3167 = CONS( _TSCP( 54996 ), c3167 ); c3167 = CONS( _TSCP( 169000 ), c3167 ); c3167 = CONS( _TSCP( 215092 ), c3167 ); c3167 = CONS( _TSCP( 76816 ), c3167 ); c3167 = CONS( _TSCP( 61452 ), c3167 ); c3167 = CONS( _TSCP( 166300 ), c3167 ); c3167 = CONS( _TSCP( 218496 ), c3167 ); c3167 = CONS( _TSCP( 78244 ), c3167 ); c3167 = CONS( _TSCP( 60856 ), c3167 ); c3167 = CONS( _TSCP( 144416 ), c3167 ); c3167 = CONS( _TSCP( 256060 ), c3167 ); c3167 = CONS( _TSCP( 101400 ), c3167 ); c3167 = CONS( _TSCP( 20484 ), c3167 ); c3167 = CONS( _TSCP( 141716 ), c3167 ); c3167 = CONS( _TSCP( 259464 ), c3167 ); c3167 = CONS( _TSCP( 102828 ), c3167 ); c3167 = CONS( _TSCP( 19888 ), c3167 ); c3167 = CONS( _TSCP( 134988 ), c3167 ); c3167 = CONS( _TSCP( 250704 ), c3167 ); c3167 = CONS( _TSCP( 112500 ), c3167 ); c3167 = CONS( _TSCP( 27496 ), c3167 ); c3167 = CONS( _TSCP( 135928 ), c3167 ); c3167 = CONS( _TSCP( 249572 ), c3167 ); c3167 = CONS( _TSCP( 109248 ), c3167 ); c3167 = CONS( _TSCP( 30428 ), c3167 ); c3167 = CONS( _TSCP( 148220 ), c3167 ); c3167 = CONS( _TSCP( 237280 ), c3167 ); c3167 = CONS( _TSCP( 129732 ), c3167 ); c3167 = CONS( _TSCP( 9944 ), c3167 ); c3167 = CONS( _TSCP( 155464 ), c3167 ); c3167 = CONS( _TSCP( 230228 ), c3167 ); c3167 = CONS( _TSCP( 124784 ), c3167 ); c3167 = CONS( _TSCP( 15212 ), c3167 ); c3167 = CONS( _TSCP( 162192 ), c3167 ); c3167 = CONS( _TSCP( 238988 ), c3167 ); c3167 = CONS( _TSCP( 115112 ), c3167 ); c3167 = CONS( _TSCP( 7604 ), c3167 ); c3167 = CONS( _TSCP( 156708 ), c3167 ); c3167 = CONS( _TSCP( 243768 ), c3167 ); c3167 = CONS( _TSCP( 121884 ), c3167 ); c3167 = CONS( _TSCP( 0 ), c3167 ); c3167 = LISTTOVECTOR( c3167 ); CONSTANTEXP( ADR( c3167 ) ); c3166 = CSTRING_TSCP( t3741 ); CONSTANTEXP( ADR( c3166 ) ); c3101 = CSTRING_TSCP( t3742 ); CONSTANTEXP( ADR( c3101 ) ); c2976 = CSTRING_TSCP( t3743 ); CONSTANTEXP( ADR( c2976 ) ); c2970 = CSTRING_TSCP( t3744 ); CONSTANTEXP( ADR( c2970 ) ); c2969 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-REF" ) ); CONSTANTEXP( ADR( c2969 ) ); c2904 = CSTRING_TSCP( t3745 ); CONSTANTEXP( ADR( c2904 ) ); c2903 = CSTRING_TSCP( t3746 ); CONSTANTEXP( ADR( c2903 ) ); c2882 = CSTRING_TSCP( t3747 ); CONSTANTEXP( ADR( c2882 ) ); c2879 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-SET!" ) ); CONSTANTEXP( ADR( c2879 ) ); c2801 = CSTRING_TSCP( t3748 ); CONSTANTEXP( ADR( c2801 ) ); c2800 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR->INTEGER" ) ); CONSTANTEXP( ADR( c2800 ) ); c2789 = CSTRING_TSCP( t3749 ); CONSTANTEXP( ADR( c2789 ) ); c2788 = STRINGTOSYMBOL( CSTRING_TSCP( "INTEGER->CHAR" ) ); CONSTANTEXP( ADR( c2788 ) ); c2689 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR<=?" ) ); CONSTANTEXP( ADR( c2689 ) ); c2680 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR>=?" ) ); CONSTANTEXP( ADR( c2680 ) ); c2669 = CSTRING_TSCP( t3750 ); CONSTANTEXP( ADR( c2669 ) ); c2668 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR=?" ) ); CONSTANTEXP( ADR( c2668 ) ); c2661 = CSTRING_TSCP( t3751 ); CONSTANTEXP( ADR( c2661 ) ); c2640 = CSTRING_TSCP( t3752 ); CONSTANTEXP( ADR( c2640 ) ); c2639 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-REF" ) ); CONSTANTEXP( ADR( c2639 ) ); c2632 = CSTRING_TSCP( t3753 ); CONSTANTEXP( ADR( c2632 ) ); c2631 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c2631 ) ); c2611 = CSTRING_TSCP( t3754 ); CONSTANTEXP( ADR( c2611 ) ); c2610 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c2610 ) ); c2561 = STRINGTOSYMBOL( CSTRING_TSCP( "NAME" ) ); CONSTANTEXP( ADR( c2561 ) ); c2542 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); CONSTANTEXP( ADR( c2542 ) ); c2508 = CSTRING_TSCP( t3755 ); CONSTANTEXP( ADR( c2508 ) ); c2475 = EMPTYLIST; c2475 = CONS( t3732, c2475 ); c2475 = CONS( c3359, c2475 ); CONSTANTEXP( ADR( c2475 ) ); c2434 = STRINGTOSYMBOL( CSTRING_TSCP( "GOTOS" ) ); CONSTANTEXP( ADR( c2434 ) ); c2421 = STRINGTOSYMBOL( CSTRING_TSCP( "ALIAS" ) ); CONSTANTEXP( ADR( c2421 ) ); c2408 = STRINGTOSYMBOL( CSTRING_TSCP( "CALLS" ) ); CONSTANTEXP( ADR( c2408 ) ); c2395 = STRINGTOSYMBOL( CSTRING_TSCP( "REFS" ) ); CONSTANTEXP( ADR( c2395 ) ); c2382 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2382 ) ); c2369 = STRINGTOSYMBOL( CSTRING_TSCP( "VALUE" ) ); CONSTANTEXP( ADR( c2369 ) ); c2356 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINED" ) ); CONSTANTEXP( ADR( c2356 ) ); c2343 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNAL" ) ); CONSTANTEXP( ADR( c2343 ) ); c2330 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2330 ) ); c2317 = STRINGTOSYMBOL( CSTRING_TSCP( "BOUNDID" ) ); CONSTANTEXP( ADR( c2317 ) ); c2304 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY" ) ); CONSTANTEXP( ADR( c2304 ) ); c2291 = STRINGTOSYMBOL( CSTRING_TSCP( "TYPE" ) ); CONSTANTEXP( ADR( c2291 ) ); c2254 = STRINGTOSYMBOL( CSTRING_TSCP( "CNAME" ) ); CONSTANTEXP( ADR( c2254 ) ); c2229 = STRINGTOSYMBOL( CSTRING_TSCP( "PRINTNAME" ) ); CONSTANTEXP( ADR( c2229 ) ); c2213 = CSTRING_TSCP( t3756 ); CONSTANTEXP( ADR( c2213 ) ); c2212 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2212 ) ); c2177 = STRINGTOSYMBOL( CSTRING_TSCP( "EXPRESSION-LIST" ) ); CONSTANTEXP( ADR( c2177 ) ); c2172 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2172 ) ); c2169 = STRINGTOSYMBOL( CSTRING_TSCP( "EXPAND" ) ); CONSTANTEXP( ADR( c2169 ) ); c2150 = EMPTYLIST; c2150 = CONS( FALSEVALUE, c2150 ); c2150 = CONS( TRUEVALUE, c2150 ); CONSTANTEXP( ADR( c2150 ) ); c2101 = CSTRING_TSCP( t3757 ); CONSTANTEXP( ADR( c2101 ) ); c2099 = STRINGTOSYMBOL( CSTRING_TSCP( "VNAME" ) ); CONSTANTEXP( ADR( c2099 ) ); c2089 = CSTRING_TSCP( t3758 ); CONSTANTEXP( ADR( c2089 ) ); c2086 = STRINGTOSYMBOL( CSTRING_TSCP( "UNDEFREF" ) ); CONSTANTEXP( ADR( c2086 ) ); c2082 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); CONSTANTEXP( ADR( c2082 ) ); c2078 = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL" ) ); CONSTANTEXP( ADR( c2078 ) ); c2077 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2077 ) ); c2029 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); CONSTANTEXP( ADR( c2029 ) ); } DEFTSCP( expform_global_2dfree_2dvars_v ); DEFCSTRING( t3759, "GLOBAL-FREE-VARS" ); DEFTSCP( expform_lexical_2dfree_2dvars_v ); DEFCSTRING( t3760, "LEXICAL-FREE-VARS" ); DEFTSCP( expform_und_2dvars_85c10849_v ); DEFCSTRING( t3761, "LEXICAL-BOUND-VARS" ); DEFTSCP( expform_current_2dlambda_2did_v ); DEFCSTRING( t3762, "CURRENT-LAMBDA-ID" ); DEFTSCP( expform_make_2dalpha_2dseq_v ); DEFCSTRING( t3763, "MAKE-ALPHA-SEQ" ); DEFTSCP( expform_expand_2dforms_v ); DEFCSTRING( t3764, "EXPAND-FORMS" ); EXTERNTSCPP( scrt6_eof_2dobject_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_eof_2dobject_3f_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); EXTERNTSCPP( expform_exp_2dform, XAL2( TSCP, TSCP ) ); EXTERNTSCP( expform_exp_2dform_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( expform_hex28, XAL2( TSCP, TSCP ) ); EXTERNTSCP( expform_hex28_v ); EXTERNTSCP( sc_emptystring ); EXTERNTSCPP( expform_lchexname, XAL1( TSCP ) ); EXTERNTSCP( expform_lchexname_v ); TSCP expform_expand_2dforms( ) { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3764 ); X1 = EMPTYLIST; X1 = CONS( X1, EMPTYLIST ); X3 = SYMBOL_VALUE( read_2dtext_v ); X3 = UNKNOWNCALL( X3, 0 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( PROCEDURE_CLOSURE( X3 ) ); L3768: X2 = CONS( X2, EMPTYLIST ); if ( FALSE( scrt6_eof_2dobject_3f( PAIR_CAR( X2 ) ) ) ) goto L3769; X3 = scrt1_reverse( PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X3 ); goto L3770; L3769: expform_lexical_2dfree_2dvars_v = EMPTYLIST; expform_current_2dlambda_2did_v = c2029; X3 = expform_exp_2dform( PAIR_CAR( X2 ), expform_exp_2dform_v ); SETGEN( PAIR_CAR( X2 ), X3 ); if ( FALSE( PAIR_CAR( X2 ) ) ) goto L3772; X3 = sc_cons( PAIR_CAR( X2 ), PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X3 ); L3772: X3 = SYMBOL_VALUE( read_2dtext_v ); X3 = UNKNOWNCALL( X3, 0 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( PROCEDURE_CLOSURE( X3 ) ); GOBACK( L3768 ); L3770: X2 = expform_global_2dfree_2dvars_v; X3 = X2; L3776: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3777; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3781; scrt1__24__car_2derror( X3 ); L3781: X4 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3785; scrt1__24__car_2derror( X4 ); L3785: X5 = PAIR_CAR( X4 ); X7 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3789; scrt1__24__car_2derror( X7 ); L3789: X6 = PAIR_CAR( X7 ); X7 = plist_get( X6, c2077 ); if ( NEQ( _S2CUINT( X7 ), _S2CUINT( c2078 ) ) ) goto L3794; if ( TRUE( plist_get( X6, c2082 ) ) ) goto L3794; SETGENTL( SYMBOL_VALUE( current_2ddefine_2dname_v ), plist_get( X6, c2086 ) ); X7 = SYMBOL_VALUE( report_2dwarning_v ); X7 = UNKNOWNCALL( X7, 2 ); VIA( PROCEDURE_CODE( X7 ) )( c2089, X5, PROCEDURE_CLOSURE( X7 ) ); plist_put( X6, c2077, c2029 ); plist_put( X6, c2082, c2029 ); X8 = CONS( c2101, EMPTYLIST ); X9 = expform_lchexname( X5 ); X7 = scrt3_string_2dappend( CONS( expform_hex28( sc_emptystring, X9 ), X8 ) ); plist_put( X6, c2099, X7 ); X9 = sc_cons( X6, EMPTYLIST ); X8 = sc_cons( X5, X9 ); X7 = X8; X8 = SYMBOL_VALUE( quote_2dconstants_v ); SETGENTL( SYMBOL_VALUE( quote_2dconstants_v ), sc_cons( X7, X8 ) ); L3794: X3 = PAIR_CDR( X3 ); GOBACK( L3776 ); L3777: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( expform_exp_2dform_v ); DEFCSTRING( t3799, "EXP-FORM" ); EXTERNTSCPP( expform_bound, XAL1( TSCP ) ); EXTERNTSCP( expform_bound_v ); EXTERNTSCPP( scrt1_member, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_member_v ); EXTERNTSCPP( sc_apply_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_apply_2dtwo_v ); EXTERNTSCPP( expform_expand_2derror, XAL2( TSCP, TSCP ) ); EXTERNTSCP( expform_expand_2derror_v ); TSCP expform_exp_2dform( e2120, e2121 ) TSCP e2120, e2121; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3799 ); if ( NOT( AND( EQ( TSCPTAG( e2120 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2120 ), SYMBOLTAG ) ) ) ) goto L3801; POPSTACKTRACE( expform_bound( e2120 ) ); L3801: if ( NEQ( TSCPTAG( e2120 ), FIXNUMTAG ) ) goto L3803; X1 = TRUEVALUE; goto L3804; L3803: X1 = BOOLEAN( AND( EQ( TSCPTAG( e2120 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2120 ), DOUBLEFLOATTAG ) ) ); L3804: if ( TRUE( X1 ) ) goto L3809; if ( AND( EQ( TSCPTAG( e2120 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2120 ), STRINGTAG ) ) ) goto L3809; if ( EQ( TSCPIMMEDIATETAG( e2120 ), CHARACTERTAG ) ) goto L3809; if ( TRUE( scrt1_member( e2120, c2150 ) ) ) goto L3809; X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X2 ) )( e2120, _TSCP( 4 ), PROCEDURE_CLOSURE( X2 ) ) ) ) goto L3820; if ( EQ( TSCPTAG( e2120 ), PAIRTAG ) ) goto L3825; scrt1__24__car_2derror( e2120 ); L3825: X3 = PAIR_CAR( e2120 ); if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) ) goto L3822; X3 = PAIR_CAR( e2120 ); X2 = plist_get( X3, c2169 ); goto L3823; L3822: X2 = EMPTYLIST; L3823: if ( FALSE( X2 ) ) goto L3829; X3 = X2; goto L3830; L3829: X3 = SYMBOL_VALUE( call_2dexp_v ); L3830: X6 = sc_cons( e2121, EMPTYLIST ); X5 = sc_cons( e2120, X6 ); X4 = X5; POPSTACKTRACE( sc_apply_2dtwo( X3, X4 ) ); L3820: POPSTACKTRACE( expform_expand_2derror( sc_emptystring, e2120 ) ); L3809: X4 = sc_cons( e2120, EMPTYLIST ); X3 = sc_cons( c2172, X4 ); X2 = X3; X1 = e2121; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2121, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( expform_exp_2dform_2dlist_v ); DEFCSTRING( t3833, "EXP-FORM-LIST" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP expform_exp_2dform_2dlist( e2175, f2176 ) TSCP e2175, f2176; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3833 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( e2175, _TSCP( 0 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L3835; X1 = e2175; X2 = EMPTYLIST; X3 = EMPTYLIST; L3838: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3839; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3842; scrt1__24__car_2derror( X1 ); L3842: X7 = PAIR_CAR( X1 ); X6 = f2176; X6 = UNKNOWNCALL( X6, 2 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( X7, f2176, PROCEDURE_CLOSURE( X6 ) ); X4 = sc_cons( X5, EMPTYLIST ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3845; X5 = PAIR_CDR( X1 ); X3 = X4; X2 = X4; X1 = X5; GOBACK( L3838 ); L3845: X5 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3850; scdebug_error( c2212, c2213, CONS( X3, EMPTYLIST ) ); L3850: X3 = SETGEN( PAIR_CDR( X3 ), X4 ); X1 = X5; GOBACK( L3838 ); L3839: POPSTACKTRACE( X2 ); L3835: POPSTACKTRACE( expform_expand_2derror( c2177, e2175 ) ); } DEFTSCP( expform_id_2dprintname_v ); DEFCSTRING( t3852, "ID-PRINTNAME" ); TSCP expform_id_2dprintname( i2226 ) TSCP i2226; { PUSHSTACKTRACE( t3852 ); POPSTACKTRACE( plist_get( i2226, c2229 ) ); } DEFTSCP( expform_intname_21_e25cd208_v ); DEFCSTRING( t3854, "SET-ID-PRINTNAME!" ); TSCP expform_intname_21_e25cd208( i2232, n2233 ) TSCP i2232, n2233; { PUSHSTACKTRACE( t3854 ); POPSTACKTRACE( plist_put( i2232, c2229, n2233 ) ); } DEFTSCP( expform_id_2dvname_v ); DEFCSTRING( t3856, "ID-VNAME" ); TSCP expform_id_2dvname( i2239 ) TSCP i2239; { PUSHSTACKTRACE( t3856 ); POPSTACKTRACE( plist_get( i2239, c2099 ) ); } DEFTSCP( expform_set_2did_2dvname_21_v ); DEFCSTRING( t3858, "SET-ID-VNAME!" ); TSCP expform_set_2did_2dvname_21( i2244, n2245 ) TSCP i2244, n2245; { PUSHSTACKTRACE( t3858 ); POPSTACKTRACE( plist_put( i2244, c2099, n2245 ) ); } DEFTSCP( expform_id_2dcname_v ); DEFCSTRING( t3860, "ID-CNAME" ); TSCP expform_id_2dcname( i2251 ) TSCP i2251; { PUSHSTACKTRACE( t3860 ); POPSTACKTRACE( plist_get( i2251, c2254 ) ); } DEFTSCP( expform_set_2did_2dcname_21_v ); DEFCSTRING( t3862, "SET-ID-CNAME!" ); TSCP expform_set_2did_2dcname_21( i2257, n2258 ) TSCP i2257, n2258; { PUSHSTACKTRACE( t3862 ); POPSTACKTRACE( plist_put( i2257, c2254, n2258 ) ); } DEFTSCP( expform_id_2dmodule_v ); DEFCSTRING( t3864, "ID-MODULE" ); TSCP expform_id_2dmodule( i2264 ) TSCP i2264; { PUSHSTACKTRACE( t3864 ); POPSTACKTRACE( plist_get( i2264, c2082 ) ); } DEFTSCP( expform_set_2did_2dmodule_21_v ); DEFCSTRING( t3866, "SET-ID-MODULE!" ); TSCP expform_set_2did_2dmodule_21( i2269, n2270 ) TSCP i2269, n2270; { PUSHSTACKTRACE( t3866 ); POPSTACKTRACE( plist_put( i2269, c2082, n2270 ) ); } DEFTSCP( expform_id_2duse_v ); DEFCSTRING( t3868, "ID-USE" ); TSCP expform_id_2duse( i2276 ) TSCP i2276; { PUSHSTACKTRACE( t3868 ); POPSTACKTRACE( plist_get( i2276, c2077 ) ); } DEFTSCP( expform_set_2did_2duse_21_v ); DEFCSTRING( t3870, "SET-ID-USE!" ); TSCP expform_set_2did_2duse_21( i2281, t2282 ) TSCP i2281, t2282; { PUSHSTACKTRACE( t3870 ); POPSTACKTRACE( plist_put( i2281, c2077, t2282 ) ); } DEFTSCP( expform_id_2dtype_v ); DEFCSTRING( t3872, "ID-TYPE" ); TSCP expform_id_2dtype( i2288 ) TSCP i2288; { PUSHSTACKTRACE( t3872 ); POPSTACKTRACE( plist_get( i2288, c2291 ) ); } DEFTSCP( expform_set_2did_2dtype_21_v ); DEFCSTRING( t3874, "SET-ID-TYPE!" ); TSCP expform_set_2did_2dtype_21( i2294, t2295 ) TSCP i2294, t2295; { PUSHSTACKTRACE( t3874 ); POPSTACKTRACE( plist_put( i2294, c2291, t2295 ) ); } DEFTSCP( expform_id_2ddisplay_v ); DEFCSTRING( t3876, "ID-DISPLAY" ); TSCP expform_id_2ddisplay( i2301 ) TSCP i2301; { PUSHSTACKTRACE( t3876 ); POPSTACKTRACE( plist_get( i2301, c2304 ) ); } DEFTSCP( expform_set_2did_2ddisplay_21_v ); DEFCSTRING( t3878, "SET-ID-DISPLAY!" ); TSCP expform_set_2did_2ddisplay_21( i2307, f2308 ) TSCP i2307, f2308; { PUSHSTACKTRACE( t3878 ); POPSTACKTRACE( plist_put( i2307, c2304, f2308 ) ); } DEFTSCP( expform_id_2dboundid_v ); DEFCSTRING( t3880, "ID-BOUNDID" ); TSCP expform_id_2dboundid( i2314 ) TSCP i2314; { PUSHSTACKTRACE( t3880 ); POPSTACKTRACE( plist_get( i2314, c2317 ) ); } DEFTSCP( expform_set_2did_2dboundid_v ); DEFCSTRING( t3882, "SET-ID-BOUNDID" ); TSCP expform_set_2did_2dboundid( i2320, v2321 ) TSCP i2320, v2321; { PUSHSTACKTRACE( t3882 ); POPSTACKTRACE( plist_put( i2320, c2317, v2321 ) ); } DEFTSCP( expform_id_2dlambda_v ); DEFCSTRING( t3884, "ID-LAMBDA" ); TSCP expform_id_2dlambda( i2327 ) TSCP i2327; { PUSHSTACKTRACE( t3884 ); POPSTACKTRACE( plist_get( i2327, c2330 ) ); } DEFTSCP( expform_set_2did_2dlambda_21_v ); DEFCSTRING( t3886, "SET-ID-LAMBDA!" ); TSCP expform_set_2did_2dlambda_21( i2333, l2334 ) TSCP i2333, l2334; { PUSHSTACKTRACE( t3886 ); POPSTACKTRACE( plist_put( i2333, c2330, l2334 ) ); } DEFTSCP( expform_id_2dexternal_v ); DEFCSTRING( t3888, "ID-EXTERNAL" ); TSCP expform_id_2dexternal( i2340 ) TSCP i2340; { PUSHSTACKTRACE( t3888 ); POPSTACKTRACE( plist_get( i2340, c2343 ) ); } DEFTSCP( expform_xternal_21_97042b81_v ); DEFCSTRING( t3890, "SET-ID-EXTERNAL!" ); TSCP expform_xternal_21_97042b81( i2346, f2347 ) TSCP i2346, f2347; { PUSHSTACKTRACE( t3890 ); POPSTACKTRACE( plist_put( i2346, c2343, f2347 ) ); } DEFTSCP( expform_id_2ddefined_v ); DEFCSTRING( t3892, "ID-DEFINED" ); TSCP expform_id_2ddefined( i2353 ) TSCP i2353; { PUSHSTACKTRACE( t3892 ); POPSTACKTRACE( plist_get( i2353, c2356 ) ); } DEFTSCP( expform_set_2did_2ddefined_21_v ); DEFCSTRING( t3894, "SET-ID-DEFINED!" ); TSCP expform_set_2did_2ddefined_21( i2359, f2360 ) TSCP i2359, f2360; { PUSHSTACKTRACE( t3894 ); POPSTACKTRACE( plist_put( i2359, c2356, f2360 ) ); } DEFTSCP( expform_id_2dvalue_v ); DEFCSTRING( t3896, "ID-VALUE" ); TSCP expform_id_2dvalue( i2366 ) TSCP i2366; { PUSHSTACKTRACE( t3896 ); POPSTACKTRACE( plist_get( i2366, c2369 ) ); } DEFTSCP( expform_set_2did_2dvalue_21_v ); DEFCSTRING( t3898, "SET-ID-VALUE!" ); TSCP expform_set_2did_2dvalue_21( i2372, x2373 ) TSCP i2372, x2373; { PUSHSTACKTRACE( t3898 ); POPSTACKTRACE( plist_put( i2372, c2369, x2373 ) ); } DEFTSCP( expform_id_2dset_21_v ); DEFCSTRING( t3900, "ID-SET!" ); TSCP expform_id_2dset_21( i2379 ) TSCP i2379; { PUSHSTACKTRACE( t3900 ); POPSTACKTRACE( plist_get( i2379, c2382 ) ); } DEFTSCP( expform_set_2did_2dset_21_21_v ); DEFCSTRING( t3902, "SET-ID-SET!!" ); TSCP expform_set_2did_2dset_21_21( i2385, f2386 ) TSCP i2385, f2386; { PUSHSTACKTRACE( t3902 ); POPSTACKTRACE( plist_put( i2385, c2382, f2386 ) ); } DEFTSCP( expform_id_2drefs_v ); DEFCSTRING( t3904, "ID-REFS" ); TSCP expform_id_2drefs( i2392 ) TSCP i2392; { PUSHSTACKTRACE( t3904 ); POPSTACKTRACE( plist_get( i2392, c2395 ) ); } DEFTSCP( expform_set_2did_2drefs_21_v ); DEFCSTRING( t3906, "SET-ID-REFS!" ); TSCP expform_set_2did_2drefs_21( i2398, c2399 ) TSCP i2398, c2399; { PUSHSTACKTRACE( t3906 ); POPSTACKTRACE( plist_put( i2398, c2395, c2399 ) ); } DEFTSCP( expform_id_2dcalls_v ); DEFCSTRING( t3908, "ID-CALLS" ); TSCP expform_id_2dcalls( i2405 ) TSCP i2405; { PUSHSTACKTRACE( t3908 ); POPSTACKTRACE( plist_get( i2405, c2408 ) ); } DEFTSCP( expform_set_2did_2dcalls_21_v ); DEFCSTRING( t3910, "SET-ID-CALLS!" ); TSCP expform_set_2did_2dcalls_21( i2411, c2412 ) TSCP i2411, c2412; { PUSHSTACKTRACE( t3910 ); POPSTACKTRACE( plist_put( i2411, c2408, c2412 ) ); } DEFTSCP( expform_id_2dalias_v ); DEFCSTRING( t3912, "ID-ALIAS" ); TSCP expform_id_2dalias( i2418 ) TSCP i2418; { PUSHSTACKTRACE( t3912 ); POPSTACKTRACE( plist_get( i2418, c2421 ) ); } DEFTSCP( expform_set_2did_2dalias_21_v ); DEFCSTRING( t3914, "SET-ID-ALIAS!" ); TSCP expform_set_2did_2dalias_21( i2424, l2425 ) TSCP i2424, l2425; { PUSHSTACKTRACE( t3914 ); POPSTACKTRACE( plist_put( i2424, c2421, l2425 ) ); } DEFTSCP( expform_id_2dgotos_v ); DEFCSTRING( t3916, "ID-GOTOS" ); TSCP expform_id_2dgotos( i2431 ) TSCP i2431; { PUSHSTACKTRACE( t3916 ); POPSTACKTRACE( plist_get( i2431, c2434 ) ); } DEFTSCP( expform_set_2did_2dgotos_21_v ); DEFCSTRING( t3918, "SET-ID-GOTOS!" ); TSCP expform_set_2did_2dgotos_21( i2437, c2438 ) TSCP i2437, c2438; { PUSHSTACKTRACE( t3918 ); POPSTACKTRACE( plist_put( i2437, c2434, c2438 ) ); } DEFTSCP( expform_id_2dundefref_v ); DEFCSTRING( t3920, "ID-UNDEFREF" ); TSCP expform_id_2dundefref( i2444 ) TSCP i2444; { PUSHSTACKTRACE( t3920 ); POPSTACKTRACE( plist_get( i2444, c2086 ) ); } DEFTSCP( expform_ndefref_21_c23a600d_v ); DEFCSTRING( t3922, "SET-ID-UNDEFREF!" ); TSCP expform_ndefref_21_c23a600d( i2449, v2450 ) TSCP i2449, v2450; { PUSHSTACKTRACE( t3922 ); POPSTACKTRACE( plist_put( i2449, c2086, v2450 ) ); } DEFTSCP( expform_id_2dglobal_v ); DEFCSTRING( t3924, "ID-GLOBAL" ); TSCP expform_id_2dglobal( i2456 ) TSCP i2456; { PUSHSTACKTRACE( t3924 ); POPSTACKTRACE( plist_get( i2456, c2078 ) ); } DEFTSCP( expform_set_2did_2dglobal_21_v ); DEFCSTRING( t3926, "SET-ID-GLOBAL!" ); TSCP expform_set_2did_2dglobal_21( i2461, a2462 ) TSCP i2461, a2462; { PUSHSTACKTRACE( t3926 ); POPSTACKTRACE( plist_put( i2461, c2078, a2462 ) ); } DEFTSCP( expform_assign_2dknown_2dname_v ); DEFCSTRING( t3928, "ASSIGN-KNOWN-NAME" ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); TSCP expform_assign_2dknown_2dname( v2468 ) TSCP v2468; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3928 ); X1 = plist_get( v2468, c2077 ); X2 = plist_get( v2468, c2082 ); X4 = plist_get( v2468, c2229 ); X3 = expform_lchexname( X4 ); if ( FALSE( scrt1_memq( X1, c2475 ) ) ) goto L3933; X4 = expform_lchexname( v2468 ); if ( FALSE( plist_get( v2468, c2330 ) ) ) goto L3936; X6 = CONS( X4, EMPTYLIST ); X6 = CONS( c2508, X6 ); X5 = scrt3_string_2dappend( CONS( SYMBOL_VALUE( module_2dname_v ), X6 ) ); plist_put( v2468, c2254, X5 ); X6 = CONS( c2101, EMPTYLIST ); X5 = scrt3_string_2dappend( CONS( X4, X6 ) ); POPSTACKTRACE( plist_put( v2468, c2099, X5 ) ); L3936: POPSTACKTRACE( plist_put( v2468, c2099, X4 ) ); L3933: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2078 ) ) ) goto L3939; X4 = plist_get( v2468, c2291 ); goto L3940; L3939: X4 = FALSEVALUE; L3940: if ( TRUE( X4 ) ) goto L3942; X6 = CONS( c2101, EMPTYLIST ); X5 = scrt3_string_2dappend( CONS( expform_hex28( X2, X3 ), X6 ) ); plist_put( v2468, c2099, X5 ); X5 = scrt3_string_2dappend( CONS( expform_hex28( X2, X3 ), EMPTYLIST ) ); POPSTACKTRACE( plist_put( v2468, c2254, X5 ) ); L3942: POPSTACKTRACE( X4 ); } DEFTSCP( expform_name_2da_2dlambda_v ); DEFCSTRING( t3945, "NAME-A-LAMBDA" ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); TSCP expform_name_2da_2dlambda( n2520, e2521 ) TSCP n2520, e2521; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3945 ); e2521 = CONS( e2521, EMPTYLIST ); X2 = PAIR_CAR( e2521 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3948; X4 = PAIR_CAR( X2 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2542 ) ) ); goto L3949; L3948: X3 = FALSEVALUE; L3949: if ( FALSE( X3 ) ) goto L3952; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3955; scrt1__24__cdr_2derror( X2 ); L3955: X4 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3958; scrt1__24__car_2derror( X4 ); L3958: X1 = PAIR_CAR( X4 ); goto L3953; L3952: X1 = X3; L3953: SETGEN( PAIR_CAR( e2521 ), X1 ); if ( FALSE( PAIR_CAR( e2521 ) ) ) goto L3960; plist_put( n2520, c2330, PAIR_CAR( e2521 ) ); POPSTACKTRACE( plist_put( PAIR_CAR( e2521 ), c2561, n2520 ) ); L3960: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( expform_vname_v ); DEFCSTRING( t3963, "VNAME" ); TSCP expform_vname( e2563 ) TSCP e2563; { TSCP X1; PUSHSTACKTRACE( t3963 ); e2563 = CONS( e2563, EMPTYLIST ); if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( e2563 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( e2563 ) ), SYMBOLTAG ) ) ) ) goto L3965; X1 = plist_get( PAIR_CAR( e2563 ), c2077 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2330 ) ) ) goto L3970; if ( FALSE( plist_get( PAIR_CAR( e2563 ), c2561 ) ) ) goto L3970; X1 = plist_get( PAIR_CAR( e2563 ), c2561 ); SETGEN( PAIR_CAR( e2563 ), X1 ); L3970: POPSTACKTRACE( plist_get( PAIR_CAR( e2563 ), c2099 ) ); L3965: POPSTACKTRACE( PAIR_CAR( e2563 ) ); } DEFTSCP( expform_cname_v ); DEFCSTRING( t3972, "CNAME" ); TSCP expform_cname( e2583 ) TSCP e2583; { TSCP X1; PUSHSTACKTRACE( t3972 ); e2583 = CONS( e2583, EMPTYLIST ); if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( e2583 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( e2583 ) ), SYMBOLTAG ) ) ) ) goto L3974; X1 = plist_get( PAIR_CAR( e2583 ), c2077 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2330 ) ) ) goto L3979; if ( FALSE( plist_get( PAIR_CAR( e2583 ), c2561 ) ) ) goto L3979; X1 = plist_get( PAIR_CAR( e2583 ), c2561 ); SETGEN( PAIR_CAR( e2583 ), X1 ); L3979: POPSTACKTRACE( plist_get( PAIR_CAR( e2583 ), c2254 ) ); L3974: POPSTACKTRACE( PAIR_CAR( e2583 ) ); } DEFTSCP( expform_lchexname_v ); DEFCSTRING( t3981, "LCHEXNAME" ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt3_list_2d_3estring, XAL1( TSCP ) ); EXTERNTSCP( scrt3_list_2d_3estring_v ); EXTERNTSCPP( scrt2__3e_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_3d_2dtwo_v ); EXTERNTSCPP( scrt1_last_2dpair, XAL1( TSCP ) ); EXTERNTSCP( scrt1_last_2dpair_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( scrt2__3c_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_2dtwo_v ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); EXTERNTSCPP( expform_char_2d_3edl, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( expform_char_2d_3edl_v ); TSCP expform_lchexname( n2603 ) TSCP n2603; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3981 ); n2603 = CONS( n2603, EMPTYLIST ); if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( n2603 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( n2603 ) ), SYMBOLTAG ) ) ) ) goto L3983; X2 = PAIR_CAR( n2603 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) goto L3986; scdebug_error( c2610, c2611, CONS( X2, EMPTYLIST ) ); L3986: X1 = SYMBOL_NAME( X2 ); SETGEN( PAIR_CAR( n2603 ), X1 ); L3983: X1 = EMPTYLIST; X2 = _TSCP( 0 ); X4 = sc_cons( _TSCP( 4 ), EMPTYLIST ); X3 = X4; L3990: X1 = CONS( X1, EMPTYLIST ); X5 = PAIR_CAR( n2603 ); if ( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), STRINGTAG ) ) ) goto L3992; scdebug_error( c2631, c2632, CONS( X5, EMPTYLIST ) ); L3992: X4 = C_FIXED( STRING_LENGTH( X5 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X4 ) ), 3 ) ) goto L3996; if ( EQ( _S2CUINT( X2 ), _S2CUINT( X4 ) ) ) goto L4000; goto L4001; L3996: if ( FALSE( scrt2__3d_2dtwo( X2, X4 ) ) ) goto L4001; L4000: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4005; scrt1__24__cdr_2derror( X3 ); L4005: X4 = PAIR_CDR( X3 ); POPSTACKTRACE( scrt3_list_2d_3estring( X4 ) ); L4001: X5 = PAIR_CAR( n2603 ); if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L4009; scdebug_error( c2639, c2640, CONS( X2, EMPTYLIST ) ); L4009: X6 = BOOLEAN( LT( _S2CINT( X2 ), 0 ) ); if ( TRUE( X6 ) ) goto L4015; if ( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), STRINGTAG ) ) ) goto L4017; scdebug_error( c2631, c2632, CONS( X5, EMPTYLIST ) ); L4017: X7 = C_FIXED( STRING_LENGTH( X5 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X7 ) ), 3 ) ) goto L4021; if ( GTE( _S2CINT( X2 ), _S2CINT( X7 ) ) ) goto L4015; goto L4028; L4021: if ( FALSE( scrt2__3e_3d_2dtwo( X2, X7 ) ) ) goto L4028; L4015: scdebug_error( c2639, c2661, CONS( X2, EMPTYLIST ) ); L4028: X4 = C_CHAR( STRING_CHAR( X5, X2 ) ); SETGEN( PAIR_CAR( X1 ), X4 ); X4 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X4 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 24338 ) ), CHARACTERTAG ) ) ) goto L4030; X5 = CONS( _TSCP( 24338 ), EMPTYLIST ); scdebug_error( c2668, c2669, CONS( X4, X5 ) ); L4030: if ( NEQ( _S2CINT( X4 ), _S2CINT( _TSCP( 24338 ) ) ) ) goto L4032; X7 = sc_cons( _TSCP( 24338 ), EMPTYLIST ); X6 = sc_cons( _TSCP( 24338 ), X7 ); X5 = X6; X6 = scrt1_last_2dpair( X3 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4036; scdebug_error( c2212, c2213, CONS( X6, EMPTYLIST ) ); L4036: SETGEN( PAIR_CDR( X6 ), X5 ); goto L4083; L4032: X6 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 16658 ) ), CHARACTERTAG ) ) ) goto L4039; X7 = CONS( _TSCP( 16658 ), EMPTYLIST ); scdebug_error( c2680, c2669, CONS( X6, X7 ) ); L4039: X5 = BOOLEAN( GTE( _S2CINT( X6 ), _S2CINT( _TSCP( 16658 ) ) ) ); if ( FALSE( X5 ) ) goto L4082; X6 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 23058 ) ), CHARACTERTAG ) ) ) goto L4046; X7 = CONS( _TSCP( 23058 ), EMPTYLIST ); scdebug_error( c2689, c2669, CONS( X6, X7 ) ); L4046: if ( GT( _S2CINT( X6 ), _S2CINT( _TSCP( 23058 ) ) ) ) goto L4082; X12 = PAIR_CAR( X1 ); if ( EQ( TSCPIMMEDIATETAG( X12 ), CHARACTERTAG ) ) goto L4051; scdebug_error( c2800, c2801, CONS( X12, EMPTYLIST ) ); L4051: X11 = CHAR_FIX( X12 ); if ( BITAND( BITOR( _S2CINT( X11 ), _S2CINT( _TSCP( 128 ) ) ), 3 ) ) goto L4054; X10 = _TSCP( IPLUS( _S2CINT( X11 ), _S2CINT( _TSCP( 128 ) ) ) ); goto L4055; L4054: X10 = scrt2__2b_2dtwo( X11, _TSCP( 128 ) ); L4055: X11 = BOOLEAN( NEQ( TSCPTAG( X10 ), FIXNUMTAG ) ); if ( TRUE( X11 ) ) goto L4061; if ( BITAND( BITOR( _S2CINT( X10 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4062; X12 = BOOLEAN( LT( _S2CINT( X10 ), _S2CINT( _TSCP( 0 ) ) ) ); goto L4063; L4062: X12 = scrt2__3c_2dtwo( X10, _TSCP( 0 ) ); L4063: if ( TRUE( X12 ) ) goto L4061; if ( BITAND( BITOR( _S2CINT( X10 ), _S2CINT( _TSCP( 1020 ) ) ), 3 ) ) goto L4070; if ( GT( _S2CINT( X10 ), _S2CINT( _TSCP( 1020 ) ) ) ) goto L4061; goto L4077; L4070: if ( FALSE( scrt2__3e_2dtwo( X10, _TSCP( 1020 ) ) ) ) goto L4077; L4061: scdebug_error( c2788, c2789, CONS( X10, EMPTYLIST ) ); L4077: X9 = FIX_CHAR( X10 ); X8 = sc_cons( X9, EMPTYLIST ); X7 = X8; X8 = scrt1_last_2dpair( X3 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L4080; scdebug_error( c2212, c2213, CONS( X8, EMPTYLIST ) ); L4080: SETGEN( PAIR_CDR( X8 ), X7 ); goto L4083; L4082: X7 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X7 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 24850 ) ), CHARACTERTAG ) ) ) goto L4085; X8 = CONS( _TSCP( 24850 ), EMPTYLIST ); scdebug_error( c2680, c2669, CONS( X7, X8 ) ); L4085: X6 = BOOLEAN( GTE( _S2CINT( X7 ), _S2CINT( _TSCP( 24850 ) ) ) ); if ( FALSE( X6 ) ) goto L4088; X7 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X7 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 31250 ) ), CHARACTERTAG ) ) ) goto L4091; X8 = CONS( _TSCP( 31250 ), EMPTYLIST ); scdebug_error( c2689, c2669, CONS( X7, X8 ) ); L4091: X5 = BOOLEAN( LTE( _S2CINT( X7 ), _S2CINT( _TSCP( 31250 ) ) ) ); goto L4089; L4088: X5 = X6; L4089: if ( TRUE( X5 ) ) goto L4097; X7 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X7 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 12306 ) ), CHARACTERTAG ) ) ) goto L4099; X8 = CONS( _TSCP( 12306 ), EMPTYLIST ); scdebug_error( c2680, c2669, CONS( X7, X8 ) ); L4099: X6 = BOOLEAN( GTE( _S2CINT( X7 ), _S2CINT( _TSCP( 12306 ) ) ) ); if ( FALSE( X6 ) ) goto L4122; X8 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPIMMEDIATETAG( X8 ), CHARACTERTAG ), EQ( TSCPIMMEDIATETAG( _TSCP( 14610 ) ), CHARACTERTAG ) ) ) goto L4106; X9 = CONS( _TSCP( 14610 ), EMPTYLIST ); scdebug_error( c2689, c2669, CONS( X8, X9 ) ); L4106: X7 = BOOLEAN( LTE( _S2CINT( X8 ), _S2CINT( _TSCP( 14610 ) ) ) ); if ( FALSE( X7 ) ) goto L4122; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 0 ) ) ), 3 ) ) goto L4113; if ( GT( _S2CINT( X2 ), _S2CINT( _TSCP( 0 ) ) ) ) goto L4097; goto L4122; L4113: if ( TRUE( scrt2__3e_2dtwo( X2, _TSCP( 0 ) ) ) ) goto L4097; L4122: X5 = scrt1_last_2dpair( X3 ); X7 = expform_char_2d_3edl( PAIR_CAR( X1 ), _TSCP( 64 ), _TSCP( 8 ) ); X6 = sc_cons( _TSCP( 24338 ), X7 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4124; scdebug_error( c2212, c2213, CONS( X5, EMPTYLIST ) ); L4124: SETGEN( PAIR_CDR( X5 ), X6 ); goto L4083; L4097: X6 = sc_cons( PAIR_CAR( X1 ), EMPTYLIST ); X5 = X6; X6 = scrt1_last_2dpair( X3 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4128; scdebug_error( c2212, c2213, CONS( X6, EMPTYLIST ) ); L4128: SETGEN( PAIR_CDR( X6 ), X5 ); L4083: if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X2 ) ), 3 ) ) goto L4130; X4 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X2 ) ) ); goto L4131; L4130: X4 = scrt2__2b_2dtwo( _TSCP( 4 ), X2 ); L4131: X2 = X4; X1 = PAIR_CAR( X1 ); GOBACK( L3990 ); } DEFTSCP( expform_hex28_v ); DEFCSTRING( t4132, "HEX28" ); EXTERNTSCPP( scrt2__3c_3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_3d_2dtwo_v ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCPP( expform_crc_2d32x2, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( expform_crc_2d32x2_v ); EXTERNTSCPP( scrt3_string_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2d_3elist_v ); EXTERNTSCPP( scrt3_substring, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt3_substring_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( scrt2_max_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_max_2dtwo_v ); EXTERNTSCPP( scrt3_char_2dnumeric_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt3_char_2dnumeric_3f_v ); TSCP expform_hex28( m2823, n2824 ) TSCP m2823, n2824; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4132 ); if ( AND( EQ( TSCPTAG( m2823 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( m2823 ), STRINGTAG ) ) ) goto L4135; scdebug_error( c2631, c2632, CONS( m2823, EMPTYLIST ) ); L4135: X2 = C_FIXED( STRING_LENGTH( m2823 ) ); if ( AND( EQ( TSCPTAG( n2824 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( n2824 ), STRINGTAG ) ) ) goto L4138; scdebug_error( c2631, c2632, CONS( n2824, EMPTYLIST ) ); L4138: X3 = C_FIXED( STRING_LENGTH( n2824 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X3 ) ), 3 ) ) goto L4141; X1 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( X3 ) ) ); goto L4142; L4141: X1 = scrt2__2b_2dtwo( X2, X3 ); L4142: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 112 ) ) ), 3 ) ) goto L4145; if ( LTE( _S2CINT( X1 ), _S2CINT( _TSCP( 112 ) ) ) ) goto L4149; goto L4150; L4145: if ( FALSE( scrt2__3c_3d_2dtwo( X1, _TSCP( 112 ) ) ) ) goto L4150; L4149: if ( TRUE( scrt1_equal_3f( m2823, sc_emptystring ) ) ) goto L4153; X1 = CONS( n2824, EMPTYLIST ); X1 = CONS( c2508, X1 ); POPSTACKTRACE( scrt3_string_2dappend( CONS( m2823, X1 ) ) ); L4153: POPSTACKTRACE( n2824 ); L4150: X5 = CONS( n2824, EMPTYLIST ); X4 = scrt3_string_2dappend( CONS( m2823, X5 ) ); X3 = scrt3_string_2d_3elist( X4 ); X2 = CONS( expform_crc_2d32x2( X3, _TSCP( 0 ), _TSCP( 0 ) ), EMPTYLIST ); X5 = C_FIXED( STRING_LENGTH( n2824 ) ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) goto L4157; X4 = _TSCP( IDIFFERENCE( _S2CINT( X5 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L4158; L4157: X4 = scrt2__2d_2dtwo( X5, _TSCP( 40 ) ); L4158: if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( X4 ) ), 3 ) ) goto L4160; if ( LTE( _S2CINT( _TSCP( 0 ) ), _S2CINT( X4 ) ) ) goto L4162; X3 = _TSCP( 0 ); goto L4161; L4162: X3 = X4; goto L4161; L4160: X3 = scrt2_max_2dtwo( _TSCP( 0 ), X4 ); L4161: X4 = C_FIXED( STRING_LENGTH( n2824 ) ); X2 = CONS( scrt3_substring( n2824, X3, X4 ), X2 ); X5 = C_FIXED( STRING_LENGTH( m2823 ) ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 36 ) ) ), 3 ) ) goto L4167; X4 = _TSCP( IDIFFERENCE( _S2CINT( X5 ), _S2CINT( _TSCP( 36 ) ) ) ); goto L4168; L4167: X4 = scrt2__2d_2dtwo( X5, _TSCP( 36 ) ); L4168: if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( X4 ) ), 3 ) ) goto L4170; if ( LTE( _S2CINT( _TSCP( 0 ) ), _S2CINT( X4 ) ) ) goto L4172; X3 = _TSCP( 0 ); goto L4171; L4172: X3 = X4; goto L4171; L4170: X3 = scrt2_max_2dtwo( _TSCP( 0 ), X4 ); L4171: X4 = C_FIXED( STRING_LENGTH( m2823 ) ); X2 = CONS( scrt3_substring( m2823, X3, X4 ), X2 ); X1 = scrt6_format( EMPTYLIST, CONS( c2904, X2 ) ); if ( EQ( TSCPTAG( _TSCP( 0 ) ), FIXNUMTAG ) ) goto L4179; scdebug_error( c2639, c2640, CONS( _TSCP( 0 ), EMPTYLIST ) ); L4179: X3 = BOOLEAN( LT( _S2CINT( _TSCP( 0 ) ), 0 ) ); if ( TRUE( X3 ) ) goto L4185; if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), STRINGTAG ) ) ) goto L4187; scdebug_error( c2631, c2632, CONS( X1, EMPTYLIST ) ); L4187: X4 = C_FIXED( STRING_LENGTH( X1 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( X4 ) ), 3 ) ) goto L4191; if ( GTE( _S2CINT( _TSCP( 0 ) ), _S2CINT( X4 ) ) ) goto L4185; goto L4198; L4191: if ( FALSE( scrt2__3e_3d_2dtwo( _TSCP( 0 ), X4 ) ) ) goto L4198; L4185: scdebug_error( c2639, c2661, CONS( _TSCP( 0 ), EMPTYLIST ) ); L4198: X2 = C_CHAR( STRING_CHAR( X1, _TSCP( 0 ) ) ); if ( FALSE( scrt3_char_2dnumeric_3f( X2 ) ) ) goto L4176; if ( EQ( TSCPIMMEDIATETAG( _TSCP( 24338 ) ), CHARACTERTAG ) ) goto L4200; scdebug_error( c2879, c2882, CONS( _TSCP( 24338 ), EMPTYLIST ) ); L4200: X2 = BOOLEAN( LT( _S2CINT( _TSCP( 0 ) ), 0 ) ); if ( TRUE( X2 ) ) goto L4206; if ( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), STRINGTAG ) ) ) goto L4208; scdebug_error( c2631, c2632, CONS( X1, EMPTYLIST ) ); L4208: X3 = C_FIXED( STRING_LENGTH( X1 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( X3 ) ), 3 ) ) goto L4212; if ( GTE( _S2CINT( _TSCP( 0 ) ), _S2CINT( X3 ) ) ) goto L4206; goto L4219; L4212: if ( FALSE( scrt2__3e_3d_2dtwo( _TSCP( 0 ), X3 ) ) ) goto L4219; L4206: scdebug_error( c2879, c2903, EMPTYLIST ); L4219: STRING_CHAR( X1, _TSCP( 0 ) ) = CHAR_C( _TSCP( 24338 ) ); L4176: POPSTACKTRACE( X1 ); } DEFTSCP( expform_crc_2d32x2_v ); DEFCSTRING( t4220, "CRC-32X2" ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); EXTERNTSCPP( scrt2_remainder, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_remainder_v ); EXTERNTSCPP( scrt2_quotient, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_quotient_v ); EXTERNTSCPP( scrt4_bit_2dlsh, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2dlsh_v ); EXTERNTSCPP( scrt4_bit_2dxor, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2dxor_v ); EXTERNTSCPP( scrt4_bit_2drsh, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2drsh_v ); EXTERNTSCP( expform_t_2dleft_v ); EXTERNTSCPP( scrt4_bit_2dor, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2dor_v ); EXTERNTSCPP( scrt4_bit_2dand, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt4_bit_2dand_v ); EXTERNTSCP( expform_t_2dright_v ); TSCP expform_crc_2d32x2( c2949, c2950, c2951 ) TSCP c2949, c2950, c2951; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4220 ); L4221: if ( NEQ( _S2CUINT( c2949 ), _S2CUINT( EMPTYLIST ) ) ) goto L4222; X1 = EMPTYLIST; X2 = c2950; X3 = c2951; L4225: if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L4226; X4 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ); goto L4227; L4226: X4 = scrt2_zero_3f( X2 ); L4227: if ( FALSE( X4 ) ) goto L4241; if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L4233; if ( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4237; goto L4241; L4233: if ( FALSE( scrt2_zero_3f( X3 ) ) ) goto L4241; L4237: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L4242; POPSTACKTRACE( scrt3_list_2d_3estring( X1 ) ); L4242: POPSTACKTRACE( c3166 ); L4241: X7 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 64 ) ) ), 3 ) ) ); if ( FALSE( X7 ) ) goto L4250; if ( EQ( _S2CUINT( _TSCP( 64 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4250; X6 = _TSCP( REMAINDER( _S2CINT( X3 ), _S2CINT( _TSCP( 64 ) ) ) ); goto L4251; L4250: X6 = scrt2_remainder( X3, _TSCP( 64 ) ); L4251: if ( EQ( TSCPTAG( X6 ), FIXNUMTAG ) ) goto L4253; scdebug_error( c2639, c2640, CONS( X6, EMPTYLIST ) ); L4253: X7 = BOOLEAN( LT( _S2CINT( X6 ), 0 ) ); if ( TRUE( X7 ) ) goto L4259; if ( AND( EQ( TSCPTAG( c3101 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c3101 ), STRINGTAG ) ) ) goto L4261; scdebug_error( c2631, c2632, CONS( c3101, EMPTYLIST ) ); L4261: X8 = C_FIXED( STRING_LENGTH( c3101 ) ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( X8 ) ), 3 ) ) goto L4265; if ( GTE( _S2CINT( X6 ), _S2CINT( X8 ) ) ) goto L4259; goto L4272; L4265: if ( FALSE( scrt2__3e_3d_2dtwo( X6, X8 ) ) ) goto L4272; L4259: scdebug_error( c2639, c2661, CONS( X6, EMPTYLIST ) ); L4272: X5 = C_CHAR( STRING_CHAR( c3101, X6 ) ); X4 = sc_cons( X5, X1 ); X6 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 64 ) ) ), 3 ) ) ); if ( FALSE( X6 ) ) goto L4279; if ( EQ( _S2CUINT( _TSCP( 64 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4279; X5 = C_FIXED( QUOTIENT( _S2CINT( X2 ), _S2CINT( _TSCP( 64 ) ) ) ); goto L4280; L4279: X5 = scrt2_quotient( X2, _TSCP( 64 ) ); L4280: X8 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 64 ) ) ), 3 ) ) ); if ( FALSE( X8 ) ) goto L4287; if ( EQ( _S2CUINT( _TSCP( 64 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4287; X7 = _TSCP( REMAINDER( _S2CINT( X2 ), _S2CINT( _TSCP( 64 ) ) ) ); goto L4288; L4287: X7 = scrt2_remainder( X2, _TSCP( 64 ) ); L4288: X6 = scrt4_bit_2dlsh( X7, _TSCP( 48 ) ); X8 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 64 ) ) ), 3 ) ) ); if ( FALSE( X8 ) ) goto L4295; if ( EQ( _S2CUINT( _TSCP( 64 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4295; X7 = C_FIXED( QUOTIENT( _S2CINT( X3 ), _S2CINT( _TSCP( 64 ) ) ) ); goto L4296; L4295: X7 = scrt2_quotient( X3, _TSCP( 64 ) ); L4296: if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( X7 ) ), 3 ) ) goto L4298; X3 = _TSCP( IPLUS( _S2CINT( X6 ), _S2CINT( X7 ) ) ); goto L4299; L4298: X3 = scrt2__2b_2dtwo( X6, X7 ); L4299: X2 = X5; X1 = X4; GOBACK( L4225 ); L4222: if ( EQ( TSCPTAG( c2949 ), PAIRTAG ) ) goto L4301; scrt1__24__car_2derror( c2949 ); L4301: X2 = PAIR_CAR( c2949 ); if ( EQ( TSCPIMMEDIATETAG( X2 ), CHARACTERTAG ) ) goto L4304; scdebug_error( c2800, c2801, CONS( X2, EMPTYLIST ) ); L4304: X1 = CHAR_FIX( X2 ); X2 = PAIR_CDR( c2949 ); X4 = scrt4_bit_2drsh( c2950, _TSCP( 32 ) ); X7 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( c2951 ), _S2CINT( _TSCP( 1024 ) ) ), 3 ) ) ); if ( FALSE( X7 ) ) goto L4314; if ( EQ( _S2CUINT( _TSCP( 1024 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4314; X6 = _TSCP( REMAINDER( _S2CINT( c2951 ), _S2CINT( _TSCP( 1024 ) ) ) ); goto L4315; L4314: X6 = scrt2_remainder( c2951, _TSCP( 1024 ) ); L4315: X7 = expform_t_2dleft_v; if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), VECTORTAG ) ) ) goto L4317; scdebug_error( c2969, c2970, CONS( X7, EMPTYLIST ) ); L4317: if ( EQ( TSCPTAG( X6 ), FIXNUMTAG ) ) goto L4319; scdebug_error( c2969, c2640, CONS( X6, EMPTYLIST ) ); L4319: if ( LT( _S2CUINT( FIXED_C( X6 ) ), _S2CUINT( VECTOR_LENGTH( X7 ) ) ) ) goto L4321; scdebug_error( c2969, c2976, CONS( X6, EMPTYLIST ) ); L4321: X5 = CONS( VECTOR_ELEMENT( X7, X6 ), EMPTYLIST ); X6 = expform_t_2dleft_v; if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), VECTORTAG ) ) ) goto L4324; scdebug_error( c2969, c2970, CONS( X6, EMPTYLIST ) ); L4324: if ( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L4326; scdebug_error( c2969, c2640, CONS( X1, EMPTYLIST ) ); L4326: if ( LT( _S2CUINT( FIXED_C( X1 ) ), _S2CUINT( VECTOR_LENGTH( X6 ) ) ) ) goto L4328; scdebug_error( c2969, c2976, CONS( X1, EMPTYLIST ) ); L4328: X3 = scrt4_bit_2dxor( X4, CONS( VECTOR_ELEMENT( X6, X1 ), X5 ) ); X6 = scrt4_bit_2dand( c2950, CONS( _TSCP( 1020 ), EMPTYLIST ) ); X5 = scrt4_bit_2dlsh( X6, _TSCP( 32 ) ); X4 = scrt4_bit_2dor( X5, CONS( scrt4_bit_2drsh( c2951, _TSCP( 32 ) ), EMPTYLIST ) ); X7 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( c2951 ), _S2CINT( _TSCP( 1024 ) ) ), 3 ) ) ); if ( FALSE( X7 ) ) goto L4336; if ( EQ( _S2CUINT( _TSCP( 1024 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4336; X6 = _TSCP( REMAINDER( _S2CINT( c2951 ), _S2CINT( _TSCP( 1024 ) ) ) ); goto L4337; L4336: X6 = scrt2_remainder( c2951, _TSCP( 1024 ) ); L4337: X7 = expform_t_2dright_v; if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), VECTORTAG ) ) ) goto L4339; scdebug_error( c2969, c2970, CONS( X7, EMPTYLIST ) ); L4339: if ( EQ( TSCPTAG( X6 ), FIXNUMTAG ) ) goto L4341; scdebug_error( c2969, c2640, CONS( X6, EMPTYLIST ) ); L4341: if ( LT( _S2CUINT( FIXED_C( X6 ) ), _S2CUINT( VECTOR_LENGTH( X7 ) ) ) ) goto L4343; scdebug_error( c2969, c2976, CONS( X6, EMPTYLIST ) ); L4343: X5 = CONS( VECTOR_ELEMENT( X7, X6 ), EMPTYLIST ); X6 = expform_t_2dright_v; if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), VECTORTAG ) ) ) goto L4346; scdebug_error( c2969, c2970, CONS( X6, EMPTYLIST ) ); L4346: if ( LT( _S2CUINT( FIXED_C( X1 ) ), _S2CUINT( VECTOR_LENGTH( X6 ) ) ) ) goto L4348; scdebug_error( c2969, c2976, CONS( X1, EMPTYLIST ) ); L4348: c2951 = scrt4_bit_2dxor( X4, CONS( VECTOR_ELEMENT( X6, X1 ), X5 ) ); c2950 = X3; c2949 = X2; GOBACK( L4221 ); } DEFTSCP( expform_t_2dleft_v ); DEFCSTRING( t4350, "T-LEFT" ); DEFTSCP( expform_t_2dright_v ); DEFCSTRING( t4351, "T-RIGHT" ); DEFTSCP( expform_char_2d_3edl_v ); DEFCSTRING( t4352, "CHAR->DL" ); TSCP expform_char_2d_3edl( c3170, b3171, l3172 ) TSCP c3170, b3171, l3172; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4352 ); c3170 = CONS( c3170, EMPTYLIST ); l3172 = CONS( l3172, EMPTYLIST ); X2 = PAIR_CAR( c3170 ); if ( EQ( TSCPIMMEDIATETAG( X2 ), CHARACTERTAG ) ) goto L4355; scdebug_error( c2800, c2801, CONS( X2, EMPTYLIST ) ); L4355: X1 = CHAR_FIX( X2 ); SETGEN( PAIR_CAR( c3170 ), X1 ); X1 = EMPTYLIST; L4358: X1 = CONS( X1, EMPTYLIST ); X2 = PAIR_CAR( l3172 ); if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L4361; if ( NEQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4365; POPSTACKTRACE( PAIR_CAR( X1 ) ); L4361: if ( FALSE( scrt2_zero_3f( X2 ) ) ) goto L4365; POPSTACKTRACE( PAIR_CAR( X1 ) ); L4365: X5 = PAIR_CAR( c3170 ); X6 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( b3171 ) ), 3 ) ) ); if ( FALSE( X6 ) ) goto L4376; if ( EQ( _S2CUINT( b3171 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4376; X4 = _TSCP( REMAINDER( _S2CINT( X5 ), _S2CINT( b3171 ) ) ); goto L4377; L4376: X4 = scrt2_remainder( X5, b3171 ); L4377: if ( EQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L4379; scdebug_error( c2639, c2640, CONS( X4, EMPTYLIST ) ); L4379: X5 = BOOLEAN( LT( _S2CINT( X4 ), 0 ) ); if ( TRUE( X5 ) ) goto L4385; if ( AND( EQ( TSCPTAG( c3101 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c3101 ), STRINGTAG ) ) ) goto L4387; scdebug_error( c2631, c2632, CONS( c3101, EMPTYLIST ) ); L4387: X6 = C_FIXED( STRING_LENGTH( c3101 ) ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( X6 ) ), 3 ) ) goto L4391; if ( GTE( _S2CINT( X4 ), _S2CINT( X6 ) ) ) goto L4385; goto L4398; L4391: if ( FALSE( scrt2__3e_3d_2dtwo( X4, X6 ) ) ) goto L4398; L4385: scdebug_error( c2639, c2661, CONS( X4, EMPTYLIST ) ); L4398: X3 = C_CHAR( STRING_CHAR( c3101, X4 ) ); X2 = sc_cons( X3, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X2 ); X3 = PAIR_CAR( c3170 ); X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( b3171 ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L4406; if ( EQ( _S2CUINT( b3171 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L4406; X2 = C_FIXED( QUOTIENT( _S2CINT( X3 ), _S2CINT( b3171 ) ) ); goto L4407; L4406: X2 = scrt2_quotient( X3, b3171 ); L4407: SETGEN( PAIR_CAR( c3170 ), X2 ); X3 = PAIR_CAR( l3172 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4409; X2 = _TSCP( IDIFFERENCE( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4410; L4409: X2 = scrt2__2d_2dtwo( X3, _TSCP( 4 ) ); L4410: SETGEN( PAIR_CAR( l3172 ), X2 ); X1 = PAIR_CAR( X1 ); GOBACK( L4358 ); } DEFTSCP( expform_newv_v ); DEFCSTRING( t4411, "NEWV" ); EXTERNTSCPP( expform_make_2dalpha, XAL1( TSCP ) ); EXTERNTSCP( expform_make_2dalpha_v ); EXTERNTSCPP( scrt1_memv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memv_v ); TSCP expform_newv( v3250, p3251 ) TSCP v3250, p3251; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4411 ); X1 = plist_get( v3250, c2078 ); X3 = scrt1_memq( c2077, p3251 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4416; scrt1__24__cdr_2derror( X3 ); L4416: X4 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4419; scrt1__24__car_2derror( X4 ); L4419: X2 = PAIR_CAR( X4 ); X3 = EMPTYLIST; X3 = CONS( X3, EMPTYLIST ); if ( FALSE( X1 ) ) goto L4447; if ( FALSE( scrt1_memq( X2, c3262 ) ) ) goto L4447; if ( FALSE( plist_get( X1, c2082 ) ) ) goto L4442; X4 = plist_get( X1, c2077 ); if ( EQ( _S2CUINT( X4 ), _S2CUINT( c3279 ) ) ) goto L4434; if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2078 ) ) ) goto L4442; L4434: if ( FALSE( plist_get( X1, c2356 ) ) ) goto L4438; X4 = SYMBOL_VALUE( report_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); VIA( PROCEDURE_CODE( X4 ) )( c3297, v3250, PROCEDURE_CLOSURE( X4 ) ); goto L4442; L4438: X4 = plist_get( X1, c2082 ); if ( EQ( _S2CUINT( X4 ), _S2CUINT( c2029 ) ) ) goto L4442; X4 = plist_get( X1, c2082 ); X5 = SYMBOL_VALUE( module_2dname_v ); if ( TRUE( scrt1_equal_3f( X4, X5 ) ) ) goto L4442; X4 = SYMBOL_VALUE( report_2dwarning_v ); X4 = UNKNOWNCALL( X4, 2 ); VIA( PROCEDURE_CODE( X4 ) )( c3297, v3250, PROCEDURE_CLOSURE( X4 ) ); L4442: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2078 ) ) ) goto L4444; X4 = X1; SETGEN( PAIR_CAR( X3 ), X4 ); plist_put( PAIR_CAR( X3 ), c2330, EMPTYLIST ); plist_put( PAIR_CAR( X3 ), c2082, EMPTYLIST ); plist_put( PAIR_CAR( X3 ), c2099, EMPTYLIST ); plist_put( PAIR_CAR( X3 ), c2254, EMPTYLIST ); goto L4448; L4444: X4 = expform_make_2dalpha( v3250 ); SETGEN( PAIR_CAR( X3 ), X4 ); goto L4448; L4447: X4 = expform_make_2dalpha( v3250 ); SETGEN( PAIR_CAR( X3 ), X4 ); L4448: plist_put( PAIR_CAR( X3 ), c2229, v3250 ); X4 = p3251; L4450: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L4451; X5 = plist_get( PAIR_CAR( X3 ), c2077 ); if ( FALSE( scrt1_memv( X5, c3355 ) ) ) goto L4455; plist_put( v3250, c2078, PAIR_CAR( X3 ) ); if ( EQ( _S2CUINT( PAIR_CAR( X3 ) ), _S2CUINT( X1 ) ) ) goto L4464; X8 = sc_cons( PAIR_CAR( X3 ), EMPTYLIST ); X7 = sc_cons( v3250, X8 ); X6 = X7; expform_global_2dfree_2dvars_v = sc_cons( X6, expform_global_2dfree_2dvars_v ); goto L4464; L4455: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c3359 ) ) ) goto L4461; X8 = sc_cons( PAIR_CAR( X3 ), EMPTYLIST ); X7 = sc_cons( v3250, X8 ); X6 = X7; expform_und_2dvars_85c10849_v = sc_cons( X6, expform_und_2dvars_85c10849_v ); goto L4464; L4461: if ( FALSE( scrt1_memv( X5, c3360 ) ) ) goto L4464; X7 = SYMBOL_VALUE( downshift_v ); X7 = UNKNOWNCALL( X7, 1 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( PAIR_CAR( X3 ), PROCEDURE_CLOSURE( X7 ) ); plist_put( PAIR_CAR( X3 ), c2229, PAIR_CAR( X3 ) ); X7 = plist_get( PAIR_CAR( X3 ), c2077 ); if ( NEQ( _S2CUINT( X7 ), _S2CUINT( c2330 ) ) ) goto L4467; X8 = SYMBOL_VALUE( module_2dname_v ); X7 = expform_hex28( X8, X6 ); plist_put( PAIR_CAR( X3 ), c2254, X7 ); goto L4468; L4467: X7 = expform_hex28( sc_emptystring, X6 ); plist_put( PAIR_CAR( X3 ), c2254, X7 ); L4468: X7 = expform_hex28( sc_emptystring, X6 ); plist_put( PAIR_CAR( X3 ), c2099, X7 ); L4464: POPSTACKTRACE( PAIR_CAR( X3 ) ); L4451: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4471; scrt1__24__car_2derror( X4 ); L4471: X5 = PAIR_CAR( X4 ); X7 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L4475; scrt1__24__car_2derror( X7 ); L4475: X6 = PAIR_CAR( X7 ); plist_put( PAIR_CAR( X3 ), X5, X6 ); X5 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4479; scrt1__24__cdr_2derror( X5 ); L4479: X4 = PAIR_CDR( X5 ); GOBACK( L4450 ); } DEFTSCP( expform_make_2dalpha_v ); DEFCSTRING( t4481, "MAKE-ALPHA" ); EXTERNTSCPP( sc_string_2d_3esymbol, XAL1( TSCP ) ); EXTERNTSCP( sc_string_2d_3esymbol_v ); TSCP expform_make_2dalpha( v3407 ) TSCP v3407; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4481 ); L4482: if ( AND( EQ( TSCPTAG( v3407 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( v3407 ), SYMBOLTAG ) ) ) goto L4484; scdebug_error( c2610, c2611, CONS( v3407, EMPTYLIST ) ); L4484: X2 = SYMBOL_NAME( v3407 ); if ( EQ( TSCPTAG( _TSCP( 0 ) ), FIXNUMTAG ) ) goto L4487; scdebug_error( c2639, c2640, CONS( _TSCP( 0 ), EMPTYLIST ) ); L4487: X3 = BOOLEAN( LT( _S2CINT( _TSCP( 0 ) ), 0 ) ); if ( TRUE( X3 ) ) goto L4493; if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) goto L4495; scdebug_error( c2631, c2632, CONS( X2, EMPTYLIST ) ); L4495: X4 = C_FIXED( STRING_LENGTH( X2 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( X4 ) ), 3 ) ) goto L4499; if ( GTE( _S2CINT( _TSCP( 0 ) ), _S2CINT( X4 ) ) ) goto L4493; goto L4506; L4499: if ( FALSE( scrt2__3e_3d_2dtwo( _TSCP( 0 ), X4 ) ) ) goto L4506; L4493: scdebug_error( c2639, c2661, CONS( _TSCP( 0 ), EMPTYLIST ) ); L4506: X1 = C_CHAR( STRING_CHAR( X2, _TSCP( 0 ) ) ); X4 = CONS( expform_make_2dalpha_2dseq_v, EMPTYLIST ); X4 = CONS( X1, X4 ); X3 = scrt6_format( EMPTYLIST, CONS( c3420, X4 ) ); X2 = sc_string_2d_3esymbol( X3 ); X3 = expform_make_2dalpha_2dseq_v; if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4510; X4 = _TSCP( IPLUS( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4511; L4510: X4 = scrt2__2b_2dtwo( X3, _TSCP( 4 ) ); L4511: expform_make_2dalpha_2dseq_v = X4; if ( TRUE( plist_get( X2, c2229 ) ) ) GOBACK( L4482 ); POPSTACKTRACE( X2 ); } DEFTSCP( expform_bound_v ); DEFCSTRING( t4514, "BOUND" ); EXTERNTSCPP( scrt1_assq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assq_v ); TSCP expform_bound( v3451 ) TSCP v3451; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4514 ); X1 = scrt1_assq( v3451, expform_und_2dvars_85c10849_v ); if ( FALSE( X1 ) ) goto L4517; X2 = X1; goto L4518; L4517: X2 = scrt1_assq( v3451, expform_lexical_2dfree_2dvars_v ); L4518: X2 = CONS( X2, EMPTYLIST ); X4 = PAIR_CAR( X2 ); if ( FALSE( X4 ) ) goto L4521; X3 = X4; goto L4522; L4521: X3 = plist_get( v3451, c2078 ); L4522: if ( FALSE( X1 ) ) goto L4524; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4527; scrt1__24__cdr_2derror( X1 ); L4527: X4 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4530; scrt1__24__car_2derror( X4 ); L4530: POPSTACKTRACE( PAIR_CAR( X4 ) ); L4524: if ( FALSE( PAIR_CAR( X2 ) ) ) goto L4532; X5 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4537; scrt1__24__cdr_2derror( X5 ); L4537: X6 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4540; scrt1__24__car_2derror( X6 ); L4540: X4 = PAIR_CAR( X6 ); SETGEN( PAIR_CAR( X2 ), X4 ); POPSTACKTRACE( PAIR_CAR( X2 ) ); L4532: if ( FALSE( X3 ) ) goto L4542; X4 = plist_get( X3, c2077 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2029 ) ) ) goto L4547; X4 = SYMBOL_VALUE( find_2dquote_2dconstant_v ); X4 = UNKNOWNCALL( X4, 2 ); if ( TRUE( VIA( PROCEDURE_CODE( X4 ) )( v3451, c2029, PROCEDURE_CLOSURE( X4 ) ) ) ) goto L4547; X6 = sc_cons( X3, EMPTYLIST ); X5 = sc_cons( v3451, X6 ); X4 = X5; X5 = SYMBOL_VALUE( quote_2dconstants_v ); SETGENTL( SYMBOL_VALUE( quote_2dconstants_v ), sc_cons( X4, X5 ) ); L4547: POPSTACKTRACE( X3 ); L4542: X4 = CONS( SYMBOL_VALUE( current_2ddefine_2dname_v ), EMPTYLIST ); X4 = CONS( c2086, X4 ); X4 = CONS( c2078, X4 ); POPSTACKTRACE( expform_newv( v3451, CONS( c2077, X4 ) ) ); } DEFTSCP( expform_expand_2derror_v ); DEFCSTRING( t4550, "EXPAND-ERROR" ); TSCP expform_expand_2derror( f3503, e3504 ) TSCP f3503, e3504; { TSCP X1; PUSHSTACKTRACE( t4550 ); X1 = SYMBOL_VALUE( report_2derror_v ); X1 = UNKNOWNCALL( X1, 4 ); VIA( PROCEDURE_CODE( X1 ) )( c3505, f3503, c3506, e3504, PROCEDURE_CLOSURE( X1 ) ); POPSTACKTRACE( c3507 ); } void scrt4__init(); void scrt2__init(); void scdebug__init(); void scrt3__init(); void plist__init(); void scrt1__init(); void scrt6__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt4__init(); scrt2__init(); scdebug__init(); scrt3__init(); plist__init(); scrt1__init(); scrt6__init(); MAXDISPLAY( 0 ); } void expform__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(expform SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3759, ADR( expform_global_2dfree_2dvars_v ), EMPTYLIST ); INITIALIZEVAR( t3760, ADR( expform_lexical_2dfree_2dvars_v ), EMPTYLIST ); INITIALIZEVAR( t3761, ADR( expform_und_2dvars_85c10849_v ), EMPTYLIST ); INITIALIZEVAR( t3762, ADR( expform_current_2dlambda_2did_v ), c2029 ); INITIALIZEVAR( t3763, ADR( expform_make_2dalpha_2dseq_v ), _TSCP( 0 ) ); INITIALIZEVAR( t3764, ADR( expform_expand_2dforms_v ), MAKEPROCEDURE( 0, 0, expform_expand_2dforms, EMPTYLIST ) ); INITIALIZEVAR( t3799, ADR( expform_exp_2dform_v ), MAKEPROCEDURE( 2, 0, expform_exp_2dform, EMPTYLIST ) ); INITIALIZEVAR( t3833, ADR( expform_exp_2dform_2dlist_v ), MAKEPROCEDURE( 2, 0, expform_exp_2dform_2dlist, EMPTYLIST ) ); INITIALIZEVAR( t3852, ADR( expform_id_2dprintname_v ), MAKEPROCEDURE( 1, 0, expform_id_2dprintname, EMPTYLIST ) ); INITIALIZEVAR( t3854, ADR( expform_intname_21_e25cd208_v ), MAKEPROCEDURE( 2, 0, expform_intname_21_e25cd208, EMPTYLIST ) ); INITIALIZEVAR( t3856, ADR( expform_id_2dvname_v ), MAKEPROCEDURE( 1, 0, expform_id_2dvname, EMPTYLIST ) ); INITIALIZEVAR( t3858, ADR( expform_set_2did_2dvname_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dvname_21, EMPTYLIST ) ); INITIALIZEVAR( t3860, ADR( expform_id_2dcname_v ), MAKEPROCEDURE( 1, 0, expform_id_2dcname, EMPTYLIST ) ); INITIALIZEVAR( t3862, ADR( expform_set_2did_2dcname_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dcname_21, EMPTYLIST ) ); INITIALIZEVAR( t3864, ADR( expform_id_2dmodule_v ), MAKEPROCEDURE( 1, 0, expform_id_2dmodule, EMPTYLIST ) ); INITIALIZEVAR( t3866, ADR( expform_set_2did_2dmodule_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dmodule_21, EMPTYLIST ) ); INITIALIZEVAR( t3868, ADR( expform_id_2duse_v ), MAKEPROCEDURE( 1, 0, expform_id_2duse, EMPTYLIST ) ); INITIALIZEVAR( t3870, ADR( expform_set_2did_2duse_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2duse_21, EMPTYLIST ) ); INITIALIZEVAR( t3872, ADR( expform_id_2dtype_v ), MAKEPROCEDURE( 1, 0, expform_id_2dtype, EMPTYLIST ) ); INITIALIZEVAR( t3874, ADR( expform_set_2did_2dtype_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dtype_21, EMPTYLIST ) ); INITIALIZEVAR( t3876, ADR( expform_id_2ddisplay_v ), MAKEPROCEDURE( 1, 0, expform_id_2ddisplay, EMPTYLIST ) ); INITIALIZEVAR( t3878, ADR( expform_set_2did_2ddisplay_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2ddisplay_21, EMPTYLIST ) ); INITIALIZEVAR( t3880, ADR( expform_id_2dboundid_v ), MAKEPROCEDURE( 1, 0, expform_id_2dboundid, EMPTYLIST ) ); INITIALIZEVAR( t3882, ADR( expform_set_2did_2dboundid_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dboundid, EMPTYLIST ) ); INITIALIZEVAR( t3884, ADR( expform_id_2dlambda_v ), MAKEPROCEDURE( 1, 0, expform_id_2dlambda, EMPTYLIST ) ); INITIALIZEVAR( t3886, ADR( expform_set_2did_2dlambda_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dlambda_21, EMPTYLIST ) ); INITIALIZEVAR( t3888, ADR( expform_id_2dexternal_v ), MAKEPROCEDURE( 1, 0, expform_id_2dexternal, EMPTYLIST ) ); INITIALIZEVAR( t3890, ADR( expform_xternal_21_97042b81_v ), MAKEPROCEDURE( 2, 0, expform_xternal_21_97042b81, EMPTYLIST ) ); INITIALIZEVAR( t3892, ADR( expform_id_2ddefined_v ), MAKEPROCEDURE( 1, 0, expform_id_2ddefined, EMPTYLIST ) ); INITIALIZEVAR( t3894, ADR( expform_set_2did_2ddefined_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2ddefined_21, EMPTYLIST ) ); INITIALIZEVAR( t3896, ADR( expform_id_2dvalue_v ), MAKEPROCEDURE( 1, 0, expform_id_2dvalue, EMPTYLIST ) ); INITIALIZEVAR( t3898, ADR( expform_set_2did_2dvalue_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dvalue_21, EMPTYLIST ) ); INITIALIZEVAR( t3900, ADR( expform_id_2dset_21_v ), MAKEPROCEDURE( 1, 0, expform_id_2dset_21, EMPTYLIST ) ); INITIALIZEVAR( t3902, ADR( expform_set_2did_2dset_21_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dset_21_21, EMPTYLIST ) ); INITIALIZEVAR( t3904, ADR( expform_id_2drefs_v ), MAKEPROCEDURE( 1, 0, expform_id_2drefs, EMPTYLIST ) ); INITIALIZEVAR( t3906, ADR( expform_set_2did_2drefs_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2drefs_21, EMPTYLIST ) ); INITIALIZEVAR( t3908, ADR( expform_id_2dcalls_v ), MAKEPROCEDURE( 1, 0, expform_id_2dcalls, EMPTYLIST ) ); INITIALIZEVAR( t3910, ADR( expform_set_2did_2dcalls_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dcalls_21, EMPTYLIST ) ); INITIALIZEVAR( t3912, ADR( expform_id_2dalias_v ), MAKEPROCEDURE( 1, 0, expform_id_2dalias, EMPTYLIST ) ); INITIALIZEVAR( t3914, ADR( expform_set_2did_2dalias_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dalias_21, EMPTYLIST ) ); INITIALIZEVAR( t3916, ADR( expform_id_2dgotos_v ), MAKEPROCEDURE( 1, 0, expform_id_2dgotos, EMPTYLIST ) ); INITIALIZEVAR( t3918, ADR( expform_set_2did_2dgotos_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dgotos_21, EMPTYLIST ) ); INITIALIZEVAR( t3920, ADR( expform_id_2dundefref_v ), MAKEPROCEDURE( 1, 0, expform_id_2dundefref, EMPTYLIST ) ); INITIALIZEVAR( t3922, ADR( expform_ndefref_21_c23a600d_v ), MAKEPROCEDURE( 2, 0, expform_ndefref_21_c23a600d, EMPTYLIST ) ); INITIALIZEVAR( t3924, ADR( expform_id_2dglobal_v ), MAKEPROCEDURE( 1, 0, expform_id_2dglobal, EMPTYLIST ) ); INITIALIZEVAR( t3926, ADR( expform_set_2did_2dglobal_21_v ), MAKEPROCEDURE( 2, 0, expform_set_2did_2dglobal_21, EMPTYLIST ) ); INITIALIZEVAR( t3928, ADR( expform_assign_2dknown_2dname_v ), MAKEPROCEDURE( 1, 0, expform_assign_2dknown_2dname, EMPTYLIST ) ); INITIALIZEVAR( t3945, ADR( expform_name_2da_2dlambda_v ), MAKEPROCEDURE( 2, 0, expform_name_2da_2dlambda, EMPTYLIST ) ); INITIALIZEVAR( t3963, ADR( expform_vname_v ), MAKEPROCEDURE( 1, 0, expform_vname, EMPTYLIST ) ); INITIALIZEVAR( t3972, ADR( expform_cname_v ), MAKEPROCEDURE( 1, 0, expform_cname, EMPTYLIST ) ); INITIALIZEVAR( t3981, ADR( expform_lchexname_v ), MAKEPROCEDURE( 1, 0, expform_lchexname, EMPTYLIST ) ); INITIALIZEVAR( t4132, ADR( expform_hex28_v ), MAKEPROCEDURE( 2, 0, expform_hex28, EMPTYLIST ) ); INITIALIZEVAR( t4220, ADR( expform_crc_2d32x2_v ), MAKEPROCEDURE( 3, 0, expform_crc_2d32x2, EMPTYLIST ) ); INITIALIZEVAR( t4350, ADR( expform_t_2dleft_v ), c3167 ); INITIALIZEVAR( t4351, ADR( expform_t_2dright_v ), c3168 ); INITIALIZEVAR( t4352, ADR( expform_char_2d_3edl_v ), MAKEPROCEDURE( 3, 0, expform_char_2d_3edl, EMPTYLIST ) ); INITIALIZEVAR( t4411, ADR( expform_newv_v ), MAKEPROCEDURE( 1, 1, expform_newv, EMPTYLIST ) ); INITIALIZEVAR( t4481, ADR( expform_make_2dalpha_v ), MAKEPROCEDURE( 1, 0, expform_make_2dalpha, EMPTYLIST ) ); INITIALIZEVAR( t4514, ADR( expform_bound_v ), MAKEPROCEDURE( 1, 0, expform_bound, EMPTYLIST ) ); INITIALIZEVAR( t4550, ADR( expform_expand_2derror_v ), MAKEPROCEDURE( 2, 0, expform_expand_2derror, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/expform.sc000066400000000000000000000473661203736146400165630ustar00rootroot00000000000000;;; The "first pass" of this Scheme compiler reads the source files and ;;; performs the following operations: ;;; ;;; - macro and special form expansion ;;; - alpha-conversion ;;; - lexical variable usage recording ;;; ;;; At the end of this pass, all bindings and control flows should be visible ;;; in the tree. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module expform) ;;; Pick up external declarations. (include "plist.sch") (include "expform.sch") (include "lambdaexp.sch") ;;; During compilation, variable binding information is kept in the following ;;; global variables. Each is an a-list with entries of the form: ;;; ;;; (external-name alpha-converted-name) ;;; ;;; LEXICAL-BOUND-VARS contains the variables which are bound at the current ;;; lexical level. LEXICAL-FREE-VARS contains the variables which are ;;; lexically bound at higher lexical levels. GLOBAL-FREE-VARS contains those ;;; variables which are bound at the "top-level". (define GLOBAL-FREE-VARS '()) (define LEXICAL-FREE-VARS '()) (define LEXICAL-BOUND-VARS '()) ;;; Information relating to the current lambda expression is kept in the ;;; following variables. CURRENT-LAMBDA-ID is the identifier for the current ;;; lambda expression. (define CURRENT-LAMBDA-ID 'top-level) ;;; Alpha-conversion requires the generation of unique names. The sequence ;;; number which is used is kept in MAKE-ALPHA-SEQ. (define MAKE-ALPHA-SEQ 0) ;;; Source processing starts with the following function which is entered with ;;; a generator function for the source. It will return a list of forms which ;;; is the result of the first pass. (define (EXPAND-FORMS) (let ((results '())) (do ((exp (read-text) (read-text))) ((eof-object? exp) (set! results (reverse results))) (set! lexical-free-vars '()) (set! current-lambda-id 'top-level) (set! exp (exp-form exp exp-form)) (if exp (set! results (cons exp results)))) (for-each (lambda (var-alpha) (let ((var (car var-alpha)) (alpha (cadr var-alpha))) (if (and (eq? (id-use alpha) 'global) (not (id-module alpha))) (begin (set! current-define-name (id-undefref alpha)) (report-warning "Variable assumed to be TOP-LEVEL:" var) (set-id-use! alpha 'top-level) (set-id-module! alpha 'top-level) (set-id-vname! alpha (string-append (hex28 "" (lchexname var)) "_v")) (set! quote-constants (cons (list var alpha) quote-constants)))))) global-free-vars) results)) ;;; The expressions are recursively expanded by the following function which ;;; is called with the expression and the expansion function. The expansion ;;; process is similar to macro expansion, but it does the alpha-conversion ;;; using the functions stored under the property EXPAND. (define (EXP-FORM exp exp-func) (cond ((symbol? exp) (bound exp)) ((or (number? exp) (string? exp) (char? exp) (member exp '(#t #f))) (exp-func (list 'quote exp) exp-func)) ((islist exp 1) (let ((func (if (symbol? (car exp)) (get (car exp) 'expand) '()))) (apply (if func func call-exp) (list exp exp-func)))) (else (expand-error "" exp)))) ;;; A similar function is used to expand a list of functions. (define (EXP-FORM-LIST exp-list func) (if (islist exp-list 0) (map (lambda (exp) (func exp func)) exp-list) (expand-error 'expression-list exp-list))) ;;; During the alpha-conversion phase, all variables will be replaced with ;;; unique variables. Information about each variable will be saved as ;;; properties of the alpha-converted variable. The items saved are: ;;; ;;; PRINTNAME: original program variable name. ;;; VNAME: C name to access the item as a variable. ;;; CNAME: C name to access the item as a procedure. ;;; MODULE: module name containing the item. ;;; USE: tag indicating what the variable signifies. The possible ;;; tags are: LABEL, LAMBDA, LEXICAL, CONSTANT, GLOBAL, TOP-LEVEL, ;;; TEMPORARY, CLOSUREP, and MACRO. ;;; TYPE: data type which is either false indicating a TSCP or the ;;; appropriate C datatype. ;;; DISPLAY: boolean that indicates that the variable is be allocated in a ;;; display cell. ;;; BOUNDID: id of the lambda expression where this variable is bound. ;;; LAMBDA: id of the lambda expression which is this var's value. ;;; EXTERNAL: indicates that variable is external to this compile and is ;;; referenced. ;;; DEFINED: indicates that variable is defined by a top-level define in ;;; this module. ;;; VALUE: value for identifiers which are constants. ;;; SET!: boolean indicating that the variable has been SET!. ;;; REFS: counter for # of times a lambda bound variable is referenced. ;;; CALLS: counter for # of times a lambda bound variable is called as a ;;; function. ;;; ALIAS: label alias (see emit-lap). ;;; GOTOS: counter for # of branches to a label. ;;; UNDEFREF current-define-name for first use when undefined. (define (ID-PRINTNAME id) (id-printname id)) (define (SET-ID-PRINTNAME! id name) (set-id-printname! id name)) (define (ID-VNAME id) (id-vname id)) (define (SET-ID-VNAME! id name) (set-id-vname! id name)) (define (ID-CNAME id) (id-cname id)) (define (SET-ID-CNAME! id name) (set-id-cname! id name)) (define (ID-MODULE id) (id-module id)) (define (SET-ID-MODULE! id name) (set-id-module! id name)) (define (ID-USE id) (id-use id)) (define (SET-ID-USE! id tag) (set-id-use! id tag)) (define (ID-TYPE id) (id-type id)) (define (SET-ID-TYPE! id tag) (set-id-type! id tag)) (define (ID-DISPLAY id) (id-display id)) (define (SET-ID-DISPLAY! id flag) (set-id-display! id flag)) (define (ID-BOUNDID id) (id-boundid id)) (define (SET-ID-BOUNDID id value)(set-id-boundid id value)) (define (ID-LAMBDA id) (id-lambda id)) (define (SET-ID-LAMBDA! id lambda-id) (set-id-lambda! id lambda-id)) (define (ID-EXTERNAL id) (id-external id)) (define (SET-ID-EXTERNAL! id flag) (set-id-external! id flag)) (define (ID-DEFINED id) (id-defined id)) (define (SET-ID-DEFINED! id flag) (set-id-defined! id flag)) (define (ID-VALUE id) (id-value id)) (define (SET-ID-VALUE! id x) (set-id-value! id x)) (define (ID-SET! id) (id-set! id)) (define (SET-ID-SET!! id flag) (set-id-set!! id flag)) (define (ID-REFS id) (id-refs id)) (define (SET-ID-REFS! id cnt) (set-id-refs! id cnt)) (define (ID-CALLS id) (id-calls id)) (define (SET-ID-CALLS! id cnt) (set-id-calls! id cnt)) (define (ID-ALIAS id) (id-alias id)) (define (SET-ID-ALIAS! id label) (set-id-alias! id label)) (define (ID-GOTOS id) (id-gotos id)) (define (SET-ID-GOTOS! id cnt) (set-id-gotos! id cnt)) (define (ID-UNDEFREF id) (id-undefref id)) (define (SET-ID-UNDEFREF! id var) (set-id-undefref! id var)) ;;; Variables which represent globally defined items will have their property ;;; GLOBAL set to their alphatized variable. This allows rapid global lookup. (define (ID-GLOBAL id) (id-global id)) (define (SET-ID-GLOBAL! id alpha) (set-id-global! id alpha)) ;;; Names are generated for externally visible variables by the following ;;; function. (define (ASSIGN-KNOWN-NAME var) (let* ((use (id-use var)) (module (id-module var)) (name (lchexname (id-printname var)))) (cond ((memq use '(lexical closurep)) (let ((lcvar (lchexname var))) (cond ((id-lambda var) (set-id-cname! var (string-append module-name "_" lcvar)) (set-id-vname! var (string-append lcvar "_v"))) (else (set-id-vname! var lcvar))))) ((and (eq? use 'global) (id-type var))) (else (set-id-vname! var (string-append (hex28 module name) "_v")) (set-id-cname! var (string-append (hex28 module name))))))) ;;; This function is called to establish the linkage between a variable and a ;;; lambda expression. (define (NAME-A-LAMBDA name exp) (set! exp ($lambda-id exp)) (if exp (begin (set-id-lambda! name exp) (set-lambda-name! exp name)))) ;;; Often one wants the VNAME or CNAME of an arbitrary expression. These ;;; functions will produce it. (define (VNAME exp) (if (symbol? exp) (begin (if (and (eq? (id-use exp) 'lambda) (lambda-name exp)) (set! exp (lambda-name exp))) (id-vname exp)) exp)) (define (CNAME exp) (if (symbol? exp) (begin (if (and (eq? (id-use exp) 'lambda) (lambda-name exp)) (set! exp (lambda-name exp))) (id-cname exp)) exp)) ;;; This function is called to convert a name into its "lower case hex" format. (define (LCHEXNAME name) (if (symbol? name) (set! name (symbol->string name))) (do ((c '()) (i 0 (+ 1 i)) (new (list 1))) ((= i (string-length name)) (list->string (cdr new))) (set! c (string-ref name i)) (cond ((char=? c #\_) (set-cdr! (last-pair new) (list #\_ #\_))) ((and (char>=? c #\A) (char<=? c #\Z)) (set-cdr! (last-pair new) (list (integer->char (+ (char->integer c) 32))))) ((or (and (char>=? c #\a) (char<=? c #\z)) (and (char>=? c #\0) (char<=? c #\9) (> i 0))) (set-cdr! (last-pair new) (list c))) (else (set-cdr! (last-pair new) (cons #\_ (char->dl c 16 2))))))) ;;; This function is one of those that you hope you never have to write, but ;;; inevitably you must. It exists because vcc will only recognize the first ;;; 31 characters of a variable name. In order to force the first 31 ;;; characters of a generated name to be unique, it is necessary that the ;;; lchexnames of the module and variable be less than or equal to 28 ;;; characters. If it doesn't fit, then a name is generated consisting of ;;; the last 9 characters of the module name, the last 10 characters of the ;;; name, and the hex crc-32 of the module and name. (define (HEX28 module name) (if (<= (+ (string-length module) (string-length name)) 28) (if (equal? module "") name (string-append module "_" name)) (let ((value (format '() "~a_~a_~a" (substring module (max 0 (- (string-length module) 9)) (string-length module)) (substring name (max 0 (- (string-length name) 10)) (string-length name)) (crc-32x2 (string->list (string-append module name)) 0 0)))) (if (char-numeric? (string-ref value 0)) (string-set! value 0 #\_)) value))) ;;; Compute a crc-32 for a list of characters using a per character table and ;;; return a string with the hex value. The crc is computed in two 16-bit ;;; integers to avoid having to use floating point numbers. (define (CRC-32x2 chars crc-left crc-right) (if (null? chars) (let loop ((cl '()) (left crc-left) (right crc-right)) (if (and (zero? left) (zero? right)) (if (null? cl) "0" (list->string cl)) (loop (cons (string-ref "0123456789abcdef" (remainder right 16)) cl) (quotient left 16) (+ (bit-lsh (remainder left 16) 12) (quotient right 16))))) (let ((char (char->integer (car chars)))) (crc-32x2 (cdr chars) (bit-xor (bit-rsh crc-left 8) (vector-ref t-left char) (vector-ref t-left (remainder crc-right 256))) (bit-xor (bit-or (bit-lsh (bit-and crc-left 255) 8) (bit-rsh crc-right 8)) (vector-ref t-right char) (vector-ref t-right (remainder crc-right 256))))))) (define T-LEFT '#( #x0000 #x7707 #xEE0E #x9909 #x076D #x706A #xE963 #x9E64 #x0EDB #x79DC #xE0D5 #x97D2 #x09B6 #x7EB1 #xE7B8 #x90BF #x1DB7 #x6AB0 #xF3B9 #x84BE #x1ADA #x6DDD #xF4D4 #x83D3 #x136C #x646B #xFD62 #x8A65 #x1401 #x6306 #xFA0F #x8D08 #x3B6E #x4C69 #xD560 #xA267 #x3C03 #x4B04 #xD20D #xA50A #x35B5 #x42B2 #xDBBB #xACBC #x32D8 #x45DF #xDCD6 #xABD1 #x26D9 #x51DE #xC8D7 #xBFD0 #x21B4 #x56B3 #xCFBA #xB8BD #x2802 #x5F05 #xC60C #xB10B #x2F6F #x5868 #xC161 #xB666 #x76DC #x01DB #x98D2 #xEFD5 #x71B1 #x06B6 #x9FBF #xE8B8 #x7807 #x0F00 #x9609 #xE10E #x7F6A #x086D #x9164 #xE663 #x6B6B #x1C6C #x8565 #xF262 #x6C06 #x1B01 #x8208 #xF50F #x65B0 #x12B7 #x8BBE #xFCB9 #x62DD #x15DA #x8CD3 #xFBD4 #x4DB2 #x3AB5 #xA3BC #xD4BB #x4ADF #x3DD8 #xA4D1 #xD3D6 #x4369 #x346E #xAD67 #xDA60 #x4404 #x3303 #xAA0A #xDD0D #x5005 #x2702 #xBE0B #xC90C #x5768 #x206F #xB966 #xCE61 #x5EDE #x29D9 #xB0D0 #xC7D7 #x59B3 #x2EB4 #xB7BD #xC0BA #xEDB8 #x9ABF #x03B6 #x74B1 #xEAD5 #x9DD2 #x04DB #x73DC #xE363 #x9464 #x0D6D #x7A6A #xE40E #x9309 #x0A00 #x7D07 #xF00F #x8708 #x1E01 #x6906 #xF762 #x8065 #x196C #x6E6B #xFED4 #x89D3 #x10DA #x67DD #xF9B9 #x8EBE #x17B7 #x60B0 #xD6D6 #xA1D1 #x38D8 #x4FDF #xD1BB #xA6BC #x3FB5 #x48B2 #xD80D #xAF0A #x3603 #x4104 #xDF60 #xA867 #x316E #x4669 #xCB61 #xBC66 #x256F #x5268 #xCC0C #xBB0B #x2202 #x5505 #xC5BA #xB2BD #x2BB4 #x5CB3 #xC2D7 #xB5D0 #x2CD9 #x5BDE #x9B64 #xEC63 #x756A #x026D #x9C09 #xEB0E #x7207 #x0500 #x95BF #xE2B8 #x7BB1 #x0CB6 #x92D2 #xE5D5 #x7CDC #x0BDB #x86D3 #xF1D4 #x68DD #x1FDA #x81BE #xF6B9 #x6FB0 #x18B7 #x8808 #xFF0F #x6606 #x1101 #x8F65 #xF862 #x616B #x166C #xA00A #xD70D #x4E04 #x3903 #xA767 #xD060 #x4969 #x3E6E #xAED1 #xD9D6 #x40DF #x37D8 #xA9BC #xDEBB #x47B2 #x30B5 #xBDBD #xCABA #x53B3 #x24B4 #xBAD0 #xCDD7 #x54DE #x23D9 #xB366 #xC461 #x5D68 #x2A6F #xB40B #xC30C #x5A05 #x2D02 )) (define T-RIGHT '#( #x0000 #x3096 #x612C #x51BA #xC419 #xF48F #xA535 #x95A3 #x8832 #xB8A4 #xE91E #xD988 #x4C2B #x7CBD #x2D07 #x1D91 #x1064 #x20F2 #x7148 #x41DE #xD47D #xE4EB #xB551 #x85C7 #x9856 #xA8C0 #xF97A #xC9EC #x5C4F #x6CD9 #x3D63 #x0DF5 #x20C8 #x105E #x41E4 #x7172 #xE4D1 #xD447 #x85FD #xB56B #xA8FA #x986C #xC9D6 #xF940 #x6CE3 #x5C75 #x0DCF #x3D59 #x30AC #x003A #x5180 #x6116 #xF4B5 #xC423 #x9599 #xA50F #xB89E #x8808 #xD9B2 #xE924 #x7C87 #x4C11 #x1DAB #x2D3D #x4190 #x7106 #x20BC #x102A #x8589 #xB51F #xE4A5 #xD433 #xC9A2 #xF934 #xA88E #x9818 #x0DBB #x3D2D #x6C97 #x5C01 #x51F4 #x6162 #x30D8 #x004E #x95ED #xA57B #xF4C1 #xC457 #xD9C6 #xE950 #xB8EA #x887C #x1DDF #x2D49 #x7CF3 #x4C65 #x6158 #x51CE #x0074 #x30E2 #xA541 #x95D7 #xC46D #xF4FB #xE96A #xD9FC #x8846 #xB8D0 #x2D73 #x1DE5 #x4C5F #x7CC9 #x713C #x41AA #x1010 #x2086 #xB525 #x85B3 #xD409 #xE49F #xF90E #xC998 #x9822 #xA8B4 #x3D17 #x0D81 #x5C3B #x6CAD #x8320 #xB3B6 #xE20C #xD29A #x4739 #x77AF #x2615 #x1683 #x0B12 #x3B84 #x6A3E #x5AA8 #xCF0B #xFF9D #xAE27 #x9EB1 #x9344 #xA3D2 #xF268 #xC2FE #x575D #x67CB #x3671 #x06E7 #x1B76 #x2BE0 #x7A5A #x4ACC #xDF6F #xEFF9 #xBE43 #x8ED5 #xA3E8 #x937E #xC2C4 #xF252 #x67F1 #x5767 #x06DD #x364B #x2BDA #x1B4C #x4AF6 #x7A60 #xEFC3 #xDF55 #x8EEF #xBE79 #xB38C #x831A #xD2A0 #xE236 #x7795 #x4703 #x16B9 #x262F #x3BBE #x0B28 #x5A92 #x6A04 #xFFA7 #xCF31 #x9E8B #xAE1D #xC2B0 #xF226 #xA39C #x930A #x06A9 #x363F #x6785 #x5713 #x4A82 #x7A14 #x2BAE #x1B38 #x8E9B #xBE0D #xEFB7 #xDF21 #xD2D4 #xE242 #xB3F8 #x836E #x16CD #x265B #x77E1 #x4777 #x5AE6 #x6A70 #x3BCA #x0B5C #x9EFF #xAE69 #xFFD3 #xCF45 #xE278 #xD2EE #x8354 #xB3C2 #x2661 #x16F7 #x474D #x77DB #x6A4A #x5ADC #x0B66 #x3BF0 #xAE53 #x9EC5 #xCF7F #xFFE9 #xF21C #xC28A #x9330 #xA3A6 #x3605 #x0693 #x5729 #x67BF #x7A2E #x4AB8 #x1B02 #x2B94 #xBE37 #x8EA1 #xDF1B #xEF8D )) ;;; This function converts the character "c" into numeric string of length ;;; "len" in base "base". (define (CHAR->DL c base len) (set! c (char->integer c)) (do ((dl '())) ((zero? len) dl) (set! dl (cons (string-ref "0123456789abcdef" (remainder c base)) dl)) (set! c (quotient c base)) (set! len (- len 1)))) ;;; Variables are initially bound and their alpha-converted value is returned ;;; by the following function. It takes the variable name and an optional ;;; list of properties and values. It returns the alphabetized name. (define (NEWV var . pl) (let* ((oldalpha (id-global var)) (use (cadr (memq 'use pl))) (alpha '())) (if (and oldalpha (memq use '(global macro lexical))) (begin (if (and (id-module oldalpha) (or (eq? (id-use oldalpha) 'macro) (eq? use 'global))) (if (id-defined oldalpha) (report-error "Duplicately defined symbol:" var) (if (not (or (eq? (id-module oldalpha) 'top-level) (equal? (id-module oldalpha) module-name))) (report-warning "Duplicately defined symbol:" var)))) (if (eq? use 'global) (begin (set! alpha oldalpha) (set-id-lambda! alpha '()) (set-id-module! alpha '()) (set-id-vname! alpha '()) (set-id-cname! alpha '())) (set! alpha (make-alpha var)))) (set! alpha (make-alpha var))) (set-id-printname! alpha var) (do ((pl pl (cddr pl))) ((null? pl) (case (id-use alpha) ((global macro top-level) (set-id-global! var alpha) (if (not (eq? alpha oldalpha)) (set! global-free-vars (cons (list var alpha) global-free-vars)))) ((lexical) (set! lexical-bound-vars (cons (list var alpha) lexical-bound-vars))) ((label constant lambda temporary closurep) (let ((dsa (downshift alpha))) (set-id-printname! alpha alpha) (if (eq? (id-use alpha) 'lambda) (set-id-cname! alpha (hex28 module-name dsa)) (set-id-cname! alpha (hex28 "" dsa))) (set-id-vname! alpha (hex28 "" dsa))))) alpha) (put alpha (car pl) (cadr pl))))) ;;; All variable names will be alpha-converted by taking the first character ;;; of their name and following it with an id number. (define (MAKE-ALPHA var) (let* ((c (string-ref (symbol->string var) 0)) (alpha (string->symbol (format '() "~A~A" c make-alpha-seq)))) (set! make-alpha-seq (+ make-alpha-seq 1)) (if (id-printname alpha) (make-alpha var) alpha))) ;;; The following function looks up a variable in the current bindings. If it ;;; is not found, then it will be added to GLOBAL-FREE-VARS. TOP-LEVEL ;;; variables which are referenced will have a symbol pointer added to the ;;; constant list so that their value can be looked up. (define (BOUND var) (let* ((varalist (assq var lexical-bound-vars)) (varlex (or varalist (assq var lexical-free-vars))) (varglob (or varlex (id-global var)))) (cond (varalist (cadr varalist)) (varlex (set! varlex (cadr varlex)) varlex) (varglob (if (and (eq? (id-use varglob) 'top-level) (not (find-quote-constant var 'top-level))) (set! quote-constants (cons (list var varglob) quote-constants))) varglob) (else (newv var 'use 'global 'undefref current-define-name))))) ;;; Syntax errors are reported by the following function which will return ;;; (begin #t) as its value. (define (EXPAND-ERROR form exp) (report-error "Illegal" form "syntax:" exp) '(begin #t)) scheme2c-2012.10.14/scsc/expform.sch000066400000000000000000000047421203736146400167220ustar00rootroot00000000000000;;; External and in-line declarations from expform.sc (define-in-line (ID-PRINTNAME id) (get id 'printname)) (define-in-line (SET-ID-PRINTNAME! id name) (put id 'printname name)) (define-in-line (ID-VNAME id) (get id 'vname)) (define-in-line (SET-ID-VNAME! id name) (put id 'vname name)) (define-in-line (ID-CNAME id) (get id 'cname)) (define-in-line (SET-ID-CNAME! id name) (put id 'cname name)) (define-in-line (ID-MODULE id) (get id 'module)) (define-in-line (SET-ID-MODULE! id name) (put id 'module name)) (define-in-line (ID-USE id) (get id 'use)) (define-in-line (SET-ID-USE! id tag) (put id 'use tag)) (define-in-line (ID-TYPE id) (get id 'type)) (define-in-line (SET-ID-TYPE! id tag) (put id 'type tag)) (define-in-line (ID-HEAP id) (get id 'heap)) (define-in-line (SET-ID-HEAP! id flag) (put id 'heap flag)) (define-in-line (ID-DISPLAY id) (get id 'display)) (define-in-line (SET-ID-DISPLAY! id flag) (put id 'display flag)) (define-in-line (ID-BOUNDID id) (get id 'boundid)) (define-in-line (SET-ID-BOUNDID id value) (put id 'boundid value)) (define-in-line (ID-LAMBDA id) (get id 'lambda)) (define-in-line (SET-ID-LAMBDA! id lambda-id) (put id 'lambda lambda-id)) (define-in-line (ID-EXTERNAL id) (get id 'external)) (define-in-line (SET-ID-EXTERNAL! id flag) (put id 'external flag)) (define-in-line (ID-DEFINED id) (get id 'defined)) (define-in-line (SET-ID-DEFINED! id flag) (put id 'defined flag)) (define-in-line (ID-VALUE id) (get id 'value)) (define-in-line (SET-ID-VALUE! id x) (put id 'value x)) (define-in-line (ID-SET! id) (get id 'set!)) (define-in-line (SET-ID-SET!! id flag) (put id 'set! flag)) (define-in-line (ID-REFS id) (get id 'refs)) (define-in-line (SET-ID-REFS! id cnt) (put id 'refs cnt)) (define-in-line (ID-CALLS id) (get id 'calls)) (define-in-line (SET-ID-CALLS! id cnt) (put id 'calls cnt)) (define-in-line (ID-ALIAS id) (get id 'alias)) (define-in-line (SET-ID-ALIAS! id label) (put id 'alias label)) (define-in-line (ID-GOTOS id) (get id 'gotos)) (define-in-line (SET-ID-GOTOS! id cnt) (put id 'gotos cnt)) (define-in-line (ID-UNDEFREF id) (get id 'undefref)) (define-in-line (SET-ID-UNDEFREF! id var) (put id 'undefref var)) (define-in-line (ID-GLOBAL id) (get id 'global)) (define-in-line (SET-ID-GLOBAL! id alpha) (put id 'global alpha)) (define-external (VNAME exp) expform) (define-external (CNAME exp) expform) (define-external (LCHEXNAME exp) expform) (define-external (NEWV var . pl) expform) (define-external (BOUND var) expform) scheme2c-2012.10.14/scsc/gencode.c000066400000000000000000002662731203736146400163240ustar00rootroot00000000000000 /* SCHEME->C */ #include void gencode__init(); DEFSTATICTSCP( current_2ddefine_2dname_v ); DEFSTATICTSCP( global_2dlap_2dcode_v ); DEFSTATICTSCP( c_2dinclude_2dfile_v ); DEFSTATICTSCP( main_2dprogram_2dname_v ); DEFSTATICTSCP( heap_2dsize_v ); DEFSTATICTSCP( module_2dname_v ); DEFSTATICTSCP( scc_2dversion_v ); DEFSTATICTSCP( report_2derror_v ); DEFSTATICTSCP( _24define_2dgenc_v ); DEFSTATICTSCP( _24if_2dgenc_v ); DEFSTATICTSCP( _24lambda_2dgenc_v ); DEFSTATICTSCP( _24set_2dgenc_v ); DEFSTATICTSCP( _24call_2dgenc_v ); DEFSTATICTSCP( symbol_2dgenc_v ); DEFSTATICTSCP( with_2dmodules_v ); DEFSTATICTSCP( quote_2dconstants_v ); DEFCSTRING( t3062, "TRUEVALUE" ); DEFSTATICTSCP( c2981 ); DEFCSTRING( t3063, "EMPTYLIST" ); DEFSTATICTSCP( c2980 ); DEFCSTRING( t3064, "FALSEVALUE" ); DEFSTATICTSCP( c2979 ); DEFCSTRING( t3065, "EMPTYSTRING" ); DEFSTATICTSCP( c2978 ); DEFCSTRING( t3066, "EMPTYVECTOR" ); DEFSTATICTSCP( c2977 ); DEFSTATICTSCP( c2976 ); DEFSTATICTSCP( c2916 ); DEFSTATICTSCP( c2747 ); DEFSTATICTSCP( c2745 ); DEFCSTRING( t3067, " )" ); DEFSTATICTSCP( c2741 ); DEFCSTRING( t3068, "Argument not a CHAR: ~s" ); DEFSTATICTSCP( c2738 ); DEFSTATICTSCP( c2737 ); DEFCSTRING( t3069, "_TSCP( " ); DEFSTATICTSCP( c2720 ); DEFSTATICTSCP( c2718 ); DEFCSTRING( t3070, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c2713 ); DEFSTATICTSCP( c2712 ); DEFSTATICTSCP( c2707 ); DEFSTATICTSCP( c2706 ); DEFSTATICTSCP( c2703 ); DEFSTATICTSCP( c2696 ); DEFSTATICTSCP( c2695 ); DEFCSTRING( t3071, "EMIT-CONSTANT compile error:" ); DEFSTATICTSCP( c2693 ); DEFSTATICTSCP( c2660 ); DEFSTATICTSCP( c2659 ); DEFSTATICTSCP( c2622 ); DEFSTATICTSCP( t3072 ); DEFSTATICTSCP( c2621 ); DEFCSTRING( t3074, "static void init_constants()" ); DEFSTATICTSCP( t3073 ); DEFSTATICTSCP( t3075 ); DEFCSTRING( t3076, "}" ); DEFSTATICTSCP( c2615 ); DEFSTATICTSCP( c2614 ); DEFSTATICTSCP( c2590 ); DEFCSTRING( t3078, " char *compiler_version;" ); DEFSTATICTSCP( t3077 ); DEFSTATICTSCP( c2589 ); DEFCSTRING( t3080, "static void init_modules( compiler_version )" ); DEFSTATICTSCP( t3079 ); DEFCSTRING( t3081, "__init();" ); DEFSTATICTSCP( c2587 ); DEFSTATICTSCP( c2560 ); DEFSTATICTSCP( c2534 ); DEFSTATICTSCP( c2500 ); DEFCSTRING( t3082, "..." ); DEFSTATICTSCP( c2497 ); DEFCSTRING( t3083, "Index is not in bounds: ~s" ); DEFSTATICTSCP( c2479 ); DEFCSTRING( t3084, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2475 ); DEFCSTRING( t3085, "Argument is not a VECTOR: ~s" ); DEFSTATICTSCP( c2472 ); DEFSTATICTSCP( c2471 ); DEFSTATICTSCP( c2462 ); DEFCSTRING( t3087, "double" ); DEFSTATICTSCP( t3086 ); DEFSTATICTSCP( t3088 ); DEFCSTRING( t3090, "float" ); DEFSTATICTSCP( t3089 ); DEFSTATICTSCP( t3091 ); DEFCSTRING( t3093, "long unsigned" ); DEFSTATICTSCP( t3092 ); DEFSTATICTSCP( t3094 ); DEFCSTRING( t3096, "short unsigned" ); DEFSTATICTSCP( t3095 ); DEFSTATICTSCP( t3097 ); DEFCSTRING( t3099, "unsigned" ); DEFSTATICTSCP( t3098 ); DEFSTATICTSCP( t3100 ); DEFCSTRING( t3102, "long int" ); DEFSTATICTSCP( t3101 ); DEFSTATICTSCP( t3103 ); DEFCSTRING( t3105, "short int" ); DEFSTATICTSCP( t3104 ); DEFSTATICTSCP( t3106 ); DEFCSTRING( t3108, "int" ); DEFSTATICTSCP( t3107 ); DEFSTATICTSCP( t3109 ); DEFCSTRING( t3111, "char" ); DEFSTATICTSCP( t3110 ); DEFSTATICTSCP( t3112 ); DEFCSTRING( t3114, "TSCP" ); DEFSTATICTSCP( t3113 ); DEFCSTRING( t3116, "void*" ); DEFSTATICTSCP( t3115 ); DEFSTATICTSCP( t3117 ); DEFCSTRING( t3119, "void*" ); DEFSTATICTSCP( t3118 ); DEFSTATICTSCP( t3120 ); DEFCSTRING( t3122, "void" ); DEFSTATICTSCP( t3121 ); DEFSTATICTSCP( t3123 ); DEFCSTRING( t3124, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2447 ); DEFSTATICTSCP( c2446 ); DEFSTATICTSCP( c2409 ); DEFSTATICTSCP( t3125 ); DEFSTATICTSCP( t3126 ); DEFSTATICTSCP( t3127 ); DEFSTATICTSCP( t3128 ); DEFSTATICTSCP( t3129 ); DEFSTATICTSCP( t3130 ); DEFSTATICTSCP( t3131 ); DEFSTATICTSCP( t3132 ); DEFSTATICTSCP( t3133 ); DEFSTATICTSCP( t3134 ); DEFSTATICTSCP( t3135 ); DEFSTATICTSCP( t3136 ); DEFSTATICTSCP( t3137 ); DEFSTATICTSCP( t3138 ); DEFSTATICTSCP( t3139 ); DEFSTATICTSCP( t3140 ); DEFSTATICTSCP( t3141 ); DEFSTATICTSCP( t3142 ); DEFSTATICTSCP( t3143 ); DEFSTATICTSCP( t3144 ); DEFSTATICTSCP( t3145 ); DEFSTATICTSCP( t3146 ); DEFSTATICTSCP( t3147 ); DEFSTATICTSCP( t3148 ); DEFSTATICTSCP( t3149 ); DEFSTATICTSCP( t3150 ); DEFSTATICTSCP( t3151 ); DEFSTATICTSCP( c2403 ); DEFSTATICTSCP( t3152 ); DEFSTATICTSCP( t3153 ); DEFSTATICTSCP( t3154 ); DEFSTATICTSCP( t3155 ); DEFSTATICTSCP( t3156 ); DEFSTATICTSCP( t3157 ); DEFSTATICTSCP( t3158 ); DEFSTATICTSCP( t3159 ); DEFSTATICTSCP( t3160 ); DEFSTATICTSCP( t3161 ); DEFSTATICTSCP( t3162 ); DEFSTATICTSCP( t3163 ); DEFSTATICTSCP( t3164 ); DEFSTATICTSCP( c2385 ); DEFSTATICTSCP( t3165 ); DEFSTATICTSCP( t3166 ); DEFSTATICTSCP( t3167 ); DEFSTATICTSCP( t3168 ); DEFSTATICTSCP( t3169 ); DEFSTATICTSCP( t3170 ); DEFSTATICTSCP( t3171 ); DEFSTATICTSCP( t3172 ); DEFSTATICTSCP( t3173 ); DEFSTATICTSCP( t3174 ); DEFSTATICTSCP( t3175 ); DEFSTATICTSCP( t3176 ); DEFSTATICTSCP( c2374 ); DEFSTATICTSCP( c2370 ); DEFCSTRING( t3178, "sc" ); DEFSTATICTSCP( t3177 ); DEFSTATICTSCP( c2362 ); DEFSTATICTSCP( c2356 ); DEFSTATICTSCP( c2344 ); DEFSTATICTSCP( c2339 ); DEFSTATICTSCP( c2336 ); DEFSTATICTSCP( c2324 ); DEFSTATICTSCP( c2309 ); DEFSTATICTSCP( c2301 ); DEFCSTRING( t3179, "SYMBOL does not have a value cell" ); DEFSTATICTSCP( c2298 ); DEFSTATICTSCP( c2295 ); DEFSTATICTSCP( c2280 ); DEFSTATICTSCP( c2277 ); DEFCSTRING( t3180, "DISPLAY" ); DEFSTATICTSCP( c2276 ); DEFSTATICTSCP( c2275 ); DEFSTATICTSCP( c2270 ); DEFCSTRING( t3181, "Variable is not bound" ); DEFSTATICTSCP( c2269 ); DEFSTATICTSCP( c2251 ); DEFSTATICTSCP( c2245 ); DEFSTATICTSCP( c2244 ); DEFSTATICTSCP( c2239 ); DEFSTATICTSCP( c2229 ); DEFSTATICTSCP( c2228 ); DEFSTATICTSCP( c2227 ); DEFSTATICTSCP( c2226 ); DEFCSTRING( t3182, "Illegal use of LAP" ); DEFSTATICTSCP( c2217 ); DEFCSTRING( t3183, "GENERATE-CODE compiler error" ); DEFSTATICTSCP( c2216 ); DEFSTATICTSCP( c2215 ); DEFSTATICTSCP( c2207 ); DEFSTATICTSCP( c2199 ); DEFSTATICTSCP( c2191 ); DEFSTATICTSCP( c2183 ); DEFSTATICTSCP( c2175 ); DEFCSTRING( t3184, "main" ); DEFSTATICTSCP( c2161 ); DEFCSTRING( t3185, "__init" ); DEFSTATICTSCP( c2160 ); DEFCSTRING( t3186, "Compiler error - display index is not 0" ); DEFSTATICTSCP( c2158 ); DEFSTATICTSCP( c2148 ); DEFCSTRING( t3188, "}" ); DEFSTATICTSCP( t3187 ); DEFSTATICTSCP( c2147 ); DEFSTATICTSCP( t3189 ); DEFSTATICTSCP( c2144 ); DEFCSTRING( t3191, "return 0;" ); DEFSTATICTSCP( t3190 ); DEFSTATICTSCP( c2143 ); DEFCSTRING( t3193, "SCHEMEEXIT();" ); DEFSTATICTSCP( t3192 ); DEFCSTRING( t3194, "( CLARGUMENTS( argc, argv ) );" ); DEFSTATICTSCP( c2142 ); DEFCSTRING( t3195, "Main procedure is not defined" ); DEFSTATICTSCP( c2141 ); DEFCSTRING( t3196, "__init(){}" ); DEFSTATICTSCP( c2139 ); DEFSTATICTSCP( c2136 ); DEFCSTRING( t3198, "void" ); DEFSTATICTSCP( t3197 ); DEFSTATICTSCP( t3199 ); DEFSTATICTSCP( c2135 ); DEFSTATICTSCP( c2110 ); DEFCSTRING( t3201, "sc_segv__handlers();" ); DEFSTATICTSCP( t3200 ); DEFCSTRING( t3202, " );" ); DEFSTATICTSCP( c2109 ); DEFCSTRING( t3203, ")" ); DEFSTATICTSCP( c2108 ); DEFCSTRING( t3204, " SCHEME->C COMPILER " ); DEFSTATICTSCP( c2106 ); DEFCSTRING( t3205, "(" ); DEFSTATICTSCP( c2104 ); DEFSTATICTSCP( c2103 ); DEFCSTRING( t3206, "init_modules( " ); DEFSTATICTSCP( c2102 ); DEFSTATICTSCP( c2100 ); DEFCSTRING( t3208, "init_constants();" ); DEFSTATICTSCP( t3207 ); DEFSTATICTSCP( c2099 ); DEFCSTRING( t3209, "argv" ); DEFSTATICTSCP( c2096 ); DEFCSTRING( t3210, "argc" ); DEFSTATICTSCP( c2095 ); DEFSTATICTSCP( c2093 ); DEFSTATICTSCP( c2092 ); DEFCSTRING( t3212, "init = 1;" ); DEFSTATICTSCP( t3211 ); DEFSTATICTSCP( c2091 ); DEFCSTRING( t3214, "if (init) return 1;" ); DEFSTATICTSCP( t3213 ); DEFSTATICTSCP( c2090 ); DEFCSTRING( t3216, "if (init) return;" ); DEFSTATICTSCP( t3215 ); DEFSTATICTSCP( c2089 ); DEFCSTRING( t3218, "static int init = 0;" ); DEFSTATICTSCP( t3217 ); DEFSTATICTSCP( c2088 ); DEFSTATICTSCP( c2087 ); DEFSTATICTSCP( c2086 ); DEFCSTRING( t3220, "{" ); DEFSTATICTSCP( t3219 ); DEFSTATICTSCP( c2085 ); DEFCSTRING( t3222, "int main( int argc, char **argv )" ); DEFSTATICTSCP( t3221 ); DEFCSTRING( t3223, "()" ); DEFSTATICTSCP( c2084 ); DEFCSTRING( t3224, "void " ); DEFSTATICTSCP( c2083 ); DEFCSTRING( t3225, "();" ); DEFSTATICTSCP( c2082 ); DEFCSTRING( t3226, "int " ); DEFSTATICTSCP( c2081 ); DEFCSTRING( t3227, "void " ); DEFSTATICTSCP( c2080 ); DEFSTATICTSCP( c2078 ); DEFCSTRING( t3228, "#include " ); DEFSTATICTSCP( c2074 ); DEFCSTRING( t3229, "/* SCHEME->C */" ); DEFSTATICTSCP( c2073 ); DEFSTATICTSCP( c2072 ); DEFSTATICTSCP( c2070 ); DEFSTATICTSCP( c2069 ); DEFSTATICTSCP( c2068 ); DEFSTATICTSCP( c2055 ); DEFSTATICTSCP( c2048 ); static void init_constants() { TSCP X1; current_2ddefine_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-D\ EFINE-NAME" ) ); CONSTANTEXP( ADR( current_2ddefine_2dname_v ) ); global_2dlap_2dcode_v = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL-LAP-CO\ DE" ) ); CONSTANTEXP( ADR( global_2dlap_2dcode_v ) ); c_2dinclude_2dfile_v = STRINGTOSYMBOL( CSTRING_TSCP( "C-INCLUDE-FILE\ " ) ); CONSTANTEXP( ADR( c_2dinclude_2dfile_v ) ); main_2dprogram_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "MAIN-PROGRA\ M-NAME" ) ); CONSTANTEXP( ADR( main_2dprogram_2dname_v ) ); heap_2dsize_v = STRINGTOSYMBOL( CSTRING_TSCP( "HEAP-SIZE" ) ); CONSTANTEXP( ADR( heap_2dsize_v ) ); module_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE-NAME" ) ); CONSTANTEXP( ADR( module_2dname_v ) ); scc_2dversion_v = STRINGTOSYMBOL( CSTRING_TSCP( "SCC-VERSION" ) ); CONSTANTEXP( ADR( scc_2dversion_v ) ); report_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-ERROR" ) ); CONSTANTEXP( ADR( report_2derror_v ) ); _24define_2dgenc_v = STRINGTOSYMBOL( CSTRING_TSCP( "$DEFINE-GENC" ) ); CONSTANTEXP( ADR( _24define_2dgenc_v ) ); _24if_2dgenc_v = STRINGTOSYMBOL( CSTRING_TSCP( "$IF-GENC" ) ); CONSTANTEXP( ADR( _24if_2dgenc_v ) ); _24lambda_2dgenc_v = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA-GENC" ) ); CONSTANTEXP( ADR( _24lambda_2dgenc_v ) ); _24set_2dgenc_v = STRINGTOSYMBOL( CSTRING_TSCP( "$SET-GENC" ) ); CONSTANTEXP( ADR( _24set_2dgenc_v ) ); _24call_2dgenc_v = STRINGTOSYMBOL( CSTRING_TSCP( "$CALL-GENC" ) ); CONSTANTEXP( ADR( _24call_2dgenc_v ) ); symbol_2dgenc_v = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL-GENC" ) ); CONSTANTEXP( ADR( symbol_2dgenc_v ) ); with_2dmodules_v = STRINGTOSYMBOL( CSTRING_TSCP( "WITH-MODULES" ) ); CONSTANTEXP( ADR( with_2dmodules_v ) ); quote_2dconstants_v = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE-CONSTANTS\ " ) ); CONSTANTEXP( ADR( quote_2dconstants_v ) ); c2981 = CSTRING_TSCP( t3062 ); CONSTANTEXP( ADR( c2981 ) ); c2980 = CSTRING_TSCP( t3063 ); CONSTANTEXP( ADR( c2980 ) ); c2979 = CSTRING_TSCP( t3064 ); CONSTANTEXP( ADR( c2979 ) ); c2978 = CSTRING_TSCP( t3065 ); CONSTANTEXP( ADR( c2978 ) ); c2977 = CSTRING_TSCP( t3066 ); CONSTANTEXP( ADR( c2977 ) ); c2976 = STRINGTOSYMBOL( CSTRING_TSCP( "EMIT-CONSTANT-KLUDGE" ) ); CONSTANTEXP( ADR( c2976 ) ); c2916 = STRINGTOSYMBOL( CSTRING_TSCP( "CONS" ) ); CONSTANTEXP( ADR( c2916 ) ); c2747 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUBLE_TSCP" ) ); CONSTANTEXP( ADR( c2747 ) ); c2745 = STRINGTOSYMBOL( CSTRING_TSCP( "VNAME" ) ); CONSTANTEXP( ADR( c2745 ) ); c2741 = CSTRING_TSCP( t3067 ); CONSTANTEXP( ADR( c2741 ) ); c2738 = CSTRING_TSCP( t3068 ); CONSTANTEXP( ADR( c2738 ) ); c2737 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR->INTEGER" ) ); CONSTANTEXP( ADR( c2737 ) ); c2720 = CSTRING_TSCP( t3069 ); CONSTANTEXP( ADR( c2720 ) ); c2718 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFCSTRING" ) ); CONSTANTEXP( ADR( c2718 ) ); c2713 = CSTRING_TSCP( t3070 ); CONSTANTEXP( ADR( c2713 ) ); c2712 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c2712 ) ); c2707 = STRINGTOSYMBOL( CSTRING_TSCP( "CSTRING_TSCP" ) ); CONSTANTEXP( ADR( c2707 ) ); c2706 = STRINGTOSYMBOL( CSTRING_TSCP( "STRINGTOSYMBOL" ) ); CONSTANTEXP( ADR( c2706 ) ); c2703 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFSTATICTSCP" ) ); CONSTANTEXP( ADR( c2703 ) ); c2696 = STRINGTOSYMBOL( CSTRING_TSCP( "LISTTOVECTOR" ) ); CONSTANTEXP( ADR( c2696 ) ); c2695 = STRINGTOSYMBOL( CSTRING_TSCP( "SET" ) ); CONSTANTEXP( ADR( c2695 ) ); c2693 = CSTRING_TSCP( t3071 ); CONSTANTEXP( ADR( c2693 ) ); c2660 = STRINGTOSYMBOL( CSTRING_TSCP( "ADR" ) ); CONSTANTEXP( ADR( c2660 ) ); c2659 = STRINGTOSYMBOL( CSTRING_TSCP( "CONSTANTEXP" ) ); CONSTANTEXP( ADR( c2659 ) ); c2622 = EMPTYLIST; t3072 = STRINGTOSYMBOL( CSTRING_TSCP( "LOCALS" ) ); c2622 = CONS( t3072, c2622 ); CONSTANTEXP( ADR( c2622 ) ); c2621 = EMPTYLIST; t3073 = CSTRING_TSCP( t3074 ); c2621 = CONS( t3073, c2621 ); t3075 = STRINGTOSYMBOL( CSTRING_TSCP( "LIT" ) ); c2621 = CONS( t3075, c2621 ); CONSTANTEXP( ADR( c2621 ) ); c2615 = CSTRING_TSCP( t3076 ); CONSTANTEXP( ADR( c2615 ) ); c2614 = STRINGTOSYMBOL( CSTRING_TSCP( "MAXDISPLAY" ) ); CONSTANTEXP( ADR( c2614 ) ); c2590 = EMPTYLIST; t3077 = CSTRING_TSCP( t3078 ); c2590 = CONS( t3077, c2590 ); c2590 = CONS( t3075, c2590 ); CONSTANTEXP( ADR( c2590 ) ); c2589 = EMPTYLIST; t3079 = CSTRING_TSCP( t3080 ); c2589 = CONS( t3079, c2589 ); c2589 = CONS( t3075, c2589 ); CONSTANTEXP( ADR( c2589 ) ); c2587 = CSTRING_TSCP( t3081 ); CONSTANTEXP( ADR( c2587 ) ); c2560 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED" ) ); CONSTANTEXP( ADR( c2560 ) ); c2534 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP" ) ); CONSTANTEXP( ADR( c2534 ) ); c2500 = STRINGTOSYMBOL( CSTRING_TSCP( "REQVARS" ) ); CONSTANTEXP( ADR( c2500 ) ); c2497 = CSTRING_TSCP( t3082 ); CONSTANTEXP( ADR( c2497 ) ); c2479 = CSTRING_TSCP( t3083 ); CONSTANTEXP( ADR( c2479 ) ); c2475 = CSTRING_TSCP( t3084 ); CONSTANTEXP( ADR( c2475 ) ); c2472 = CSTRING_TSCP( t3085 ); CONSTANTEXP( ADR( c2472 ) ); c2471 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-REF" ) ); CONSTANTEXP( ADR( c2471 ) ); c2462 = EMPTYLIST; t3086 = CSTRING_TSCP( t3087 ); X1 = t3086; t3088 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUBLE" ) ); X1 = CONS( t3088, X1 ); c2462 = CONS( X1, c2462 ); t3089 = CSTRING_TSCP( t3090 ); X1 = t3089; t3091 = STRINGTOSYMBOL( CSTRING_TSCP( "FLOAT" ) ); X1 = CONS( t3091, X1 ); c2462 = CONS( X1, c2462 ); t3092 = CSTRING_TSCP( t3093 ); X1 = t3092; t3094 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGUNSIGNED" ) ); X1 = CONS( t3094, X1 ); c2462 = CONS( X1, c2462 ); t3095 = CSTRING_TSCP( t3096 ); X1 = t3095; t3097 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTUNSIGNED" ) ); X1 = CONS( t3097, X1 ); c2462 = CONS( X1, c2462 ); t3098 = CSTRING_TSCP( t3099 ); X1 = t3098; t3100 = STRINGTOSYMBOL( CSTRING_TSCP( "UNSIGNED" ) ); X1 = CONS( t3100, X1 ); c2462 = CONS( X1, c2462 ); t3101 = CSTRING_TSCP( t3102 ); X1 = t3101; t3103 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGINT" ) ); X1 = CONS( t3103, X1 ); c2462 = CONS( X1, c2462 ); t3104 = CSTRING_TSCP( t3105 ); X1 = t3104; t3106 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTINT" ) ); X1 = CONS( t3106, X1 ); c2462 = CONS( X1, c2462 ); t3107 = CSTRING_TSCP( t3108 ); X1 = t3107; t3109 = STRINGTOSYMBOL( CSTRING_TSCP( "INT" ) ); X1 = CONS( t3109, X1 ); c2462 = CONS( X1, c2462 ); t3110 = CSTRING_TSCP( t3111 ); X1 = t3110; t3112 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR" ) ); X1 = CONS( t3112, X1 ); c2462 = CONS( X1, c2462 ); t3113 = CSTRING_TSCP( t3114 ); X1 = t3113; X1 = CONS( c2534, X1 ); c2462 = CONS( X1, c2462 ); t3115 = CSTRING_TSCP( t3116 ); X1 = t3115; t3117 = STRINGTOSYMBOL( CSTRING_TSCP( "ARRAY" ) ); X1 = CONS( t3117, X1 ); c2462 = CONS( X1, c2462 ); t3118 = CSTRING_TSCP( t3119 ); X1 = t3118; t3120 = STRINGTOSYMBOL( CSTRING_TSCP( "POINTER" ) ); X1 = CONS( t3120, X1 ); c2462 = CONS( X1, c2462 ); t3121 = CSTRING_TSCP( t3122 ); X1 = t3121; t3123 = STRINGTOSYMBOL( CSTRING_TSCP( "VOID" ) ); X1 = CONS( t3123, X1 ); c2462 = CONS( X1, c2462 ); CONSTANTEXP( ADR( c2462 ) ); c2447 = CSTRING_TSCP( t3124 ); CONSTANTEXP( ADR( c2447 ) ); c2446 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2446 ) ); c2409 = EMPTYLIST; t3125 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL26" ) ); c2409 = CONS( t3125, c2409 ); t3126 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL25" ) ); c2409 = CONS( t3126, c2409 ); t3127 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL24" ) ); c2409 = CONS( t3127, c2409 ); t3128 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL23" ) ); c2409 = CONS( t3128, c2409 ); t3129 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL22" ) ); c2409 = CONS( t3129, c2409 ); t3130 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL21" ) ); c2409 = CONS( t3130, c2409 ); t3131 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL20" ) ); c2409 = CONS( t3131, c2409 ); t3132 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL19" ) ); c2409 = CONS( t3132, c2409 ); t3133 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL18" ) ); c2409 = CONS( t3133, c2409 ); t3134 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL17" ) ); c2409 = CONS( t3134, c2409 ); t3135 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL16" ) ); c2409 = CONS( t3135, c2409 ); t3136 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL15" ) ); c2409 = CONS( t3136, c2409 ); t3137 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL14" ) ); c2409 = CONS( t3137, c2409 ); t3138 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL13" ) ); c2409 = CONS( t3138, c2409 ); t3139 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL12" ) ); c2409 = CONS( t3139, c2409 ); t3140 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL11" ) ); c2409 = CONS( t3140, c2409 ); t3141 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL10" ) ); c2409 = CONS( t3141, c2409 ); t3142 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL9" ) ); c2409 = CONS( t3142, c2409 ); t3143 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL8" ) ); c2409 = CONS( t3143, c2409 ); t3144 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL7" ) ); c2409 = CONS( t3144, c2409 ); t3145 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL6" ) ); c2409 = CONS( t3145, c2409 ); t3146 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL5" ) ); c2409 = CONS( t3146, c2409 ); t3147 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL4" ) ); c2409 = CONS( t3147, c2409 ); t3148 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL3" ) ); c2409 = CONS( t3148, c2409 ); t3149 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL2" ) ); c2409 = CONS( t3149, c2409 ); t3150 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL1" ) ); c2409 = CONS( t3150, c2409 ); t3151 = STRINGTOSYMBOL( CSTRING_TSCP( "XAL0" ) ); c2409 = CONS( t3151, c2409 ); c2409 = LISTTOVECTOR( c2409 ); CONSTANTEXP( ADR( c2409 ) ); c2403 = EMPTYLIST; t3152 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNDOUBLEP" ) ); X1 = t3152; X1 = CONS( t3088, X1 ); c2403 = CONS( X1, c2403 ); t3153 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNFLOATP" ) ); X1 = t3153; X1 = CONS( t3091, X1 ); c2403 = CONS( X1, c2403 ); t3154 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNLONGUNSIGNEDP" ) ); X1 = t3154; X1 = CONS( t3094, X1 ); c2403 = CONS( X1, c2403 ); t3155 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNSHORTUNSIGNEDP" ) ); X1 = t3155; X1 = CONS( t3097, X1 ); c2403 = CONS( X1, c2403 ); t3156 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNUNSIGNEDP" ) ); X1 = t3156; X1 = CONS( t3100, X1 ); c2403 = CONS( X1, c2403 ); t3157 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNLONGINTP" ) ); X1 = t3157; X1 = CONS( t3103, X1 ); c2403 = CONS( X1, c2403 ); t3158 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNSHORTINTP" ) ); X1 = t3158; X1 = CONS( t3106, X1 ); c2403 = CONS( X1, c2403 ); t3159 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNINTP" ) ); X1 = t3159; X1 = CONS( t3109, X1 ); c2403 = CONS( X1, c2403 ); t3160 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNCHARP" ) ); X1 = t3160; X1 = CONS( t3112, X1 ); c2403 = CONS( X1, c2403 ); t3161 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNTSCPP" ) ); X1 = t3161; X1 = CONS( c2534, X1 ); c2403 = CONS( X1, c2403 ); t3162 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNARRAYP" ) ); X1 = t3162; X1 = CONS( t3117, X1 ); c2403 = CONS( X1, c2403 ); t3163 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNPOINTERP" ) ); X1 = t3163; X1 = CONS( t3120, X1 ); c2403 = CONS( X1, c2403 ); t3164 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNVOIDP" ) ); X1 = t3164; X1 = CONS( t3123, X1 ); c2403 = CONS( X1, c2403 ); CONSTANTEXP( ADR( c2403 ) ); c2385 = EMPTYLIST; t3165 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNDOUBLE" ) ); X1 = t3165; X1 = CONS( t3088, X1 ); c2385 = CONS( X1, c2385 ); t3166 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNFLOAT" ) ); X1 = t3166; X1 = CONS( t3091, X1 ); c2385 = CONS( X1, c2385 ); t3167 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNLONGUNSIGNED" ) ); X1 = t3167; X1 = CONS( t3094, X1 ); c2385 = CONS( X1, c2385 ); t3168 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNSHORTUNSIGNED" ) ); X1 = t3168; X1 = CONS( t3097, X1 ); c2385 = CONS( X1, c2385 ); t3169 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNUNSIGNED" ) ); X1 = t3169; X1 = CONS( t3100, X1 ); c2385 = CONS( X1, c2385 ); t3170 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNLONGINT" ) ); X1 = t3170; X1 = CONS( t3103, X1 ); c2385 = CONS( X1, c2385 ); t3171 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNSHORTINT" ) ); X1 = t3171; X1 = CONS( t3106, X1 ); c2385 = CONS( X1, c2385 ); t3172 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNINT" ) ); X1 = t3172; X1 = CONS( t3109, X1 ); c2385 = CONS( X1, c2385 ); t3173 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNCHAR" ) ); X1 = t3173; X1 = CONS( t3112, X1 ); c2385 = CONS( X1, c2385 ); t3174 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNTSCP" ) ); X1 = t3174; X1 = CONS( c2534, X1 ); c2385 = CONS( X1, c2385 ); t3175 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNARRAY" ) ); X1 = t3175; X1 = CONS( t3117, X1 ); c2385 = CONS( X1, c2385 ); t3176 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNPOINTER" ) ); X1 = t3176; X1 = CONS( t3120, X1 ); c2385 = CONS( X1, c2385 ); CONSTANTEXP( ADR( c2385 ) ); c2374 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); CONSTANTEXP( ADR( c2374 ) ); c2370 = EMPTYLIST; t3177 = CSTRING_TSCP( t3178 ); c2370 = CONS( t3177, c2370 ); c2370 = CONS( EMPTYSTRING, c2370 ); CONSTANTEXP( ADR( c2370 ) ); c2362 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNTSCP" ) ); CONSTANTEXP( ADR( c2362 ) ); c2356 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNTSCPP" ) ); CONSTANTEXP( ADR( c2356 ) ); c2344 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNAL" ) ); CONSTANTEXP( ADR( c2344 ) ); c2339 = STRINGTOSYMBOL( CSTRING_TSCP( "NAME" ) ); CONSTANTEXP( ADR( c2339 ) ); c2336 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2336 ) ); c2324 = STRINGTOSYMBOL( CSTRING_TSCP( "CONSTANT" ) ); CONSTANTEXP( ADR( c2324 ) ); c2309 = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL" ) ); CONSTANTEXP( ADR( c2309 ) ); c2301 = STRINGTOSYMBOL( CSTRING_TSCP( "PRINTNAME" ) ); CONSTANTEXP( ADR( c2301 ) ); c2298 = CSTRING_TSCP( t3179 ); CONSTANTEXP( ADR( c2298 ) ); c2295 = STRINGTOSYMBOL( CSTRING_TSCP( "TYPE" ) ); CONSTANTEXP( ADR( c2295 ) ); c2280 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY" ) ); CONSTANTEXP( ADR( c2280 ) ); c2277 = STRINGTOSYMBOL( CSTRING_TSCP( "PAIR_CAR" ) ); CONSTANTEXP( ADR( c2277 ) ); c2276 = CSTRING_TSCP( t3180 ); CONSTANTEXP( ADR( c2276 ) ); c2275 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2275 ) ); c2270 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL_VALUE" ) ); CONSTANTEXP( ADR( c2270 ) ); c2269 = CSTRING_TSCP( t3181 ); CONSTANTEXP( ADR( c2269 ) ); c2251 = STRINGTOSYMBOL( CSTRING_TSCP( "OPTVARS" ) ); CONSTANTEXP( ADR( c2251 ) ); c2245 = STRINGTOSYMBOL( CSTRING_TSCP( "TEMPORARY" ) ); CONSTANTEXP( ADR( c2245 ) ); c2244 = STRINGTOSYMBOL( CSTRING_TSCP( "TEMP" ) ); CONSTANTEXP( ADR( c2244 ) ); c2239 = STRINGTOSYMBOL( CSTRING_TSCP( "CODE-LABEL" ) ); CONSTANTEXP( ADR( c2239 ) ); c2229 = STRINGTOSYMBOL( CSTRING_TSCP( "GOTOS" ) ); CONSTANTEXP( ADR( c2229 ) ); c2228 = STRINGTOSYMBOL( CSTRING_TSCP( "LABEL" ) ); CONSTANTEXP( ADR( c2228 ) ); c2227 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2227 ) ); c2226 = STRINGTOSYMBOL( CSTRING_TSCP( "L" ) ); CONSTANTEXP( ADR( c2226 ) ); c2217 = CSTRING_TSCP( t3182 ); CONSTANTEXP( ADR( c2217 ) ); c2216 = CSTRING_TSCP( t3183 ); CONSTANTEXP( ADR( c2216 ) ); c2215 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAP" ) ); CONSTANTEXP( ADR( c2215 ) ); c2207 = STRINGTOSYMBOL( CSTRING_TSCP( "$DEFINE" ) ); CONSTANTEXP( ADR( c2207 ) ); c2199 = STRINGTOSYMBOL( CSTRING_TSCP( "$IF" ) ); CONSTANTEXP( ADR( c2199 ) ); c2191 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); CONSTANTEXP( ADR( c2191 ) ); c2183 = STRINGTOSYMBOL( CSTRING_TSCP( "$SET" ) ); CONSTANTEXP( ADR( c2183 ) ); c2175 = STRINGTOSYMBOL( CSTRING_TSCP( "$CALL" ) ); CONSTANTEXP( ADR( c2175 ) ); c2161 = CSTRING_TSCP( t3184 ); CONSTANTEXP( ADR( c2161 ) ); c2160 = CSTRING_TSCP( t3185 ); CONSTANTEXP( ADR( c2160 ) ); c2158 = CSTRING_TSCP( t3186 ); CONSTANTEXP( ADR( c2158 ) ); c2148 = EMPTYLIST; t3187 = CSTRING_TSCP( t3188 ); c2148 = CONS( t3187, c2148 ); c2148 = CONS( t3075, c2148 ); CONSTANTEXP( ADR( c2148 ) ); c2147 = EMPTYLIST; c2147 = CONS( _TSCP( 0 ), c2147 ); t3189 = STRINGTOSYMBOL( CSTRING_TSCP( "INDENT" ) ); c2147 = CONS( t3189, c2147 ); CONSTANTEXP( ADR( c2147 ) ); c2144 = EMPTYLIST; t3190 = CSTRING_TSCP( t3191 ); c2144 = CONS( t3190, c2144 ); c2144 = CONS( t3075, c2144 ); CONSTANTEXP( ADR( c2144 ) ); c2143 = EMPTYLIST; t3192 = CSTRING_TSCP( t3193 ); c2143 = CONS( t3192, c2143 ); c2143 = CONS( t3075, c2143 ); CONSTANTEXP( ADR( c2143 ) ); c2142 = CSTRING_TSCP( t3194 ); CONSTANTEXP( ADR( c2142 ) ); c2141 = CSTRING_TSCP( t3195 ); CONSTANTEXP( ADR( c2141 ) ); c2139 = CSTRING_TSCP( t3196 ); CONSTANTEXP( ADR( c2139 ) ); c2136 = EMPTYLIST; t3197 = CSTRING_TSCP( t3198 ); c2136 = CONS( t3197, c2136 ); t3199 = STRINGTOSYMBOL( CSTRING_TSCP( "RETURN" ) ); c2136 = CONS( t3199, c2136 ); c2136 = CONS( c2695, c2136 ); CONSTANTEXP( ADR( c2136 ) ); c2135 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-VALUE" ) ); CONSTANTEXP( ADR( c2135 ) ); c2110 = EMPTYLIST; t3200 = CSTRING_TSCP( t3201 ); c2110 = CONS( t3200, c2110 ); c2110 = CONS( t3075, c2110 ); CONSTANTEXP( ADR( c2110 ) ); c2109 = CSTRING_TSCP( t3202 ); CONSTANTEXP( ADR( c2109 ) ); c2108 = CSTRING_TSCP( t3203 ); CONSTANTEXP( ADR( c2108 ) ); c2106 = CSTRING_TSCP( t3204 ); CONSTANTEXP( ADR( c2106 ) ); c2104 = CSTRING_TSCP( t3205 ); CONSTANTEXP( ADR( c2104 ) ); c2103 = STRINGTOSYMBOL( CSTRING_TSCP( "CSTRING" ) ); CONSTANTEXP( ADR( c2103 ) ); c2102 = CSTRING_TSCP( t3206 ); CONSTANTEXP( ADR( c2102 ) ); c2100 = EMPTYLIST; t3207 = CSTRING_TSCP( t3208 ); c2100 = CONS( t3207, c2100 ); c2100 = CONS( t3075, c2100 ); CONSTANTEXP( ADR( c2100 ) ); c2099 = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL" ) ); CONSTANTEXP( ADR( c2099 ) ); c2096 = CSTRING_TSCP( t3209 ); CONSTANTEXP( ADR( c2096 ) ); c2095 = CSTRING_TSCP( t3210 ); CONSTANTEXP( ADR( c2095 ) ); c2093 = STRINGTOSYMBOL( CSTRING_TSCP( "INITHEAP" ) ); CONSTANTEXP( ADR( c2093 ) ); c2092 = EMPTYLIST; t3211 = CSTRING_TSCP( t3212 ); c2092 = CONS( t3211, c2092 ); c2092 = CONS( t3075, c2092 ); CONSTANTEXP( ADR( c2092 ) ); c2091 = EMPTYLIST; t3213 = CSTRING_TSCP( t3214 ); c2091 = CONS( t3213, c2091 ); c2091 = CONS( t3075, c2091 ); CONSTANTEXP( ADR( c2091 ) ); c2090 = EMPTYLIST; t3215 = CSTRING_TSCP( t3216 ); c2090 = CONS( t3215, c2090 ); c2090 = CONS( t3075, c2090 ); CONSTANTEXP( ADR( c2090 ) ); c2089 = EMPTYLIST; t3217 = CSTRING_TSCP( t3218 ); c2089 = CONS( t3217, c2089 ); c2089 = CONS( t3075, c2089 ); CONSTANTEXP( ADR( c2089 ) ); c2088 = EMPTYLIST; c2088 = CONS( _TSCP( 0 ), c2088 ); c2088 = CONS( c2280, c2088 ); c2088 = CONS( t3072, c2088 ); CONSTANTEXP( ADR( c2088 ) ); c2087 = EMPTYLIST; c2087 = CONS( _TSCP( 32 ), c2087 ); c2087 = CONS( t3189, c2087 ); CONSTANTEXP( ADR( c2087 ) ); c2086 = EMPTYLIST; t3219 = CSTRING_TSCP( t3220 ); c2086 = CONS( t3219, c2086 ); c2086 = CONS( t3075, c2086 ); CONSTANTEXP( ADR( c2086 ) ); c2085 = EMPTYLIST; t3221 = CSTRING_TSCP( t3222 ); c2085 = CONS( t3221, c2085 ); c2085 = CONS( t3075, c2085 ); CONSTANTEXP( ADR( c2085 ) ); c2084 = CSTRING_TSCP( t3223 ); CONSTANTEXP( ADR( c2084 ) ); c2083 = CSTRING_TSCP( t3224 ); CONSTANTEXP( ADR( c2083 ) ); c2082 = CSTRING_TSCP( t3225 ); CONSTANTEXP( ADR( c2082 ) ); c2081 = CSTRING_TSCP( t3226 ); CONSTANTEXP( ADR( c2081 ) ); c2080 = CSTRING_TSCP( t3227 ); CONSTANTEXP( ADR( c2080 ) ); c2078 = EMPTYLIST; c2078 = CONS( t3075, c2078 ); CONSTANTEXP( ADR( c2078 ) ); c2074 = CSTRING_TSCP( t3228 ); CONSTANTEXP( ADR( c2074 ) ); c2073 = CSTRING_TSCP( t3229 ); CONSTANTEXP( ADR( c2073 ) ); c2072 = STRINGTOSYMBOL( CSTRING_TSCP( "LIT" ) ); CONSTANTEXP( ADR( c2072 ) ); c2070 = STRINGTOSYMBOL( CSTRING_TSCP( "$_CDR-ERROR" ) ); CONSTANTEXP( ADR( c2070 ) ); c2069 = STRINGTOSYMBOL( CSTRING_TSCP( "$_CAR-ERROR" ) ); CONSTANTEXP( ADR( c2069 ) ); c2068 = STRINGTOSYMBOL( CSTRING_TSCP( "ERROR" ) ); CONSTANTEXP( ADR( c2068 ) ); c2055 = EMPTYLIST; c2055 = CONS( EMPTYLIST, c2055 ); CONSTANTEXP( ADR( c2055 ) ); c2048 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); CONSTANTEXP( ADR( c2048 ) ); } DEFTSCP( gencode_e_2dlambda_7a3ae383_v ); DEFCSTRING( t3230, "CURRENT-CODE-LAMBDA" ); DEFTSCP( gencode_e_2dstring_8ca45c6a_v ); DEFCSTRING( t3231, "CURRENT-DEFINE-STRING" ); DEFTSCP( gencode_init_2dmodules_v ); DEFCSTRING( t3232, "INIT-MODULES" ); DEFTSCP( gencode_free_2ddisplay_v ); DEFCSTRING( t3233, "FREE-DISPLAY" ); DEFTSCP( gencode_max_2ddisplay_v ); DEFCSTRING( t3234, "MAX-DISPLAY" ); DEFTSCP( gencode_ion_2dinfo_cc47b64b_v ); DEFCSTRING( t3235, "EMPTY-CONDITION-INFO" ); DEFTSCP( gencode_ion_2dinfo_f92fd619_v ); DEFCSTRING( t3236, "GLOBAL-CONDITION-INFO" ); DEFTSCP( gencode_error_2did_v ); DEFCSTRING( t3237, "ERROR-ID" ); DEFTSCP( gencode__24__car_2derror_2did_v ); DEFCSTRING( t3238, "$_CAR-ERROR-ID" ); DEFTSCP( gencode__24__cdr_2derror_2did_v ); DEFCSTRING( t3239, "$_CDR-ERROR-ID" ); DEFTSCP( gencode_generate_2dcode_v ); DEFCSTRING( t3240, "GENERATE-CODE" ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( lap_save_2dcurrent_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_save_2dcurrent_2dlap_v ); EXTERNTSCPP( expform_bound, XAL1( TSCP ) ); EXTERNTSCP( expform_bound_v ); EXTERNTSCPP( lap_emit_2dglobal_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_emit_2dglobal_2dlap_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( lap_emit_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_emit_2dlap_v ); EXTERNTSCPP( expform_cname, XAL1( TSCP ) ); EXTERNTSCP( expform_cname_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); EXTERNTSCPP( gencode_emit_2dconstants, XAL0( ) ); EXTERNTSCP( gencode_emit_2dconstants_v ); EXTERNTSCPP( lap_done_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_done_2dlap_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( gencode_exp_2dgenc, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( gencode_exp_2dgenc_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( gencode_t__modules_bfe186ca, XAL0( ) ); EXTERNTSCP( gencode_t__modules_bfe186ca_v ); TSCP gencode_generate_2dcode( e2062 ) TSCP e2062; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3240 ); if ( FALSE( SYMBOL_VALUE( main_2dprogram_2dname_v ) ) ) goto L3242; X1 = c2161; goto L3243; L3242: X2 = CONS( c2160, EMPTYLIST ); X1 = scrt3_string_2dappend( CONS( SYMBOL_VALUE( module_2dname_v ), X2 ) ); L3243: X2 = EMPTYLIST; X2 = CONS( X2, EMPTYLIST ); gencode_e_2dlambda_7a3ae383_v = c2048; SETGENTL( SYMBOL_VALUE( current_2ddefine_2dname_v ), c2048 ); lap_save_2dcurrent_2dlap( FALSEVALUE ); gencode_max_2ddisplay_v = _TSCP( 0 ); gencode_free_2ddisplay_v = _TSCP( 0 ); gencode_error_2did_v = expform_bound( c2068 ); gencode__24__car_2derror_2did_v = expform_bound( c2069 ); gencode__24__cdr_2derror_2did_v = expform_bound( c2070 ); SETGENTL( SYMBOL_VALUE( global_2dlap_2dcode_v ), EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2072, CONS( c2073, X4 ) ); lap_emit_2dglobal_2dlap( X3 ); X3 = scrt1_cons_2a( c2072, CONS( EMPTYLIST, EMPTYLIST ) ); lap_emit_2dglobal_2dlap( X3 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( _TSCP( 15890 ), X4 ); X4 = CONS( SYMBOL_VALUE( c_2dinclude_2dfile_v ), X4 ); X4 = CONS( _TSCP( 15378 ), X4 ); X3 = scrt1_cons_2a( c2072, CONS( c2074, X4 ) ); lap_emit_2dglobal_2dlap( X3 ); lap_emit_2dglobal_2dlap( c2078 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( c2082, X4 ); X4 = CONS( X1, X4 ); if ( FALSE( SYMBOL_VALUE( main_2dprogram_2dname_v ) ) ) goto L3245; X5 = c2081; goto L3246; L3245: X5 = c2080; L3246: X3 = scrt1_cons_2a( c2072, CONS( X5, X4 ) ); lap_emit_2dglobal_2dlap( X3 ); gencode_init_2dmodules_v = EMPTYLIST; if ( FALSE( SYMBOL_VALUE( main_2dprogram_2dname_v ) ) ) goto L3247; lap_emit_2dlap( c2085 ); goto L3248; L3247: X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( c2084, X4 ); X4 = CONS( X1, X4 ); X3 = scrt1_cons_2a( c2072, CONS( c2083, X4 ) ); lap_emit_2dlap( X3 ); L3248: lap_emit_2dlap( c2086 ); lap_emit_2dlap( c2087 ); lap_emit_2dlap( c2088 ); lap_emit_2dlap( c2089 ); if ( FALSE( SYMBOL_VALUE( main_2dprogram_2dname_v ) ) ) goto L3249; lap_emit_2dlap( c2091 ); goto L3250; L3249: lap_emit_2dlap( c2090 ); L3250: lap_emit_2dlap( c2092 ); if ( FALSE( SYMBOL_VALUE( main_2dprogram_2dname_v ) ) ) goto L3251; X4 = CONS( EMPTYLIST, EMPTYLIST ); X6 = SYMBOL_VALUE( main_2dprogram_2dname_v ); X5 = plist_get( X6, c2099 ); X4 = CONS( expform_cname( X5 ), X4 ); X4 = CONS( c2096, X4 ); X4 = CONS( c2095, X4 ); X3 = scrt1_cons_2a( c2093, CONS( SYMBOL_VALUE( heap_2dsize_v ), X4 ) ); lap_emit_2dlap( X3 ); goto L3252; L3251: X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( _TSCP( 0 ), X4 ); X4 = CONS( _TSCP( 0 ), X4 ); X4 = CONS( _TSCP( 0 ), X4 ); X3 = scrt1_cons_2a( c2093, CONS( SYMBOL_VALUE( heap_2dsize_v ), X4 ) ); lap_emit_2dlap( X3 ); L3252: lap_emit_2dlap( c2100 ); X3 = gencode_emit_2dconstants( ); SETGEN( PAIR_CAR( X2 ), X3 ); lap_done_2dlap( PAIR_CAR( X2 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( c2109, X4 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( c2108, EMPTYLIST ); X6 = CONS( SYMBOL_VALUE( scc_2dversion_v ), X6 ); X6 = CONS( c2106, X6 ); X6 = CONS( SYMBOL_VALUE( module_2dname_v ), X6 ); X4 = CONS( scrt1_cons_2a( c2103, CONS( scrt3_string_2dappend( CONS( c2104, X6 ) ), X5 ) ), X4 ); X3 = scrt1_cons_2a( c2072, CONS( c2102, X4 ) ); lap_emit_2dlap( X3 ); lap_emit_2dlap( c2110 ); X3 = e2062; L3254: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3255; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3259; scrt1__24__car_2derror( X3 ); L3259: X4 = PAIR_CAR( X3 ); gencode_ion_2dinfo_f92fd619_v = gencode_ion_2dinfo_cc47b64b_v; gencode_exp_2dgenc( c2135, X4, EMPTYLIST ); X3 = PAIR_CDR( X3 ); GOBACK( L3254 ); L3255: if ( FALSE( SYMBOL_VALUE( main_2dprogram_2dname_v ) ) ) goto L3263; X4 = SYMBOL_VALUE( main_2dprogram_2dname_v ); X3 = plist_get( X4, c2099 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( c2139, X5 ); X5 = CONS( SYMBOL_VALUE( module_2dname_v ), X5 ); X4 = scrt1_cons_2a( c2072, CONS( c2083, X5 ) ); lap_emit_2dglobal_2dlap( X4 ); if ( FALSE( X3 ) ) goto L3266; X5 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( c2142, X5 ); X4 = scrt1_cons_2a( c2072, CONS( expform_cname( X3 ), X5 ) ); lap_emit_2dlap( X4 ); goto L3267; L3266: X4 = SYMBOL_VALUE( report_2derror_v ); X4 = UNKNOWNCALL( X4, 1 ); VIA( PROCEDURE_CODE( X4 ) )( c2141, PROCEDURE_CLOSURE( X4 ) ); L3267: lap_emit_2dlap( c2143 ); lap_emit_2dlap( c2144 ); goto L3264; L3263: lap_emit_2dlap( c2136 ); L3264: lap_emit_2dlap( c2147 ); lap_emit_2dlap( c2148 ); X3 = gencode_free_2ddisplay_v; if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( X3 ) ), 3 ) ) goto L3270; if ( NEQ( _S2CUINT( _TSCP( 0 ) ), _S2CUINT( X3 ) ) ) goto L3274; goto L3277; L3270: if ( TRUE( scrt2__3d_2dtwo( _TSCP( 0 ), X3 ) ) ) goto L3277; L3274: X4 = SYMBOL_VALUE( report_2derror_v ); X4 = UNKNOWNCALL( X4, 1 ); VIA( PROCEDURE_CODE( X4 ) )( c2158, PROCEDURE_CLOSURE( X4 ) ); L3277: gencode_t__modules_bfe186ca( ); X3 = lap_save_2dcurrent_2dlap( EMPTYLIST ); POPSTACKTRACE( lap_done_2dlap( X3 ) ); } DEFTSCP( gencode_exp_2dgenc_v ); DEFCSTRING( t3278, "EXP-GENC" ); TSCP gencode_exp_2dgenc( l2163, e2164, b2165 ) TSCP l2163, e2164, b2165; { TSCP X1; PUSHSTACKTRACE( t3278 ); if ( NOT( AND( EQ( TSCPTAG( e2164 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2164 ), SYMBOLTAG ) ) ) ) goto L3280; X1 = SYMBOL_VALUE( symbol_2dgenc_v ); X1 = UNKNOWNCALL( X1, 3 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( l2163, e2164, b2165, PROCEDURE_CLOSURE( X1 ) ) ); L3280: if ( EQ( TSCPTAG( e2164 ), PAIRTAG ) ) goto L3285; scrt1__24__car_2derror( e2164 ); L3285: X1 = PAIR_CAR( e2164 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2175 ) ) ) goto L3282; X1 = SYMBOL_VALUE( _24call_2dgenc_v ); X1 = UNKNOWNCALL( X1, 3 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( l2163, e2164, b2165, PROCEDURE_CLOSURE( X1 ) ) ); L3282: if ( EQ( TSCPTAG( e2164 ), PAIRTAG ) ) goto L3290; scrt1__24__car_2derror( e2164 ); L3290: X1 = PAIR_CAR( e2164 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2183 ) ) ) goto L3287; X1 = SYMBOL_VALUE( _24set_2dgenc_v ); X1 = UNKNOWNCALL( X1, 3 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( l2163, e2164, b2165, PROCEDURE_CLOSURE( X1 ) ) ); L3287: if ( EQ( TSCPTAG( e2164 ), PAIRTAG ) ) goto L3295; scrt1__24__car_2derror( e2164 ); L3295: X1 = PAIR_CAR( e2164 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2191 ) ) ) goto L3292; X1 = SYMBOL_VALUE( _24lambda_2dgenc_v ); X1 = UNKNOWNCALL( X1, 3 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( l2163, e2164, b2165, PROCEDURE_CLOSURE( X1 ) ) ); L3292: if ( EQ( TSCPTAG( e2164 ), PAIRTAG ) ) goto L3300; scrt1__24__car_2derror( e2164 ); L3300: X1 = PAIR_CAR( e2164 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2199 ) ) ) goto L3297; X1 = SYMBOL_VALUE( _24if_2dgenc_v ); X1 = UNKNOWNCALL( X1, 3 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( l2163, e2164, b2165, PROCEDURE_CLOSURE( X1 ) ) ); L3297: if ( EQ( TSCPTAG( e2164 ), PAIRTAG ) ) goto L3305; scrt1__24__car_2derror( e2164 ); L3305: X1 = PAIR_CAR( e2164 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2207 ) ) ) goto L3302; X1 = SYMBOL_VALUE( _24define_2dgenc_v ); X1 = UNKNOWNCALL( X1, 3 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( l2163, e2164, b2165, PROCEDURE_CLOSURE( X1 ) ) ); L3302: if ( EQ( TSCPTAG( e2164 ), PAIRTAG ) ) goto L3310; scrt1__24__car_2derror( e2164 ); L3310: X1 = PAIR_CAR( e2164 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2215 ) ) ) goto L3307; X1 = SYMBOL_VALUE( report_2derror_v ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2217, PROCEDURE_CLOSURE( X1 ) ) ); L3307: X1 = SYMBOL_VALUE( report_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2216, e2164, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( gencode_make_2dlabel_v ); DEFCSTRING( t3312, "MAKE-LABEL" ); EXTERNTSCPP( expform_newv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( expform_newv_v ); TSCP gencode_make_2dlabel( ) { TSCP X1; PUSHSTACKTRACE( t3312 ); X1 = CONS( _TSCP( 0 ), EMPTYLIST ); X1 = CONS( c2229, X1 ); X1 = CONS( c2228, X1 ); POPSTACKTRACE( expform_newv( c2226, CONS( c2227, X1 ) ) ); } DEFTSCP( gencode_code_2dlabel_v ); DEFCSTRING( t3314, "CODE-LABEL" ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); TSCP gencode_code_2dlabel( i2232 ) TSCP i2232; { TSCP X2, X1; PUSHSTACKTRACE( t3314 ); X1 = plist_get( i2232, c2239 ); X1 = CONS( X1, EMPTYLIST ); if ( TRUE( PAIR_CAR( X1 ) ) ) goto L3317; X2 = gencode_make_2dlabel( ); SETGEN( PAIR_CAR( X1 ), X2 ); plist_put( i2232, c2239, PAIR_CAR( X1 ) ); L3317: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( gencode_make_2dc_2dglobal_v ); DEFCSTRING( t3320, "MAKE-C-GLOBAL" ); TSCP gencode_make_2dc_2dglobal( ) { TSCP X1; PUSHSTACKTRACE( t3320 ); X1 = CONS( c2245, EMPTYLIST ); POPSTACKTRACE( expform_newv( c2244, CONS( c2227, X1 ) ) ); } DEFTSCP( gencode_optional_2dargs_v ); DEFCSTRING( t3322, "OPTIONAL-ARGS" ); TSCP gencode_optional_2dargs( i2248 ) TSCP i2248; { TSCP X1; PUSHSTACKTRACE( t3322 ); if ( FALSE( plist_get( i2248, c2251 ) ) ) goto L3324; X1 = plist_get( i2248, c2251 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3327; scrt1__24__car_2derror( X1 ); L3327: POPSTACKTRACE( PAIR_CAR( X1 ) ); L3324: POPSTACKTRACE( EMPTYLIST ); } DEFTSCP( gencode_lookup_v ); DEFCSTRING( t3329, "LOOKUP" ); EXTERNTSCPP( gencode_var_2dis_2dconstant, XAL1( TSCP ) ); EXTERNTSCP( gencode_var_2dis_2dconstant_v ); EXTERNTSCPP( expform_vname, XAL1( TSCP ) ); EXTERNTSCP( expform_vname_v ); EXTERNTSCPP( gencode_var_2dis_2dglobal, XAL1( TSCP ) ); EXTERNTSCP( gencode_var_2dis_2dglobal_v ); EXTERNTSCPP( gencode_emit_2dextern, XAL1( TSCP ) ); EXTERNTSCP( gencode_emit_2dextern_v ); EXTERNTSCPP( gencode_var_2din_2dstack, XAL1( TSCP ) ); EXTERNTSCP( gencode_var_2din_2dstack_v ); EXTERNTSCPP( gencode_op_2dlevel_343ff0cb, XAL1( TSCP ) ); EXTERNTSCP( gencode_op_2dlevel_343ff0cb_v ); TSCP gencode_lookup( v2260, b2261 ) TSCP v2260, b2261; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3329 ); if ( FALSE( gencode_var_2dis_2dconstant( v2260 ) ) ) goto L3331; POPSTACKTRACE( expform_vname( v2260 ) ); L3331: if ( FALSE( gencode_var_2dis_2dglobal( v2260 ) ) ) goto L3333; gencode_emit_2dextern( v2260 ); X1 = expform_vname( v2260 ); if ( TRUE( X1 ) ) goto L3337; X3 = plist_get( v2260, c2295 ); if ( FALSE( X3 ) ) goto L3340; X2 = expform_cname( v2260 ); goto L3341; L3340: X2 = X3; L3341: if ( TRUE( X2 ) ) goto L3343; X4 = plist_get( v2260, c2301 ); X3 = SYMBOL_VALUE( report_2derror_v ); X3 = UNKNOWNCALL( X3, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X3 ) )( c2298, X4, PROCEDURE_CLOSURE( X3 ) ) ); L3343: POPSTACKTRACE( X2 ); L3337: POPSTACKTRACE( X1 ); L3333: if ( FALSE( gencode_var_2din_2dstack( v2260 ) ) ) goto L3345; X1 = plist_get( v2260, c2280 ); if ( FALSE( plist_get( v2260, c2275 ) ) ) goto L3348; X2 = CONS( EMPTYLIST, EMPTYLIST ); if ( FALSE( X1 ) ) goto L3350; X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2276, CONS( X1, X4 ) ); goto L3351; L3350: X3 = expform_vname( v2260 ); L3351: POPSTACKTRACE( scrt1_cons_2a( c2277, CONS( X3, X2 ) ) ); L3348: if ( FALSE( X1 ) ) goto L3352; X2 = CONS( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2276, CONS( X1, X2 ) ) ); L3352: POPSTACKTRACE( expform_vname( v2260 ) ); L3345: if ( FALSE( gencode_op_2dlevel_343ff0cb( v2260 ) ) ) goto L3354; X1 = CONS( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2270, CONS( expform_vname( v2260 ), X1 ) ) ); L3354: X2 = expform_vname( v2260 ); X1 = SYMBOL_VALUE( report_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2269, X2, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( gencode_var_2din_2dstack_v ); DEFCSTRING( t3356, "VAR-IN-STACK" ); TSCP gencode_var_2din_2dstack( v2303 ) TSCP v2303; { TSCP X1; PUSHSTACKTRACE( t3356 ); X1 = plist_get( v2303, c2227 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2309 ) ) ) ); } DEFTSCP( gencode_var_2dis_2dglobal_v ); DEFCSTRING( t3358, "VAR-IS-GLOBAL" ); TSCP gencode_var_2dis_2dglobal( v2311 ) TSCP v2311; { TSCP X1; PUSHSTACKTRACE( t3358 ); X1 = plist_get( v2311, c2227 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2099 ) ) ) ); } DEFTSCP( gencode_var_2dis_2dconstant_v ); DEFCSTRING( t3360, "VAR-IS-CONSTANT" ); TSCP gencode_var_2dis_2dconstant( v2318 ) TSCP v2318; { TSCP X1; PUSHSTACKTRACE( t3360 ); X1 = plist_get( v2318, c2227 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2324 ) ) ) ); } DEFTSCP( gencode_op_2dlevel_343ff0cb_v ); DEFCSTRING( t3362, "VAR-IS-TOP-LEVEL" ); TSCP gencode_op_2dlevel_343ff0cb( v2326 ) TSCP v2326; { TSCP X1; PUSHSTACKTRACE( t3362 ); X1 = plist_get( v2326, c2227 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2048 ) ) ) ); } DEFTSCP( gencode_emit_2dextern_v ); DEFCSTRING( t3364, "EMIT-EXTERN" ); EXTERNTSCPP( scrt1_assq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assq_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( gencode_ern_2dargl_18fb6091, XAL1( TSCP ) ); EXTERNTSCP( gencode_ern_2dargl_18fb6091_v ); EXTERNTSCPP( gencode_emit_2dextern_2dargl, XAL1( TSCP ) ); EXTERNTSCP( gencode_emit_2dextern_2dargl_v ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( scrt1_member, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_member_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP gencode_emit_2dextern( v2333 ) TSCP v2333; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3364 ); v2333 = CONS( v2333, EMPTYLIST ); if ( FALSE( plist_get( PAIR_CAR( v2333 ), c2336 ) ) ) goto L3366; X2 = plist_get( PAIR_CAR( v2333 ), c2336 ); X1 = plist_get( X2, c2339 ); SETGEN( PAIR_CAR( v2333 ), X1 ); L3366: if ( TRUE( plist_get( PAIR_CAR( v2333 ), c2344 ) ) ) goto L3368; plist_put( PAIR_CAR( v2333 ), c2344, TRUEVALUE ); X2 = plist_get( PAIR_CAR( v2333 ), c2336 ); if ( FALSE( X2 ) ) goto L3372; X3 = plist_get( PAIR_CAR( v2333 ), c2295 ); X1 = scrt1_assq( X3, c2403 ); goto L3373; L3372: X1 = X2; L3373: if ( FALSE( X1 ) ) goto L3375; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3378; scrt1__24__cdr_2derror( X1 ); L3378: X3 = PAIR_CDR( X1 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = plist_get( PAIR_CAR( v2333 ), c2336 ); X4 = CONS( gencode_ern_2dargl_18fb6091( X5 ), X4 ); X2 = scrt1_cons_2a( X3, CONS( expform_cname( PAIR_CAR( v2333 ) ), X4 ) ); POPSTACKTRACE( lap_emit_2dglobal_2dlap( X2 ) ); L3375: X3 = plist_get( PAIR_CAR( v2333 ), c2295 ); X2 = scrt1_assq( X3, c2385 ); if ( FALSE( X2 ) ) goto L3381; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3384; scrt1__24__cdr_2derror( X2 ); L3384: X4 = PAIR_CDR( X2 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( X4, CONS( expform_vname( PAIR_CAR( v2333 ) ), X5 ) ); POPSTACKTRACE( lap_emit_2dglobal_2dlap( X3 ) ); L3381: if ( FALSE( plist_get( PAIR_CAR( v2333 ), c2336 ) ) ) goto L3387; X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = plist_get( PAIR_CAR( v2333 ), c2336 ); X4 = CONS( gencode_emit_2dextern_2dargl( X5 ), X4 ); X3 = scrt1_cons_2a( c2356, CONS( expform_cname( PAIR_CAR( v2333 ) ), X4 ) ); lap_emit_2dglobal_2dlap( X3 ); L3387: if ( FALSE( gencode_var_2dis_2dglobal( PAIR_CAR( v2333 ) ) ) ) goto L3389; X3 = plist_get( PAIR_CAR( v2333 ), c2374 ); if ( FALSE( expform_vname( PAIR_CAR( v2333 ) ) ) ) goto L3392; X5 = CONS( EMPTYLIST, EMPTYLIST ); X4 = scrt1_cons_2a( c2362, CONS( expform_vname( PAIR_CAR( v2333 ) ), X5 ) ); lap_emit_2dglobal_2dlap( X4 ); L3392: X4 = SYMBOL_VALUE( module_2dname_v ); if ( TRUE( scrt1_equal_3f( X4, X3 ) ) ) goto L3394; if ( TRUE( scrt1_member( X3, c2370 ) ) ) goto L3396; if ( TRUE( scrt1_member( X3, gencode_init_2dmodules_v ) ) ) goto L3398; X4 = plist_get( PAIR_CAR( v2333 ), c2374 ); POPSTACKTRACE( SET( gencode_init_2dmodules_v, sc_cons( X4, gencode_init_2dmodules_v ) ) ); L3398: POPSTACKTRACE( FALSEVALUE ); L3396: POPSTACKTRACE( FALSEVALUE ); L3394: POPSTACKTRACE( FALSEVALUE ); L3389: POPSTACKTRACE( FALSEVALUE ); L3368: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( gencode_ern_2dargl_18fb6091_v ); DEFCSTRING( t3400, "EMIT-C-EXTERN-ARGL" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP gencode_c2407( v2411 ) TSCP v2411; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "CTYPES [inside EMIT-C-EXTERN-ARGL]" ); X1 = v2411; X2 = EMPTYLIST; X3 = EMPTYLIST; L3405: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3406; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3409; scrt1__24__car_2derror( X1 ); L3409: X6 = PAIR_CAR( X1 ); X7 = scrt1_assq( X6, c2462 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3413; scrt1__24__cdr_2derror( X7 ); L3413: X5 = PAIR_CDR( X7 ); X4 = sc_cons( X5, EMPTYLIST ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3416; X5 = PAIR_CDR( X1 ); X3 = X4; X2 = X4; X1 = X5; GOBACK( L3405 ); L3416: X5 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3421; scdebug_error( c2446, c2447, CONS( X3, EMPTYLIST ) ); L3421: X3 = SETGEN( PAIR_CDR( X3 ), X4 ); X1 = X5; GOBACK( L3405 ); L3406: POPSTACKTRACE( X2 ); } EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); TSCP gencode_ern_2dargl_18fb6091( l2405 ) TSCP l2405; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3400 ); X1 = _TSCP( 0 ); X1 = CONS( X1, EMPTYLIST ); X2 = c2409; SETGEN( PAIR_CAR( X1 ), X2 ); X2 = plist_get( l2405, c2251 ); X3 = plist_get( l2405, c2500 ); if ( FALSE( X2 ) ) goto L3424; X6 = scrt1_length( X3 ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L3427; X5 = _TSCP( IPLUS( _S2CINT( X6 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L3428; L3427: X5 = scrt2__2b_2dtwo( X6, _TSCP( 8 ) ); L3428: X6 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), VECTORTAG ) ) ) goto L3430; scdebug_error( c2471, c2472, CONS( X6, EMPTYLIST ) ); L3430: if ( EQ( TSCPTAG( X5 ), FIXNUMTAG ) ) goto L3432; scdebug_error( c2471, c2475, CONS( X5, EMPTYLIST ) ); L3432: if ( LT( _S2CUINT( FIXED_C( X5 ) ), _S2CUINT( VECTOR_LENGTH( X6 ) ) ) ) goto L3434; scdebug_error( c2471, c2479, CONS( X5, EMPTYLIST ) ); L3434: X4 = VECTOR_ELEMENT( X6, X5 ); X5 = gencode_c2407( X3 ); X8 = gencode_c2407( X2 ); X9 = scrt1_cons_2a( c2497, CONS( EMPTYLIST, EMPTYLIST ) ); X7 = scrt1_append_2dtwo( X8, X9 ); X6 = scrt1_cons_2a( X7, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( X4, CONS( scrt1_append_2dtwo( X5, X6 ), EMPTYLIST ) ) ); L3424: X5 = scrt1_length( X3 ); X6 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPTAG( X6 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X6 ), VECTORTAG ) ) ) goto L3437; scdebug_error( c2471, c2472, CONS( X6, EMPTYLIST ) ); L3437: if ( EQ( TSCPTAG( X5 ), FIXNUMTAG ) ) goto L3439; scdebug_error( c2471, c2475, CONS( X5, EMPTYLIST ) ); L3439: if ( LT( _S2CUINT( FIXED_C( X5 ) ), _S2CUINT( VECTOR_LENGTH( X6 ) ) ) ) goto L3441; scdebug_error( c2471, c2479, CONS( X5, EMPTYLIST ) ); L3441: X4 = VECTOR_ELEMENT( X6, X5 ); X5 = gencode_c2407( X3 ); X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( X4, CONS( scrt1_append_2dtwo( X5, X6 ), EMPTYLIST ) ) ); } DEFTSCP( gencode_emit_2dextern_2dargl_v ); DEFCSTRING( t3443, "EMIT-EXTERN-ARGL" ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); EXTERNTSCPP( gencode_l2522, XAL1( TSCP ) ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); TSCP gencode_l2522( i2524 ) TSCP i2524; { TSCP X2, X1; PUSHSTACKTRACE( "LOOP [inside EMIT-EXTERN-ARGL]" ); if ( NEQ( TSCPTAG( i2524 ), FIXNUMTAG ) ) goto L3465; if ( NEQ( _S2CUINT( i2524 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3469; POPSTACKTRACE( EMPTYLIST ); L3465: if ( FALSE( scrt2_zero_3f( i2524 ) ) ) goto L3469; POPSTACKTRACE( EMPTYLIST ); L3469: if ( BITAND( BITOR( _S2CINT( i2524 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3472; X2 = _TSCP( IDIFFERENCE( _S2CINT( i2524 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3473; L3472: X2 = scrt2__2d_2dtwo( i2524, _TSCP( 4 ) ); L3473: X1 = gencode_l2522( X2 ); POPSTACKTRACE( sc_cons( c2534, X1 ) ); } TSCP gencode_emit_2dextern_2dargl( l2504 ) TSCP l2504; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3443 ); X1 = _TSCP( 0 ); X1 = CONS( X1, EMPTYLIST ); X2 = c2409; SETGEN( PAIR_CAR( X1 ), X2 ); if ( FALSE( plist_get( l2504, c2560 ) ) ) goto L3446; X4 = _TSCP( 4 ); goto L3447; L3446: X4 = _TSCP( 0 ); L3447: X6 = plist_get( l2504, c2251 ); X5 = scrt1_length( X6 ); if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( X4 ) ), 3 ) ) goto L3449; X3 = _TSCP( IPLUS( _S2CINT( X5 ), _S2CINT( X4 ) ) ); goto L3450; L3449: X3 = scrt2__2b_2dtwo( X5, X4 ); L3450: X5 = plist_get( l2504, c2500 ); X4 = scrt1_length( X5 ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( X3 ) ), 3 ) ) goto L3452; X2 = _TSCP( IPLUS( _S2CINT( X4 ), _S2CINT( X3 ) ) ); goto L3453; L3452: X2 = scrt2__2b_2dtwo( X4, X3 ); L3453: X4 = PAIR_CAR( X1 ); if ( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), VECTORTAG ) ) ) goto L3456; scdebug_error( c2471, c2472, CONS( X4, EMPTYLIST ) ); L3456: if ( EQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L3458; scdebug_error( c2471, c2475, CONS( X2, EMPTYLIST ) ); L3458: if ( LT( _S2CUINT( FIXED_C( X2 ) ), _S2CUINT( VECTOR_LENGTH( X4 ) ) ) ) goto L3460; scdebug_error( c2471, c2479, CONS( X2, EMPTYLIST ) ); L3460: X3 = VECTOR_ELEMENT( X4, X2 ); X4 = gencode_l2522( X2 ); POPSTACKTRACE( sc_cons( X3, X4 ) ); } DEFTSCP( gencode_t__modules_bfe186ca_v ); DEFCSTRING( t3474, "GENERATE-INIT_MODULES" ); TSCP gencode_t__modules_bfe186ca( ) { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3474 ); X1 = lap_save_2dcurrent_2dlap( EMPTYLIST ); X3 = SYMBOL_VALUE( with_2dmodules_v ); X2 = scrt1_append_2dtwo( gencode_init_2dmodules_v, X3 ); X3 = X2; L3479: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3480; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3484; scrt1__24__car_2derror( X3 ); L3484: X4 = PAIR_CAR( X3 ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( c2587, EMPTYLIST ); X7 = CONS( X4, X7 ); X5 = scrt1_cons_2a( c2072, CONS( scrt3_string_2dappend( CONS( c2080, X7 ) ), X6 ) ); lap_emit_2dglobal_2dlap( X5 ); X3 = PAIR_CDR( X3 ); GOBACK( L3479 ); L3480: lap_emit_2dlap( c2589 ); lap_emit_2dlap( c2590 ); lap_emit_2dlap( c2086 ); lap_emit_2dlap( c2087 ); X3 = SYMBOL_VALUE( with_2dmodules_v ); X2 = scrt1_append_2dtwo( gencode_init_2dmodules_v, X3 ); X3 = X2; L3490: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3491; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3495; scrt1__24__car_2derror( X3 ); L3495: X4 = PAIR_CAR( X3 ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( c2587, EMPTYLIST ); X5 = scrt1_cons_2a( c2072, CONS( scrt3_string_2dappend( CONS( X4, X7 ) ), X6 ) ); lap_emit_2dlap( X5 ); X3 = PAIR_CDR( X3 ); GOBACK( L3490 ); L3491: X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = scrt1_cons_2a( c2614, CONS( gencode_max_2ddisplay_v, X3 ) ); lap_emit_2dlap( X2 ); lap_emit_2dlap( c2147 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = scrt1_cons_2a( c2072, CONS( c2615, X3 ) ); lap_emit_2dlap( X2 ); X2 = lap_save_2dcurrent_2dlap( X1 ); POPSTACKTRACE( lap_done_2dlap( X2 ) ); } DEFTSCP( gencode_constant_2dsymbols_v ); DEFCSTRING( t3499, "CONSTANT-SYMBOLS" ); DEFTSCP( gencode_bol_2dport_c6b2ebee_v ); DEFCSTRING( t3500, "CONSTANT-SYMBOL-PORT" ); DEFTSCP( gencode_emit_2dconstants_v ); DEFCSTRING( t3501, "EMIT-CONSTANTS" ); EXTERNTSCPP( scrt5_open_2doutput_2dstring, XAL0( ) ); EXTERNTSCP( scrt5_open_2doutput_2dstring_v ); EXTERNTSCPP( lap_save_2dlap_2dtemps, XAL0( ) ); EXTERNTSCP( lap_save_2dlap_2dtemps_v ); EXTERNTSCPP( gencode_emit_2dconstant, XAL2( TSCP, TSCP ) ); EXTERNTSCP( gencode_emit_2dconstant_v ); EXTERNTSCPP( lap_restore_2dlap_2dtemps, XAL1( TSCP ) ); EXTERNTSCP( lap_restore_2dlap_2dtemps_v ); TSCP gencode_emit_2dconstants( ) { TSCP X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3501 ); X1 = lap_save_2dcurrent_2dlap( EMPTYLIST ); gencode_constant_2dsymbols_v = EMPTYLIST; gencode_bol_2dport_c6b2ebee_v = scrt5_open_2doutput_2dstring( ); lap_emit_2dlap( c2621 ); lap_emit_2dlap( c2086 ); lap_emit_2dlap( c2087 ); lap_emit_2dlap( c2622 ); X2 = SYMBOL_VALUE( quote_2dconstants_v ); X3 = X2; L3506: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3507; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3511; scrt1__24__car_2derror( X3 ); L3511: X4 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3515; scrt1__24__cdr_2derror( X4 ); L3515: X6 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3518; scrt1__24__car_2derror( X6 ); L3518: X5 = PAIR_CAR( X6 ); X6 = PAIR_CAR( X4 ); X7 = lap_save_2dlap_2dtemps( ); gencode_emit_2dconstant( X5, X6 ); if ( EQ( TSCPTAG( X6 ), FIXNUMTAG ) ) goto L3524; if ( EQ( TSCPIMMEDIATETAG( X6 ), CHARACTERTAG ) ) goto L3524; X9 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( c2659, CONS( scrt1_cons_2a( c2660, CONS( expform_vname( X5 ), X10 ) ), X9 ) ); lap_emit_2dlap( X8 ); L3524: lap_restore_2dlap_2dtemps( X7 ); X3 = PAIR_CDR( X3 ); GOBACK( L3506 ); L3507: lap_emit_2dlap( c2147 ); lap_emit_2dlap( c2148 ); POPSTACKTRACE( lap_save_2dcurrent_2dlap( X1 ) ); } DEFTSCP( gencode_emit_2dconstant_v ); DEFCSTRING( t3527, "EMIT-CONSTANT" ); EXTERNTSCPP( scrt6_display, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_display_v ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); EXTERNTSCPP( scrt2__3c_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3c_2dtwo_v ); EXTERNTSCPP( scrt6_write, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_write_v ); EXTERNTSCPP( scrt2_remainder, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_remainder_v ); EXTERNTSCPP( scrt2__2a_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2a_2dtwo_v ); EXTERNTSCPP( scrt2_quotient, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_quotient_v ); EXTERNTSCPP( scrt2_abs, XAL1( TSCP ) ); EXTERNTSCP( scrt2_abs_v ); EXTERNTSCPP( scrt6_get_2doutput_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt6_get_2doutput_2dstring_v ); EXTERNTSCPP( gencode_ant_2dlist_82e6441b, XAL2( TSCP, TSCP ) ); EXTERNTSCP( gencode_ant_2dlist_82e6441b_v ); EXTERNTSCPP( scrt4_vector_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt4_vector_2d_3elist_v ); TSCP gencode_emit_2dconstant( v2677, c2678 ) TSCP v2677, c2678; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3527 ); if ( NEQ( TSCPTAG( c2678 ), FIXNUMTAG ) ) goto L3529; scrt6_display( c2720, CONS( gencode_bol_2dport_c6b2ebee_v, EMPTYLIST ) ); if ( BITAND( BITOR( _S2CINT( c2678 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L3532; X1 = BOOLEAN( GT( _S2CINT( c2678 ), _S2CINT( _TSCP( 8 ) ) ) ); goto L3533; L3532: X1 = scrt2__3e_2dtwo( c2678, _TSCP( 8 ) ); L3533: if ( TRUE( X1 ) ) goto L3538; if ( BITAND( BITOR( _S2CINT( c2678 ), _S2CINT( _TSCP( -8 ) ) ), 3 ) ) goto L3540; if ( LT( _S2CINT( c2678 ), _S2CINT( _TSCP( -8 ) ) ) ) goto L3538; goto L3545; L3540: if ( TRUE( scrt2__3c_2dtwo( c2678, _TSCP( -8 ) ) ) ) goto L3538; L3545: X5 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( c2678 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X5 ) ) goto L3555; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3555; X4 = _TSCP( REMAINDER( _S2CINT( c2678 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L3556; L3555: X4 = scrt2_remainder( c2678, _TSCP( 40 ) ); L3556: if ( BITAND( BITOR( _S2CINT( _TSCP( 16 ) ), _S2CINT( X4 ) ), 3 ) ) goto L3558; X3 = _TSCP( ITIMES( FIXED_C( _TSCP( 16 ) ), _S2CINT( X4 ) ) ); goto L3559; L3558: X3 = scrt2__2a_2dtwo( _TSCP( 16 ), X4 ); L3559: X4 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X4 ) ) goto L3567; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3567; X2 = _TSCP( REMAINDER( _S2CINT( X3 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L3568; L3567: X2 = scrt2_remainder( X3, _TSCP( 40 ) ); L3568: scrt6_write( X2, CONS( gencode_bol_2dport_c6b2ebee_v, EMPTYLIST ) ); goto L3548; L3538: X5 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( c2678 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X5 ) ) goto L3576; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3576; X4 = C_FIXED( QUOTIENT( _S2CINT( c2678 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L3577; L3576: X4 = scrt2_quotient( c2678, _TSCP( 40 ) ); L3577: if ( BITAND( BITOR( _S2CINT( _TSCP( 16 ) ), _S2CINT( X4 ) ), 3 ) ) goto L3579; X3 = _TSCP( ITIMES( FIXED_C( _TSCP( 16 ) ), _S2CINT( X4 ) ) ); goto L3580; L3579: X3 = scrt2__2a_2dtwo( _TSCP( 16 ), X4 ); L3580: X7 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( c2678 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X7 ) ) goto L3587; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3587; X6 = _TSCP( REMAINDER( _S2CINT( c2678 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L3588; L3587: X6 = scrt2_remainder( c2678, _TSCP( 40 ) ); L3588: if ( BITAND( BITOR( _S2CINT( _TSCP( 16 ) ), _S2CINT( X6 ) ), 3 ) ) goto L3590; X5 = _TSCP( ITIMES( FIXED_C( _TSCP( 16 ) ), _S2CINT( X6 ) ) ); goto L3591; L3590: X5 = scrt2__2a_2dtwo( _TSCP( 16 ), X6 ); L3591: X6 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X6 ) ) goto L3599; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3599; X4 = C_FIXED( QUOTIENT( _S2CINT( X5 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L3600; L3599: X4 = scrt2_quotient( X5, _TSCP( 40 ) ); L3600: if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X4 ) ), 3 ) ) goto L3602; X2 = _TSCP( IPLUS( _S2CINT( X3 ), _S2CINT( X4 ) ) ); goto L3603; L3602: X2 = scrt2__2b_2dtwo( X3, X4 ); L3603: scrt6_write( X2, CONS( gencode_bol_2dport_c6b2ebee_v, EMPTYLIST ) ); X6 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( c2678 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X6 ) ) goto L3610; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3610; X5 = _TSCP( REMAINDER( _S2CINT( c2678 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L3611; L3610: X5 = scrt2_remainder( c2678, _TSCP( 40 ) ); L3611: if ( BITAND( BITOR( _S2CINT( _TSCP( 16 ) ), _S2CINT( X5 ) ), 3 ) ) goto L3613; X4 = _TSCP( ITIMES( FIXED_C( _TSCP( 16 ) ), _S2CINT( X5 ) ) ); goto L3614; L3613: X4 = scrt2__2a_2dtwo( _TSCP( 16 ), X5 ); L3614: X5 = BOOLEAN( NOT( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 40 ) ) ), 3 ) ) ); if ( FALSE( X5 ) ) goto L3622; if ( EQ( _S2CUINT( _TSCP( 40 ) ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L3622; X3 = _TSCP( REMAINDER( _S2CINT( X4 ), _S2CINT( _TSCP( 40 ) ) ) ); goto L3623; L3622: X3 = scrt2_remainder( X4, _TSCP( 40 ) ); L3623: if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L3625; if ( LT( _S2CINT( X3 ), 0 ) ) goto L3630; X2 = X3; goto L3631; L3625: X2 = scrt2_abs( X3 ); goto L3631; L3630: X2 = _TSCP( INEGATE( _S2CINT( X3 ) ) ); L3631: scrt6_write( X2, CONS( gencode_bol_2dport_c6b2ebee_v, EMPTYLIST ) ); L3548: scrt6_display( c2741, CONS( gencode_bol_2dport_c6b2ebee_v, EMPTYLIST ) ); X1 = scrt6_get_2doutput_2dstring( gencode_bol_2dport_c6b2ebee_v ); POPSTACKTRACE( plist_put( v2677, c2745, X1 ) ); L3529: if ( NOT( AND( EQ( TSCPTAG( c2678 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c2678 ), DOUBLEFLOATTAG ) ) ) ) goto L3632; X2 = CONS( EMPTYLIST, EMPTYLIST ); X1 = scrt1_cons_2a( c2703, CONS( expform_vname( v2677 ), X2 ) ); lap_emit_2dglobal_2dlap( X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( c2747, CONS( c2678, X3 ) ), X2 ); X1 = scrt1_cons_2a( c2695, CONS( expform_vname( v2677 ), X2 ) ); POPSTACKTRACE( lap_emit_2dlap( X1 ) ); L3632: if ( NEQ( TSCPIMMEDIATETAG( c2678 ), CHARACTERTAG ) ) goto L3635; scrt6_display( c2720, CONS( gencode_bol_2dport_c6b2ebee_v, EMPTYLIST ) ); X3 = CHAR_FIX( c2678 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 1024 ) ) ), 3 ) ) goto L3640; X2 = _TSCP( ITIMES( FIXED_C( X3 ), _S2CINT( _TSCP( 1024 ) ) ) ); goto L3641; L3640: X2 = scrt2__2a_2dtwo( X3, _TSCP( 1024 ) ); L3641: if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 72 ) ) ), 3 ) ) goto L3643; X1 = _TSCP( IPLUS( _S2CINT( X2 ), _S2CINT( _TSCP( 72 ) ) ) ); goto L3644; L3643: X1 = scrt2__2b_2dtwo( X2, _TSCP( 72 ) ); L3644: scrt6_write( X1, CONS( gencode_bol_2dport_c6b2ebee_v, EMPTYLIST ) ); scrt6_display( c2741, CONS( gencode_bol_2dport_c6b2ebee_v, EMPTYLIST ) ); X1 = scrt6_get_2doutput_2dstring( gencode_bol_2dport_c6b2ebee_v ); POPSTACKTRACE( plist_put( v2677, c2745, X1 ) ); L3635: if ( NOT( AND( EQ( TSCPTAG( c2678 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c2678 ), STRINGTAG ) ) ) ) goto L3645; X1 = gencode_make_2dc_2dglobal( ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c2103, CONS( c2678, X4 ) ), X3 ); X2 = scrt1_cons_2a( c2718, CONS( expform_vname( X1 ), X3 ) ); lap_emit_2dglobal_2dlap( X2 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = scrt1_cons_2a( c2703, CONS( expform_vname( v2677 ), X3 ) ); lap_emit_2dglobal_2dlap( X2 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c2707, CONS( expform_vname( X1 ), X4 ) ), X3 ); X2 = scrt1_cons_2a( c2695, CONS( expform_vname( v2677 ), X3 ) ); POPSTACKTRACE( lap_emit_2dlap( X2 ) ); L3645: if ( NOT( AND( EQ( TSCPTAG( c2678 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c2678 ), SYMBOLTAG ) ) ) ) goto L3648; X2 = CONS( EMPTYLIST, EMPTYLIST ); X1 = scrt1_cons_2a( c2703, CONS( expform_vname( v2677 ), X2 ) ); lap_emit_2dglobal_2dlap( X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( c2706, CONS( scrt1_cons_2a( c2707, CONS( scrt1_cons_2a( c2103, CONS( SYMBOL_NAME( c2678 ), X5 ) ), X4 ) ), X3 ) ), X2 ); X1 = scrt1_cons_2a( c2695, CONS( expform_vname( v2677 ), X2 ) ); lap_emit_2dlap( X1 ); X3 = sc_cons( v2677, EMPTYLIST ); X2 = sc_cons( c2678, X3 ); X1 = X2; POPSTACKTRACE( SET( gencode_constant_2dsymbols_v, sc_cons( X1, gencode_constant_2dsymbols_v ) ) ); L3648: if ( NEQ( TSCPTAG( c2678 ), PAIRTAG ) ) goto L3653; X1 = plist_get( v2677, c2227 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2324 ) ) ) goto L3656; X2 = CONS( EMPTYLIST, EMPTYLIST ); X1 = scrt1_cons_2a( c2703, CONS( expform_vname( v2677 ), X2 ) ); lap_emit_2dglobal_2dlap( X1 ); L3656: X1 = expform_vname( v2677 ); POPSTACKTRACE( gencode_ant_2dlist_82e6441b( X1, c2678 ) ); L3653: if ( NOT( AND( EQ( TSCPTAG( c2678 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c2678 ), VECTORTAG ) ) ) ) goto L3658; X1 = scrt4_vector_2d_3elist( c2678 ); gencode_emit_2dconstant( v2677, X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_cons_2a( c2696, CONS( expform_vname( v2677 ), X3 ) ), X2 ); X1 = scrt1_cons_2a( c2695, CONS( expform_vname( v2677 ), X2 ) ); POPSTACKTRACE( lap_emit_2dlap( X1 ) ); L3658: X1 = SYMBOL_VALUE( report_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2693, c2678, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( gencode_ant_2dlist_82e6441b_v ); DEFCSTRING( t3661, "EMIT-CONSTANT-LIST" ); EXTERNTSCPP( gencode__2delement_28e1d5cf, XAL1( TSCP ) ); EXTERNTSCP( gencode__2delement_28e1d5cf_v ); TSCP gencode_ant_2dlist_82e6441b( v2906, c2907 ) TSCP v2906, c2907; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3661 ); if ( NEQ( TSCPTAG( c2907 ), PAIRTAG ) ) goto L3663; X1 = PAIR_CDR( c2907 ); gencode_ant_2dlist_82e6441b( v2906, X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( v2906, X3 ); X4 = PAIR_CAR( c2907 ); X2 = CONS( scrt1_cons_2a( c2916, CONS( gencode__2delement_28e1d5cf( X4 ), X3 ) ), X2 ); X1 = scrt1_cons_2a( c2695, CONS( v2906, X2 ) ); POPSTACKTRACE( lap_emit_2dlap( X1 ) ); L3663: X2 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( gencode__2delement_28e1d5cf( c2907 ), X2 ); X1 = scrt1_cons_2a( c2695, CONS( v2906, X2 ) ); POPSTACKTRACE( lap_emit_2dlap( X1 ) ); } DEFTSCP( gencode__2delement_28e1d5cf_v ); DEFCSTRING( t3668, "EMIT-CONSTANT-ELEMENT" ); EXTERNTSCP( sc_emptystring ); EXTERNTSCP( sc_emptyvector ); EXTERNTSCPP( lap_use_2dlap_2dtemp, XAL0( ) ); EXTERNTSCP( lap_use_2dlap_2dtemp_v ); EXTERNTSCPP( lap_drop_2dlap_2dtemp, XAL1( TSCP ) ); EXTERNTSCP( lap_drop_2dlap_2dtemp_v ); TSCP gencode__2delement_28e1d5cf( c2922 ) TSCP c2922; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3668 ); if ( EQ( _S2CUINT( c2922 ), _S2CUINT( TRUEVALUE ) ) ) goto L3670; if ( EQ( _S2CUINT( c2922 ), _S2CUINT( EMPTYLIST ) ) ) goto L3672; if ( EQ( _S2CUINT( c2922 ), _S2CUINT( FALSEVALUE ) ) ) goto L3674; if ( TRUE( scrt1_equal_3f( c2922, sc_emptystring ) ) ) goto L3676; if ( TRUE( scrt1_equal_3f( c2922, sc_emptyvector ) ) ) goto L3678; X1 = BOOLEAN( EQ( TSCPTAG( c2922 ), FIXNUMTAG ) ); if ( TRUE( X1 ) ) goto L3684; if ( EQ( TSCPIMMEDIATETAG( c2922 ), CHARACTERTAG ) ) goto L3684; if ( NEQ( TSCPTAG( c2922 ), PAIRTAG ) ) goto L3687; X2 = lap_use_2dlap_2dtemp( ); X3 = expform_vname( X2 ); gencode_ant_2dlist_82e6441b( X3, c2922 ); lap_drop_2dlap_2dtemp( X2 ); POPSTACKTRACE( plist_get( X2, c2745 ) ); L3687: if ( NOT( AND( EQ( TSCPTAG( c2922 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c2922 ), VECTORTAG ) ) ) ) goto L3690; X2 = lap_use_2dlap_2dtemp( ); gencode_emit_2dconstant( X2, c2922 ); lap_drop_2dlap_2dtemp( X2 ); POPSTACKTRACE( plist_get( X2, c2745 ) ); L3690: if ( NOT( AND( EQ( TSCPTAG( c2922 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( c2922 ), SYMBOLTAG ) ) ) ) goto L3693; X2 = scrt1_assq( c2922, gencode_constant_2dsymbols_v ); goto L3694; L3693: X2 = FALSEVALUE; L3694: if ( FALSE( X2 ) ) goto L3696; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3699; scrt1__24__cdr_2derror( X2 ); L3699: X4 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3702; scrt1__24__car_2derror( X4 ); L3702: X3 = PAIR_CAR( X4 ); POPSTACKTRACE( expform_vname( X3 ) ); L3696: X3 = gencode_make_2dc_2dglobal( ); gencode_emit_2dconstant( X3, c2922 ); POPSTACKTRACE( plist_get( X3, c2745 ) ); L3678: POPSTACKTRACE( c2977 ); L3676: POPSTACKTRACE( c2978 ); L3674: POPSTACKTRACE( c2979 ); L3672: POPSTACKTRACE( c2980 ); L3670: POPSTACKTRACE( c2981 ); L3684: POPSTACKTRACE( gencode_emit_2dconstant( c2976, c2922 ) ); } void scrt4__init(); void scrt6__init(); void scrt5__init(); void scdebug__init(); void scrt2__init(); void plist__init(); void scrt1__init(); void expform__init(); void lap__init(); void scrt3__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt4__init(); scrt6__init(); scrt5__init(); scdebug__init(); scrt2__init(); plist__init(); scrt1__init(); expform__init(); lap__init(); scrt3__init(); MAXDISPLAY( 0 ); } void gencode__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(gencode SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3230, ADR( gencode_e_2dlambda_7a3ae383_v ), c2048 ); INITIALIZEVAR( t3231, ADR( gencode_e_2dstring_8ca45c6a_v ), EMPTYLIST ); INITIALIZEVAR( t3232, ADR( gencode_init_2dmodules_v ), EMPTYLIST ); INITIALIZEVAR( t3233, ADR( gencode_free_2ddisplay_v ), _TSCP( 0 ) ); INITIALIZEVAR( t3234, ADR( gencode_max_2ddisplay_v ), _TSCP( 0 ) ); INITIALIZEVAR( t3235, ADR( gencode_ion_2dinfo_cc47b64b_v ), c2055 ); INITIALIZEVAR( t3236, ADR( gencode_ion_2dinfo_f92fd619_v ), gencode_ion_2dinfo_cc47b64b_v ); INITIALIZEVAR( t3237, ADR( gencode_error_2did_v ), FALSEVALUE ); INITIALIZEVAR( t3238, ADR( gencode__24__car_2derror_2did_v ), FALSEVALUE ); INITIALIZEVAR( t3239, ADR( gencode__24__cdr_2derror_2did_v ), FALSEVALUE ); INITIALIZEVAR( t3240, ADR( gencode_generate_2dcode_v ), MAKEPROCEDURE( 1, 0, gencode_generate_2dcode, EMPTYLIST ) ); INITIALIZEVAR( t3278, ADR( gencode_exp_2dgenc_v ), MAKEPROCEDURE( 3, 0, gencode_exp_2dgenc, EMPTYLIST ) ); INITIALIZEVAR( t3312, ADR( gencode_make_2dlabel_v ), MAKEPROCEDURE( 0, 0, gencode_make_2dlabel, EMPTYLIST ) ); INITIALIZEVAR( t3314, ADR( gencode_code_2dlabel_v ), MAKEPROCEDURE( 1, 0, gencode_code_2dlabel, EMPTYLIST ) ); INITIALIZEVAR( t3320, ADR( gencode_make_2dc_2dglobal_v ), MAKEPROCEDURE( 0, 0, gencode_make_2dc_2dglobal, EMPTYLIST ) ); INITIALIZEVAR( t3322, ADR( gencode_optional_2dargs_v ), MAKEPROCEDURE( 1, 0, gencode_optional_2dargs, EMPTYLIST ) ); INITIALIZEVAR( t3329, ADR( gencode_lookup_v ), MAKEPROCEDURE( 2, 0, gencode_lookup, EMPTYLIST ) ); INITIALIZEVAR( t3356, ADR( gencode_var_2din_2dstack_v ), MAKEPROCEDURE( 1, 0, gencode_var_2din_2dstack, EMPTYLIST ) ); INITIALIZEVAR( t3358, ADR( gencode_var_2dis_2dglobal_v ), MAKEPROCEDURE( 1, 0, gencode_var_2dis_2dglobal, EMPTYLIST ) ); INITIALIZEVAR( t3360, ADR( gencode_var_2dis_2dconstant_v ), MAKEPROCEDURE( 1, 0, gencode_var_2dis_2dconstant, EMPTYLIST ) ); INITIALIZEVAR( t3362, ADR( gencode_op_2dlevel_343ff0cb_v ), MAKEPROCEDURE( 1, 0, gencode_op_2dlevel_343ff0cb, EMPTYLIST ) ); INITIALIZEVAR( t3364, ADR( gencode_emit_2dextern_v ), MAKEPROCEDURE( 1, 0, gencode_emit_2dextern, EMPTYLIST ) ); INITIALIZEVAR( t3400, ADR( gencode_ern_2dargl_18fb6091_v ), MAKEPROCEDURE( 1, 0, gencode_ern_2dargl_18fb6091, EMPTYLIST ) ); INITIALIZEVAR( t3443, ADR( gencode_emit_2dextern_2dargl_v ), MAKEPROCEDURE( 1, 0, gencode_emit_2dextern_2dargl, EMPTYLIST ) ); INITIALIZEVAR( t3474, ADR( gencode_t__modules_bfe186ca_v ), MAKEPROCEDURE( 0, 0, gencode_t__modules_bfe186ca, EMPTYLIST ) ); INITIALIZEVAR( t3499, ADR( gencode_constant_2dsymbols_v ), EMPTYLIST ); INITIALIZEVAR( t3500, ADR( gencode_bol_2dport_c6b2ebee_v ), EMPTYLIST ); INITIALIZEVAR( t3501, ADR( gencode_emit_2dconstants_v ), MAKEPROCEDURE( 0, 0, gencode_emit_2dconstants, EMPTYLIST ) ); INITIALIZEVAR( t3527, ADR( gencode_emit_2dconstant_v ), MAKEPROCEDURE( 2, 0, gencode_emit_2dconstant, EMPTYLIST ) ); INITIALIZEVAR( t3661, ADR( gencode_ant_2dlist_82e6441b_v ), MAKEPROCEDURE( 2, 0, gencode_ant_2dlist_82e6441b, EMPTYLIST ) ); INITIALIZEVAR( t3668, ADR( gencode__2delement_28e1d5cf_v ), MAKEPROCEDURE( 1, 0, gencode__2delement_28e1d5cf, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/gencode.sc000066400000000000000000000351611203736146400164750ustar00rootroot00000000000000;;; This is when the actual code generation occurs. It is entered with a ;;; list of expressions. Code is not as optimal as it might be, but then ;;; that's what the C compiler is for. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module gencode) ;;; External and in-line declarations. (include "plist.sch") (include "expform.sch") (include "lambdaexp.sch") (include "miscexp.sch") (include "lap.sch") ;;; Top-level globals. (define CURRENT-CODE-LAMBDA 'top-level) (define CURRENT-DEFINE-STRING '()) ; id which is the string defining the ; current top-level DEFINE. (define INIT-MODULES '()) (define FREE-DISPLAY 0) (define MAX-DISPLAY 0) (define EMPTY-CONDITION-INFO '(()) ) (define GLOBAL-CONDITION-INFO empty-condition-info) (define ERROR-ID #f) (define $_CAR-ERROR-ID #f) (define $_CDR-ERROR-ID #f) (define (GENERATE-CODE expl) (let ((bindings '()) (initname (if main-program-name "main" (string-append module-name "__init"))) (constant-lap '())) (set! current-code-lambda 'top-level) (set! current-define-name 'top-level) (save-current-lap #f) (set! max-display 0) (set! free-display 0) (set! error-id (bound 'error)) (set! $_car-error-id (bound '$_car-error)) (set! $_cdr-error-id (bound '$_cdr-error)) (set! global-lap-code '()) (emit-global-lap `(LIT "/* SCHEME->C */")) (emit-global-lap `(LIT)) (emit-global-lap `(LIT "#include " #\< ,c-include-file #\>)) (emit-global-lap '(LIT)) (emit-global-lap `(LIT ,(if main-program-name "int " "void ") ,initname "();")) (set! init-modules '()) (if main-program-name (emit-lap '(LIT "int main( int argc, char **argv )")) (emit-lap `(LIT "void " ,initname "()"))) (emit-lap '(LIT "{")) (emit-lap '(indent 8)) (emit-lap '(LOCALS DISPLAY 0)) (emit-lap '(LIT "static int init = 0;")) (if main-program-name (emit-lap '(LIT "if (init) return 1;")) (emit-lap '(LIT "if (init) return;"))) (emit-lap '(LIT "init = 1;")) (if main-program-name (emit-lap `(INITHEAP ,heap-size "argc" "argv" ,(cname (id-global main-program-name)))) (emit-lap `(INITHEAP ,heap-size 0 0 0))) (emit-lap '(LIT "init_constants();")) (set! constant-lap (emit-constants)) (done-lap constant-lap) (emit-lap `(LIT "init_modules( " (CSTRING ,(string-append "(" module-name " SCHEME->C COMPILER " scc-version ")")) " );")) (emit-lap '(LIT "sc_segv__handlers();")) (for-each (lambda (exp) (set! global-condition-info empty-condition-info) (exp-genc 'no-value exp bindings)) expl) (if main-program-name (let ((name (id-global main-program-name))) (emit-global-lap `(LIT "void " ,module-name "__init(){}")) (if name (emit-lap `(LIT ,(cname name) "( CLARGUMENTS( argc, argv ) );")) (report-error "Main procedure is not defined")) (emit-lap '(LIT "SCHEMEEXIT();")) (emit-lap '(LIT "return 0;"))) (emit-lap '(SET RETURN "void"))) (emit-lap '(indent 0)) (emit-lap '(LIT "}")) (if (not (= 0 free-display)) (report-error "Compiler error - display index is not 0")) (generate-init_modules) (done-lap (save-current-lap '())))) ;;; Code for each expression is generated by the following function. It ;;; returns the code which evaluates to the expression. (define (EXP-GENC loc exp bindings) (cond ((symbol? exp) (symbol-genc loc exp bindings)) ((eq? (car exp) '$call) ($call-genc loc exp bindings)) ((eq? (car exp) '$set) ($set-genc loc exp bindings)) ((eq? (car exp) '$lambda) ($lambda-genc loc exp bindings)) ((eq? (car exp) '$if) ($if-genc loc exp bindings)) ((eq? (car exp) '$define) ($define-genc loc exp bindings)) ((eq? (car exp) '$lap) (report-error "Illegal use of LAP")) (else (report-error "GENERATE-CODE compiler error" exp)))) ;;; Labels are needed during the code generation and are constructed by the ;;; following function. ID-BOUNDREFS is used to keep track of the number of ;;; references. (define (MAKE-LABEL) (newv 'l 'use 'label 'gotos 0)) ;;; Code labels are automatically constructed for all lambda expressions by ;;; the following function. Labels that are not used are removed during ;;; peep-hole optimization of the lap code. (define (CODE-LABEL id) (let ((label (lambda-code-label id))) (if (not label) (begin (set! label (make-label)) (set-lambda-code-label! id label))) label)) ;;; Global names are sometimes needed in the C-code and are emitted by the ;;; following function. (define (MAKE-C-GLOBAL) (newv 'temp 'use 'temporary)) ;;; The optional argument (if any) of a function is returned by the following ;;; function. (define (OPTIONAL-ARGS id) (if (lambda-optvars id) (car (lambda-optvars id)) '())) ;;; Variables are "looked-up" in the current bindings by the following ;;; function. It returns the code the access the value bound to the ;;; variable. (define (LOOKUP var bindings) (let ((offset 0) (code '())) (cond ((var-is-constant var) (vname var)) ((var-is-global var) (emit-extern var) (or (vname var) (and (id-type var) (cname var)) (report-error "SYMBOL does not have a value cell" (id-printname var)))) ((var-in-stack var) (let ((displayx (id-display var))) (cond ((id-set! var) `(PAIR_CAR ,(if displayx `("DISPLAY" ,displayx) (vname var)))) (displayx `("DISPLAY" ,displayx)) (else (vname var))))) ((var-is-top-level var) `(SYMBOL_VALUE ,(vname var))) (else (report-error "Variable is not bound" (vname var)))))) (define (VAR-IN-STACK var) (eq? (id-use var) 'lexical)) (define (VAR-IS-GLOBAL var) (eq? (id-use var) 'global)) (define (VAR-IS-CONSTANT var) (eq? (id-use var) 'constant)) (define (VAR-IS-TOP-LEVEL var) (eq? (id-use var) 'top-level)) ;;; Emit declarations for external procedures. (define (EMIT-EXTERN var) (if (id-lambda var) (set! var (lambda-name (id-lambda var)))) (when (not (id-external var)) (set-id-external! var #t) (cond ((and (id-lambda var) (assq (id-type var) '((void . EXTERNVOIDP) (pointer . EXTERNPOINTERP) (array . EXTERNARRAYP) (tscp . EXTERNTSCPP) (char . EXTERNCHARP) (int . EXTERNINTP) (shortint . EXTERNSHORTINTP) (longint . EXTERNLONGINTP) (unsigned . EXTERNUNSIGNEDP) (shortunsigned . EXTERNSHORTUNSIGNEDP) (longunsigned . EXTERNLONGUNSIGNEDP) (float . EXTERNFLOATP) (double . EXTERNDOUBLEP)))) => (lambda (type) (emit-global-lap `(,(cdr type) ,(cname var) ,(emit-c-extern-argl (id-lambda var)))))) ((assq (id-type var) '((pointer . EXTERNPOINTER) (array . EXTERNARRAY) (tscp . EXTERNTSCP) (char . EXTERNCHAR) (int . EXTERNINT) (shortint . EXTERNSHORTINT) (longint . EXTERNLONGINT) (unsigned . EXTERNUNSIGNED) (shortunsigned . EXTERNSHORTUNSIGNED) (longunsigned . EXTERNLONGUNSIGNED) (float . EXTERNFLOAT) (double . EXTERNDOUBLE))) => (lambda (type) (emit-global-lap `(,(cdr type) ,(vname var))))) (else (if (id-lambda var) (emit-global-lap `(EXTERNTSCPP ,(cname var) ,(emit-extern-argl (id-lambda var))))) (if (var-is-global var) (let ((vmodule (id-module var))) (if (vname var) (emit-global-lap `(EXTERNTSCP ,(vname var)))) (if (and (not (equal? module-name vmodule)) (not (member vmodule '("" "sc"))) (not (member vmodule init-modules))) (set! init-modules (cons (id-module var) init-modules))))))))) (define (EMIT-C-EXTERN-ARGL lid) (define XALN '#(XAL0 XAL1 XAL2 XAL3 XAL4 XAL5 XAL6 XAL7 XAL8 XAL9 XAL10 XAL11 XAL12 XAL13 XAL14 XAL15 XAL16 XAL17 XAL18 XAL19 XAL20 XAL21 XAL22 XAL23 XAL24 XAL25 XAL26)) (define (CTYPES vars) (map (lambda (var) (cdr (assq var '((void . "void") (pointer . "void*") (array . "void*") (tscp . "TSCP") (char . "char") (int . "int") (shortint . "short int") (longint . "long int") (unsigned . "unsigned") (shortunsigned . "short unsigned") (longunsigned . "long unsigned") (float . "float") (double . "double"))))) vars)) (let ((req (lambda-reqvars lid)) (opt (lambda-optvars lid))) (if opt `(,(vector-ref xaln (+ (length req) 2)) ,@(ctypes req) ,@(ctypes opt) "...") `(,(vector-ref xaln (length req)) ,@(ctypes req))))) (define (EMIT-EXTERN-ARGL lid) (define XALN '#(XAL0 XAL1 XAL2 XAL3 XAL4 XAL5 XAL6 XAL7 XAL8 XAL9 XAL10 XAL11 XAL12 XAL13 XAL14 XAL15 XAL16 XAL17 XAL18 XAL19 XAL20 XAL21 XAL22 XAL23 XAL24 XAL25 XAL26)) (let ((count (+ (length (lambda-reqvars lid)) (length (lambda-optvars lid)) (if (lambda-closed lid) 1 0)))) (cons (vector-ref xaln count) (let loop ((i count)) (if (zero? i) '() (cons 'tscp (loop (- i 1)))))))) ;;; When all code has been emitted, this function is called to emit the ;;; procedure "init_modules" which calls the initialization code for all ;;; modules used by this program. (define (GENERATE-INIT_MODULES) (let ((save-lap (save-current-lap '()))) (for-each (lambda (with-module) (emit-global-lap `(LIT ,(string-append "void " with-module "__init();")))) (append init-modules with-modules)) (emit-lap '(LIT "static void init_modules( compiler_version )")) (emit-lap '(LIT " char *compiler_version;")) (emit-lap '(LIT"{")) (emit-lap '(indent 8)) (for-each (lambda (with-module) (emit-lap `(LIT ,(string-append with-module "__init();")))) (append init-modules with-modules)) (emit-lap `(MAXDISPLAY ,max-display)) (emit-lap '(indent 0)) (emit-lap `(LIT "}")) (done-lap (save-current-lap save-lap)))) ;;; All storage and initialization for constants is emitted at the start of ;;; the module's initialization function. Since vectors, strings, lists, and ;;; floating point numbers are constructed from the heap, they must be ;;; registered with the run-time system. (define CONSTANT-SYMBOLS '()) (define CONSTANT-SYMBOL-PORT '()) (define (EMIT-CONSTANTS) (let ((save-lap (save-current-lap '()))) (set! constant-symbols '()) (set! constant-symbol-port (open-output-string)) (emit-lap '(LIT "static void init_constants()")) (emit-lap '(LIT "{")) (emit-lap '(INDENT 8)) (emit-lap '(LOCALS)) (for-each (lambda (const-var) (let ((var (cadr const-var)) (const (car const-var)) (temps (save-lap-temps))) (emit-constant var const) (if (and (not (fixed? const)) (not (char? const))) (emit-lap `(CONSTANTEXP (ADR ,(vname var))))) (restore-lap-temps temps))) quote-constants) (emit-lap '(INDENT 0)) (emit-lap '(LIT "}")) (save-current-lap save-lap))) (define (EMIT-CONSTANT var const) (cond ((fixed? const) (display "_TSCP( " constant-symbol-port) (if (or (> const 2) (< const -2)) (begin (write (+ (* 4 (quotient const 10)) (quotient (* 4 (remainder const 10)) 10)) constant-symbol-port) (write (abs (remainder (* 4 (remainder const 10)) 10)) constant-symbol-port)) (write (remainder (* 4 (remainder const 10)) 10) constant-symbol-port)) (display " )" constant-symbol-port) (set-id-vname! var (get-output-string constant-symbol-port))) ((float? const) (emit-global-lap `(DEFSTATICTSCP ,(vname var))) (emit-lap `(SET ,(vname var) (DOUBLE_TSCP ,const)))) ((char? const) (display "_TSCP( " constant-symbol-port) (write (+ (* (char->integer const) 256) 18) constant-symbol-port) (display " )" constant-symbol-port) (set-id-vname! var (get-output-string constant-symbol-port))) ((string? const) (let ((temp (make-c-global))) (emit-global-lap `(DEFCSTRING ,(vname temp) (CSTRING ,const))) (emit-global-lap `(DEFSTATICTSCP ,(vname var))) (emit-lap `(SET ,(vname var) (CSTRING_TSCP ,(vname temp)))))) ((symbol? const) (emit-global-lap `(DEFSTATICTSCP ,(vname var))) (emit-lap `(SET ,(vname var) (STRINGTOSYMBOL (CSTRING_TSCP (CSTRING ,(symbol->string const)))))) (set! constant-symbols (cons (list const var) constant-symbols))) ((pair? const) (if (eq? (id-use var) 'constant) (emit-global-lap `(DEFSTATICTSCP ,(vname var)))) (emit-constant-list (vname var) const)) ((vector? const) (emit-constant var (vector->list const)) (emit-lap `(SET ,(vname var) (LISTTOVECTOR ,(vname var))))) (else (report-error "EMIT-CONSTANT compile error:" const)))) (define (EMIT-CONSTANT-LIST varname const) (cond ((pair? const) (emit-constant-list varname (cdr const)) (emit-lap `(SET ,varname (CONS ,(emit-constant-element (car const)) ,varname)))) (else (emit-lap `(SET ,varname ,(emit-constant-element const)))))) (define (EMIT-CONSTANT-ELEMENT const) (cond ((eq? const #t) "TRUEVALUE" ) ((eq? const '()) "EMPTYLIST" ) ((eq? const #f) "FALSEVALUE") ((equal? const "") "EMPTYSTRING") ((equal? const '#()) "EMPTYVECTOR") ((or (fixed? const) (char? const)) (emit-constant 'emit-constant-kludge const)) ((pair? const) (let ((temp (use-lap-temp))) (emit-constant-list (vname temp) const) (drop-lap-temp temp) (id-vname temp))) ((vector? const) (let ((temp (use-lap-temp))) (emit-constant temp const) (drop-lap-temp temp) (id-vname temp))) ((and (symbol? const) (assq const constant-symbols)) => (lambda (symbol.const) (vname (cadr symbol.const)))) (else (let ((temp (make-c-global))) (emit-constant temp const) (id-vname temp))))) scheme2c-2012.10.14/scsc/gencode.sch000066400000000000000000000016531203736146400166440ustar00rootroot00000000000000;;; External definitions for gencode.sc (define-external CURRENT-CODE-LAMBDA gencode) (define-external INIT-MODULES gencode) (define-external FREE-DISPLAY gencode) (define-external MAX-DISPLAY gencode) (define-external EMPTY-CONDITION-INFO gencode) (define-external GLOBAL-CONDITION-INFO gencode) (define-external ERROR-ID gencode) (define-external $_CAR-ERROR-ID gencode) (define-external $_CDR-ERROR-ID gencode) (define-external (EXP-GENC loc exp bindings) gencode) (define-external (MAKE-LABEL) gencode) (define-external (CODE-LABEL id) gencode) (define-external (MAKE-C-GLOBAL) gencode) (define-external (OPTIONAL-ARGS id) gencode) (define-external (LOOKUP var bindings) gencode) (define-external (VAR-IN-STACK var) gencode) (define-external (VAR-IS-GLOBAL var) gencode) (define-external (EMIT-EXTERN var) gencode) (define-external (VAR-IS-CONSTANT var) gencode) (define-external (VAR-IS-TOP-LEVEL var) gencode) scheme2c-2012.10.14/scsc/lambdacode.c000066400000000000000000001462741203736146400167710ustar00rootroot00000000000000 /* SCHEME->C */ #include void lambdacode__init(); DEFSTATICTSCP( indirect_2dlambda_2dlexical_v ); DEFSTATICTSCP( sc_2dstack_2dtrace_v ); DEFSTATICTSCP( current_2ddefine_2dname_v ); DEFSTATICTSCP( current_2ddefine_2dstring_v ); DEFSTATICTSCP( _ion_2dinfo_e0971c7d_v ); DEFSTATICTSCP( _tersection_b4e3b790_v ); DEFSTATICTSCP( retrieve_2dcondition_2dinfo_v ); DEFSTATICTSCP( store_2dcondition_2dinfo_v ); DEFSTATICTSCP( lap_2dmax_2ddisplay_v ); DEFSTATICTSCP( c3019 ); DEFCSTRING( t3084, "CONS" ); DEFSTATICTSCP( c2992 ); DEFSTATICTSCP( c2970 ); DEFSTATICTSCP( c2951 ); DEFSTATICTSCP( c2944 ); DEFSTATICTSCP( c2934 ); DEFSTATICTSCP( c2741 ); DEFSTATICTSCP( c2687 ); DEFSTATICTSCP( c2618 ); DEFSTATICTSCP( c2616 ); DEFSTATICTSCP( c2608 ); DEFSTATICTSCP( c2603 ); DEFCSTRING( t3085, "]" ); DEFSTATICTSCP( c2534 ); DEFCSTRING( t3086, " [inside " ); DEFSTATICTSCP( c2529 ); DEFCSTRING( t3087, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c2526 ); DEFSTATICTSCP( c2525 ); DEFSTATICTSCP( c2520 ); DEFSTATICTSCP( c2519 ); DEFSTATICTSCP( c2509 ); DEFCSTRING( t3088, "CLOSURE_VAR" ); DEFSTATICTSCP( c2475 ); DEFCSTRING( t3089, "MAKECLOSURE" ); DEFSTATICTSCP( c2413 ); DEFCSTRING( t3090, "DISPLAY" ); DEFSTATICTSCP( c2394 ); DEFSTATICTSCP( c2379 ); DEFSTATICTSCP( c2376 ); DEFSTATICTSCP( c2375 ); DEFSTATICTSCP( c2374 ); DEFSTATICTSCP( c2250 ); DEFSTATICTSCP( c2245 ); DEFSTATICTSCP( c2244 ); DEFSTATICTSCP( c2236 ); DEFSTATICTSCP( c2232 ); DEFSTATICTSCP( c2224 ); DEFCSTRING( t3092, "}" ); DEFSTATICTSCP( t3091 ); DEFSTATICTSCP( t3093 ); DEFSTATICTSCP( c2223 ); DEFSTATICTSCP( c2221 ); DEFSTATICTSCP( c2218 ); DEFSTATICTSCP( c2217 ); DEFSTATICTSCP( c2216 ); DEFSTATICTSCP( c2215 ); DEFCSTRING( t3095, "{" ); DEFSTATICTSCP( t3094 ); DEFCSTRING( t3096, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2206 ); DEFSTATICTSCP( c2205 ); DEFSTATICTSCP( c2170 ); DEFCSTRING( t3097, "EMPTYLIST" ); DEFSTATICTSCP( c2169 ); DEFCSTRING( t3098, "MAKEPROCEDURE" ); DEFSTATICTSCP( c2166 ); DEFSTATICTSCP( c2165 ); DEFSTATICTSCP( c2164 ); DEFSTATICTSCP( c2132 ); DEFSTATICTSCP( c2111 ); DEFSTATICTSCP( c2106 ); DEFSTATICTSCP( c2102 ); static void init_constants() { indirect_2dlambda_2dlexical_v = STRINGTOSYMBOL( CSTRING_TSCP( "INDIR\ ECT-LAMBDA-LEXICAL" ) ); CONSTANTEXP( ADR( indirect_2dlambda_2dlexical_v ) ); sc_2dstack_2dtrace_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-STACK-TRACE\ " ) ); CONSTANTEXP( ADR( sc_2dstack_2dtrace_v ) ); current_2ddefine_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-D\ EFINE-NAME" ) ); CONSTANTEXP( ADR( current_2ddefine_2dname_v ) ); current_2ddefine_2dstring_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT\ -DEFINE-STRING" ) ); CONSTANTEXP( ADR( current_2ddefine_2dstring_v ) ); _ion_2dinfo_e0971c7d_v = STRINGTOSYMBOL( CSTRING_TSCP( "INTERSECT-WI\ TH-GLOBAL-CONDITION-INFO" ) ); CONSTANTEXP( ADR( _ion_2dinfo_e0971c7d_v ) ); _tersection_b4e3b790_v = STRINGTOSYMBOL( CSTRING_TSCP( "STORED-CONDI\ TIONS-INTERSECTION" ) ); CONSTANTEXP( ADR( _tersection_b4e3b790_v ) ); retrieve_2dcondition_2dinfo_v = STRINGTOSYMBOL( CSTRING_TSCP( "RETRI\ EVE-CONDITION-INFO" ) ); CONSTANTEXP( ADR( retrieve_2dcondition_2dinfo_v ) ); store_2dcondition_2dinfo_v = STRINGTOSYMBOL( CSTRING_TSCP( "STORE-CO\ NDITION-INFO" ) ); CONSTANTEXP( ADR( store_2dcondition_2dinfo_v ) ); lap_2dmax_2ddisplay_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAP-MAX-DISPL\ AY" ) ); CONSTANTEXP( ADR( lap_2dmax_2ddisplay_v ) ); c3019 = STRINGTOSYMBOL( CSTRING_TSCP( "CONS" ) ); CONSTANTEXP( ADR( c3019 ) ); c2992 = CSTRING_TSCP( t3084 ); CONSTANTEXP( ADR( c2992 ) ); c2970 = STRINGTOSYMBOL( CSTRING_TSCP( "VNAME" ) ); CONSTANTEXP( ADR( c2970 ) ); c2951 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2951 ) ); c2944 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2944 ) ); c2934 = STRINGTOSYMBOL( CSTRING_TSCP( "UNDEFINED" ) ); CONSTANTEXP( ADR( c2934 ) ); c2741 = STRINGTOSYMBOL( CSTRING_TSCP( "GOTO" ) ); CONSTANTEXP( ADR( c2741 ) ); c2687 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE-TAILS" ) ); CONSTANTEXP( ADR( c2687 ) ); c2618 = STRINGTOSYMBOL( CSTRING_TSCP( "LABEL" ) ); CONSTANTEXP( ADR( c2618 ) ); c2616 = STRINGTOSYMBOL( CSTRING_TSCP( "TOS" ) ); CONSTANTEXP( ADR( c2616 ) ); c2608 = STRINGTOSYMBOL( CSTRING_TSCP( "OPTVARS" ) ); CONSTANTEXP( ADR( c2608 ) ); c2603 = EMPTYLIST; c2603 = CONS( c2934, c2603 ); CONSTANTEXP( ADR( c2603 ) ); c2534 = CSTRING_TSCP( t3085 ); CONSTANTEXP( ADR( c2534 ) ); c2529 = CSTRING_TSCP( t3086 ); CONSTANTEXP( ADR( c2529 ) ); c2526 = CSTRING_TSCP( t3087 ); CONSTANTEXP( ADR( c2526 ) ); c2525 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c2525 ) ); c2520 = STRINGTOSYMBOL( CSTRING_TSCP( "CSTRING" ) ); CONSTANTEXP( ADR( c2520 ) ); c2519 = STRINGTOSYMBOL( CSTRING_TSCP( "PUSHSTACKTRACE" ) ); CONSTANTEXP( ADR( c2519 ) ); c2509 = STRINGTOSYMBOL( CSTRING_TSCP( "PRINTNAME" ) ); CONSTANTEXP( ADR( c2509 ) ); c2475 = CSTRING_TSCP( t3088 ); CONSTANTEXP( ADR( c2475 ) ); c2413 = CSTRING_TSCP( t3089 ); CONSTANTEXP( ADR( c2413 ) ); c2394 = CSTRING_TSCP( t3090 ); CONSTANTEXP( ADR( c2394 ) ); c2379 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY-CLOSEP" ) ); CONSTANTEXP( ADR( c2379 ) ); c2376 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSUREP" ) ); CONSTANTEXP( ADR( c2376 ) ); c2375 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2375 ) ); c2374 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSE" ) ); CONSTANTEXP( ADR( c2374 ) ); c2250 = STRINGTOSYMBOL( CSTRING_TSCP( "REQVARS" ) ); CONSTANTEXP( ADR( c2250 ) ); c2245 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); CONSTANTEXP( ADR( c2245 ) ); c2244 = STRINGTOSYMBOL( CSTRING_TSCP( "NESTIN" ) ); CONSTANTEXP( ADR( c2244 ) ); c2236 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNAL" ) ); CONSTANTEXP( ADR( c2236 ) ); c2232 = STRINGTOSYMBOL( CSTRING_TSCP( "NAME" ) ); CONSTANTEXP( ADR( c2232 ) ); c2224 = EMPTYLIST; t3091 = CSTRING_TSCP( t3092 ); c2224 = CONS( t3091, c2224 ); t3093 = STRINGTOSYMBOL( CSTRING_TSCP( "LIT" ) ); c2224 = CONS( t3093, c2224 ); CONSTANTEXP( ADR( c2224 ) ); c2223 = STRINGTOSYMBOL( CSTRING_TSCP( "INDENT" ) ); CONSTANTEXP( ADR( c2223 ) ); c2221 = STRINGTOSYMBOL( CSTRING_TSCP( "RETURN" ) ); CONSTANTEXP( ADR( c2221 ) ); c2218 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY" ) ); CONSTANTEXP( ADR( c2218 ) ); c2217 = STRINGTOSYMBOL( CSTRING_TSCP( "LOCALS" ) ); CONSTANTEXP( ADR( c2217 ) ); c2216 = EMPTYLIST; c2216 = CONS( _TSCP( 32 ), c2216 ); c2216 = CONS( c2223, c2216 ); CONSTANTEXP( ADR( c2216 ) ); c2215 = EMPTYLIST; t3094 = CSTRING_TSCP( t3095 ); c2215 = CONS( t3094, c2215 ); c2215 = CONS( t3093, c2215 ); CONSTANTEXP( ADR( c2215 ) ); c2206 = CSTRING_TSCP( t3096 ); CONSTANTEXP( ADR( c2206 ) ); c2205 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2205 ) ); c2170 = STRINGTOSYMBOL( CSTRING_TSCP( "PROC" ) ); CONSTANTEXP( ADR( c2170 ) ); c2169 = CSTRING_TSCP( t3097 ); CONSTANTEXP( ADR( c2169 ) ); c2166 = CSTRING_TSCP( t3098 ); CONSTANTEXP( ADR( c2166 ) ); c2165 = STRINGTOSYMBOL( CSTRING_TSCP( "SET" ) ); CONSTANTEXP( ADR( c2165 ) ); c2164 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-VALUE" ) ); CONSTANTEXP( ADR( c2164 ) ); c2132 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); CONSTANTEXP( ADR( c2132 ) ); c2111 = STRINGTOSYMBOL( CSTRING_TSCP( "GENERATE" ) ); CONSTANTEXP( ADR( c2111 ) ); c2106 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED-PROCEDURE" ) ); CONSTANTEXP( ADR( c2106 ) ); c2102 = STRINGTOSYMBOL( CSTRING_TSCP( "PROCEDURE" ) ); CONSTANTEXP( ADR( c2102 ) ); } DEFTSCP( lambdacode__24lambda_2dgenc_v ); DEFCSTRING( t3099, "$LAMBDA-GENC" ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); EXTERNTSCPP( lambdacode_procedure_2demit, XAL4( TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( lambdacode_procedure_2demit_v ); EXTERNTSCPP( ambdacode_ure_2demit_8ce41db4, XAL4( TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( ambdacode_ure_2demit_8ce41db4_v ); TSCP lambdacode__24lambda_2dgenc( l2092, e2093, b2094 ) TSCP l2092, e2093, b2094; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3099 ); if ( NEQ( TSCPTAG( e2093 ), PAIRTAG ) ) goto L3101; X3 = PAIR_CAR( e2093 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2132 ) ) ); goto L3102; L3101: X2 = FALSEVALUE; L3102: if ( FALSE( X2 ) ) goto L3105; if ( EQ( TSCPTAG( e2093 ), PAIRTAG ) ) goto L3108; scrt1__24__cdr_2derror( e2093 ); L3108: X3 = PAIR_CDR( e2093 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3111; scrt1__24__car_2derror( X3 ); L3111: X1 = PAIR_CAR( X3 ); goto L3106; L3105: X1 = X2; L3106: X2 = plist_get( X1, c2111 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2102 ) ) ) goto L3115; POPSTACKTRACE( lambdacode_procedure_2demit( l2092, X1, e2093, b2094 ) ); L3115: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2106 ) ) ) goto L3117; POPSTACKTRACE( ambdacode_ure_2demit_8ce41db4( l2092, X1, e2093, b2094 ) ); L3117: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( lambdacode_procedure_2demit_v ); DEFCSTRING( t3119, "PROCEDURE-EMIT" ); EXTERNTSCPP( gencode_optional_2dargs, XAL1( TSCP ) ); EXTERNTSCP( gencode_optional_2dargs_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( expform_cname, XAL1( TSCP ) ); EXTERNTSCP( expform_cname_v ); EXTERNTSCPP( lap_emit_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_emit_2dlap_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( expform_vname, XAL1( TSCP ) ); EXTERNTSCP( expform_vname_v ); EXTERNTSCPP( lap_save_2dcurrent_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_save_2dcurrent_2dlap_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCP( gencode_free_2ddisplay_v ); EXTERNTSCPP( ambdacode_ace_2demit_561a03cc, XAL1( TSCP ) ); EXTERNTSCP( ambdacode_ace_2demit_561a03cc_v ); EXTERNTSCPP( ambdacode_ody_2dgenc_da78cf6b, XAL5( TSCP, TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( ambdacode_ody_2dgenc_da78cf6b_v ); EXTERNTSCPP( ambdacode__2ddisplay_cfffb4a9, XAL2( TSCP, TSCP ) ); EXTERNTSCP( ambdacode__2ddisplay_cfffb4a9_v ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); EXTERNTSCPP( lap_done_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_done_2dlap_v ); TSCP lambdacode_procedure_2demit( l2145, i2146, e2147, b2148 ) TSCP l2145, i2146, e2147, b2148; { TSCP X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3119 ); X1 = plist_get( i2146, c2250 ); X2 = gencode_optional_2dargs( i2146 ); if ( FALSE( X2 ) ) goto L3123; X5 = sc_cons( X2, EMPTYLIST ); X4 = X5; goto L3124; L3123: X4 = EMPTYLIST; L3124: X3 = scrt1_append_2dtwo( X1, X4 ); X4 = expform_cname( i2146 ); X5 = EMPTYLIST; X5 = CONS( X5, EMPTYLIST ); X7 = plist_get( i2146, c2244 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2245 ) ) ); if ( EQ( _S2CUINT( l2145 ), _S2CUINT( c2164 ) ) ) goto L3130; X8 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( c2169, X9 ); X9 = CONS( expform_cname( X4 ), X9 ); if ( FALSE( X2 ) ) goto L3132; X10 = _TSCP( 4 ); goto L3133; L3132: X10 = _TSCP( 0 ); L3133: X9 = CONS( X10, X9 ); X8 = CONS( scrt1_cons_2a( c2166, CONS( scrt1_length( X1 ), X9 ) ), X8 ); X7 = scrt1_cons_2a( c2165, CONS( expform_vname( l2145 ), X8 ) ); lap_emit_2dlap( X7 ); L3130: X7 = lap_save_2dcurrent_2dlap( EMPTYLIST ); SETGEN( PAIR_CAR( X5 ), X7 ); X10 = X3; X11 = EMPTYLIST; X12 = EMPTYLIST; L3136: if ( NEQ( _S2CUINT( X10 ), _S2CUINT( EMPTYLIST ) ) ) goto L3137; X9 = X11; goto L3144; L3137: if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3140; scrt1__24__car_2derror( X10 ); L3140: X15 = PAIR_CAR( X10 ); X14 = expform_vname( X15 ); X13 = sc_cons( X14, EMPTYLIST ); if ( NEQ( _S2CUINT( X11 ), _S2CUINT( EMPTYLIST ) ) ) goto L3143; X14 = PAIR_CDR( X10 ); X12 = X13; X11 = X13; X10 = X14; GOBACK( L3136 ); L3143: X14 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L3148; scdebug_error( c2205, c2206, CONS( X12, EMPTYLIST ) ); L3148: X12 = SETGEN( PAIR_CDR( X12 ), X13 ); X10 = X14; GOBACK( L3136 ); L3144: X10 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ); X7 = scrt1_cons_2a( c2170, CONS( expform_cname( X4 ), X8 ) ); lap_emit_2dlap( X7 ); lap_emit_2dlap( c2215 ); lap_emit_2dlap( c2216 ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( gencode_free_2ddisplay_v, X8 ); X7 = scrt1_cons_2a( c2217, CONS( c2218, X8 ) ); lap_emit_2dlap( X7 ); ambdacode_ace_2demit_561a03cc( i2146 ); X7 = ambdacode__2ddisplay_cfffb4a9( X3, gencode_free_2ddisplay_v ); ambdacode_ody_2dgenc_da78cf6b( c2221, e2147, X3, X7, b2148 ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X7 = scrt1_cons_2a( c2223, CONS( _TSCP( 0 ), X8 ) ); lap_emit_2dlap( X7 ); lap_emit_2dlap( c2224 ); X7 = plist_get( i2146, c2232 ); if ( EQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L3150; X7 = plist_get( i2146, c2232 ); plist_put( X7, c2236, TRUEVALUE ); L3150: X7 = lap_save_2dcurrent_2dlap( PAIR_CAR( X5 ) ); POPSTACKTRACE( lap_done_2dlap( X7 ) ); } DEFTSCP( ambdacode_ure_2demit_8ce41db4_v ); DEFCSTRING( t3152, "CLOSED-PROCEDURE-EMIT" ); EXTERNTSCPP( expform_newv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( expform_newv_v ); EXTERNTSCPP( ambdacode__2dclosure_56745b5, XAL1( TSCP ) ); EXTERNTSCP( ambdacode__2dclosure_56745b5_v ); EXTERNTSCPP( ambdacode__2ddisplay_41b1bac7, XAL2( TSCP, TSCP ) ); EXTERNTSCP( ambdacode__2ddisplay_41b1bac7_v ); EXTERNTSCPP( lap_use_2dlap_2dtemp, XAL0( ) ); EXTERNTSCP( lap_use_2dlap_2dtemp_v ); TSCP ambdacode_ure_2demit_8ce41db4( l2252, i2253, e2254, b2255 ) TSCP l2252, i2253, e2254, b2255; { TSCP X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3152 ); X1 = plist_get( i2253, c2250 ); X2 = gencode_optional_2dargs( i2253 ); X4 = CONS( plist_get( i2253, c2379 ), EMPTYLIST ); X4 = CONS( c2218, X4 ); X4 = CONS( c2376, X4 ); X3 = expform_newv( c2374, CONS( c2375, X4 ) ); if ( FALSE( X2 ) ) goto L3157; X7 = sc_cons( X2, EMPTYLIST ); X6 = X7; goto L3158; L3157: X6 = EMPTYLIST; L3158: X8 = sc_cons( X3, EMPTYLIST ); X7 = X8; X5 = scrt1_append_2dtwo( X6, X7 ); X4 = scrt1_append_2dtwo( X1, X5 ); X5 = expform_cname( i2253 ); X6 = EMPTYLIST; X6 = CONS( X6, EMPTYLIST ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( ambdacode__2dclosure_56745b5( i2253 ), X9 ); X9 = CONS( expform_cname( X5 ), X9 ); if ( FALSE( X2 ) ) goto L3164; X10 = _TSCP( 4 ); goto L3165; L3164: X10 = _TSCP( 0 ); L3165: X9 = CONS( X10, X9 ); X8 = CONS( scrt1_cons_2a( c2166, CONS( scrt1_length( X1 ), X9 ) ), X8 ); X7 = scrt1_cons_2a( c2165, CONS( expform_vname( l2252 ), X8 ) ); lap_emit_2dlap( X7 ); X7 = lap_save_2dcurrent_2dlap( EMPTYLIST ); SETGEN( PAIR_CAR( X6 ), X7 ); X10 = X4; X11 = EMPTYLIST; X12 = EMPTYLIST; L3168: if ( NEQ( _S2CUINT( X10 ), _S2CUINT( EMPTYLIST ) ) ) goto L3169; X9 = X11; goto L3176; L3169: if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L3172; scrt1__24__car_2derror( X10 ); L3172: X15 = PAIR_CAR( X10 ); X14 = expform_vname( X15 ); X13 = sc_cons( X14, EMPTYLIST ); if ( NEQ( _S2CUINT( X11 ), _S2CUINT( EMPTYLIST ) ) ) goto L3175; X14 = PAIR_CDR( X10 ); X12 = X13; X11 = X13; X10 = X14; GOBACK( L3168 ); L3175: X14 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L3180; scdebug_error( c2205, c2206, CONS( X12, EMPTYLIST ) ); L3180: X12 = SETGEN( PAIR_CDR( X12 ), X13 ); X10 = X14; GOBACK( L3168 ); L3176: X10 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ); X7 = scrt1_cons_2a( c2170, CONS( expform_cname( X5 ), X8 ) ); lap_emit_2dlap( X7 ); lap_emit_2dlap( c2215 ); lap_emit_2dlap( c2216 ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( gencode_free_2ddisplay_v, X8 ); X7 = scrt1_cons_2a( c2217, CONS( c2218, X8 ) ); lap_emit_2dlap( X7 ); ambdacode_ace_2demit_561a03cc( i2253 ); X7 = ambdacode__2ddisplay_41b1bac7( i2253, X3 ); if ( FALSE( X7 ) ) goto L3183; X8 = lap_use_2dlap_2dtemp( ); X9 = ambdacode__2ddisplay_cfffb4a9( X4, gencode_free_2ddisplay_v ); ambdacode_ody_2dgenc_da78cf6b( X8, e2254, X4, X9, b2255 ); X9 = X7; X10 = EMPTYLIST; X11 = EMPTYLIST; L3188: if ( EQ( _S2CUINT( X9 ), _S2CUINT( EMPTYLIST ) ) ) goto L3196; if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3192; scrt1__24__car_2derror( X9 ); L3192: X14 = PAIR_CAR( X9 ); X13 = lap_emit_2dlap( X14 ); X12 = sc_cons( X13, EMPTYLIST ); if ( NEQ( _S2CUINT( X10 ), _S2CUINT( EMPTYLIST ) ) ) goto L3195; X13 = PAIR_CDR( X9 ); X11 = X12; X10 = X12; X9 = X13; GOBACK( L3188 ); L3195: X13 = PAIR_CDR( X9 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L3200; scdebug_error( c2205, c2206, CONS( X11, EMPTYLIST ) ); L3200: X11 = SETGEN( PAIR_CDR( X11 ), X12 ); X9 = X13; GOBACK( L3188 ); L3196: X10 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( expform_vname( X8 ), X10 ); X9 = scrt1_cons_2a( c2165, CONS( c2221, X10 ) ); lap_emit_2dlap( X9 ); goto L3184; L3183: ambdacode_ody_2dgenc_da78cf6b( c2221, e2254, X4, X4, b2255 ); L3184: X8 = CONS( EMPTYLIST, EMPTYLIST ); X7 = scrt1_cons_2a( c2223, CONS( _TSCP( 0 ), X8 ) ); lap_emit_2dlap( X7 ); lap_emit_2dlap( c2224 ); X7 = plist_get( i2253, c2232 ); if ( EQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L3202; X7 = plist_get( i2253, c2232 ); plist_put( X7, c2236, TRUEVALUE ); L3202: X7 = lap_save_2dcurrent_2dlap( PAIR_CAR( X6 ) ); POPSTACKTRACE( lap_done_2dlap( X7 ) ); } DEFTSCP( ambdacode__2ddisplay_cfffb4a9_v ); DEFCSTRING( t3204, "PROC-ARGS-TO-DISPLAY" ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); TSCP ambdacode__2ddisplay_cfffb4a9( f2383, d2384 ) TSCP f2383, d2384; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3204 ); if ( FALSE( f2383 ) ) goto L3206; if ( EQ( TSCPTAG( f2383 ), PAIRTAG ) ) goto L3209; scrt1__24__car_2derror( f2383 ); L3209: X1 = PAIR_CAR( f2383 ); if ( FALSE( plist_get( X1, c2218 ) ) ) goto L3212; X3 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( expform_vname( X1 ), X3 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X2 = scrt1_cons_2a( c2165, CONS( scrt1_cons_2a( c2394, CONS( d2384, X4 ) ), X3 ) ); lap_emit_2dlap( X2 ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X2 = scrt1_cons_2a( c2394, CONS( d2384, X3 ) ); X4 = PAIR_CDR( f2383 ); if ( BITAND( BITOR( _S2CINT( d2384 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3216; X5 = _TSCP( IPLUS( _S2CINT( d2384 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3217; L3216: X5 = scrt2__2b_2dtwo( d2384, _TSCP( 4 ) ); L3217: X3 = ambdacode__2ddisplay_cfffb4a9( X4, X5 ); POPSTACKTRACE( sc_cons( X2, X3 ) ); L3212: X3 = PAIR_CDR( f2383 ); X2 = ambdacode__2ddisplay_cfffb4a9( X3, d2384 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L3206: POPSTACKTRACE( EMPTYLIST ); } DEFTSCP( ambdacode__2dclosure_56745b5_v ); DEFCSTRING( t3219, "CLOSED-PROC-CLOSURE" ); TSCP ambdacode__2dclosure_56745b5( i2410 ) TSCP i2410; { TSCP X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3219 ); X2 = SYMBOL_VALUE( indirect_2dlambda_2dlexical_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( i2410, PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3222; X4 = X1; X5 = EMPTYLIST; X6 = EMPTYLIST; L3225: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3226; X3 = X5; goto L3234; L3226: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3229; scrt1__24__car_2derror( X4 ); L3229: X9 = PAIR_CAR( X4 ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( c2394, CONS( plist_get( X9, c2218 ), X10 ) ); X7 = sc_cons( X8, EMPTYLIST ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L3233; X8 = PAIR_CDR( X4 ); X6 = X7; X5 = X7; X4 = X8; GOBACK( L3225 ); L3233: X8 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3238; scdebug_error( c2205, c2206, CONS( X6, EMPTYLIST ) ); L3238: X6 = SETGEN( PAIR_CDR( X6 ), X7 ); X4 = X8; GOBACK( L3225 ); L3234: X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_append_2dtwo( X3, X4 ), EMPTYLIST ); X2 = CONS( scrt1_length( X1 ), X2 ); POPSTACKTRACE( scrt1_cons_2a( c2413, CONS( c2169, X2 ) ) ); L3222: POPSTACKTRACE( c2169 ); } DEFTSCP( ambdacode__2ddisplay_41b1bac7_v ); DEFCSTRING( t3240, "CLOSED-PROC-DISPLAY" ); EXTERNTSCPP( lambdacode_l2468, XAL2( TSCP, TSCP ) ); TSCP lambdacode_l2468( i2470, v2471 ) TSCP i2470, v2471; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside CLOSED-PROC-DISPLAY]" ); if ( FALSE( v2471 ) ) goto L3245; X1 = lap_use_2dlap_2dtemp( ); if ( EQ( TSCPTAG( v2471 ), PAIRTAG ) ) goto L3248; scrt1__24__car_2derror( v2471 ); L3248: X3 = PAIR_CAR( v2471 ); X2 = plist_get( X3, c2218 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( scrt1_cons_2a( c2394, CONS( X2, X5 ) ), X4 ); X3 = scrt1_cons_2a( c2165, CONS( expform_vname( X1 ), X4 ) ); lap_emit_2dlap( X3 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( i2470, X5 ); X4 = CONS( scrt1_cons_2a( c2475, CONS( expform_vname( DISPLAY( 0 ) ), X5 ) ), X4 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2165, CONS( scrt1_cons_2a( c2394, CONS( X2, X5 ) ), X4 ) ); lap_emit_2dlap( X3 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( expform_vname( X1 ), X4 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2165, CONS( scrt1_cons_2a( c2394, CONS( X2, X5 ) ), X4 ) ); if ( BITAND( BITOR( _S2CINT( i2470 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3251; X5 = _TSCP( IPLUS( _S2CINT( i2470 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3252; L3251: X5 = scrt2__2b_2dtwo( i2470, _TSCP( 4 ) ); L3252: X6 = PAIR_CDR( v2471 ); X4 = lambdacode_l2468( X5, X6 ); POPSTACKTRACE( sc_cons( X3, X4 ) ); L3245: POPSTACKTRACE( EMPTYLIST ); } TSCP ambdacode__2ddisplay_41b1bac7( i2462, c2463 ) TSCP i2462, c2463; { TSCP X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t3240 ); DISPLAY( 0 ) = c2463; X2 = SYMBOL_VALUE( indirect_2dlambda_2dlexical_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( i2462, PROCEDURE_CLOSURE( X2 ) ); SDVAL = lambdacode_l2468( _TSCP( 0 ), X1 ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } DEFTSCP( ambdacode_ace_2demit_561a03cc_v ); DEFCSTRING( t3254, "STACK-TRACE-EMIT" ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); TSCP ambdacode_ace_2demit_561a03cc( l2493 ) TSCP l2493; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3254 ); if ( FALSE( SYMBOL_VALUE( sc_2dstack_2dtrace_v ) ) ) goto L3256; X1 = plist_get( l2493, c2232 ); if ( FALSE( X1 ) ) goto L3268; X2 = plist_get( X1, c2509 ); X3 = SYMBOL_VALUE( current_2ddefine_2dname_v ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X3 ) ) ) goto L3268; X2 = plist_get( l2493, c2244 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2245 ) ) ) goto L3268; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = SYMBOL_VALUE( current_2ddefine_2dstring_v ); X2 = scrt1_cons_2a( c2519, CONS( expform_vname( X4 ), X3 ) ); POPSTACKTRACE( lap_emit_2dlap( X2 ) ); L3256: POPSTACKTRACE( FALSEVALUE ); L3268: X3 = CONS( c2534, EMPTYLIST ); X4 = SYMBOL_VALUE( current_2ddefine_2dname_v ); if ( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), SYMBOLTAG ) ) ) goto L3270; scdebug_error( c2525, c2526, CONS( X4, EMPTYLIST ) ); L3270: X3 = CONS( SYMBOL_NAME( X4 ), X3 ); X3 = CONS( c2529, X3 ); if ( FALSE( X1 ) ) goto L3272; X5 = plist_get( X1, c2509 ); if ( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), SYMBOLTAG ) ) ) goto L3275; scdebug_error( c2525, c2526, CONS( X5, EMPTYLIST ) ); L3275: X4 = SYMBOL_NAME( X5 ); goto L3273; L3272: X4 = expform_cname( l2493 ); L3273: X2 = scrt3_string_2dappend( CONS( X4, X3 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2519, CONS( scrt1_cons_2a( c2520, CONS( X2, X5 ) ), X4 ) ); POPSTACKTRACE( lap_emit_2dlap( X3 ) ); } DEFTSCP( ambdacode_ody_2dgenc_da78cf6b_v ); DEFCSTRING( t3278, "LAMBDA-BODY-GENC" ); EXTERNTSCP( gencode_e_2dlambda_7a3ae383_v ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( lambdacode_reserve_2ddisplay, XAL2( TSCP, TSCP ) ); EXTERNTSCP( lambdacode_reserve_2ddisplay_v ); EXTERNTSCPP( gencode_code_2dlabel, XAL1( TSCP ) ); EXTERNTSCP( gencode_code_2dlabel_v ); EXTERNTSCPP( ambdacode_ind_2dvars_b19ac457, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( ambdacode_ind_2dvars_b19ac457_v ); EXTERNTSCPP( ambdacode_ils_2dgenc_66c68d48, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( ambdacode_ils_2dgenc_66c68d48_v ); EXTERNTSCPP( gencode_exp_2dgenc, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( gencode_exp_2dgenc_v ); EXTERNTSCPP( lap_drop_2dlap_2dtemp, XAL1( TSCP ) ); EXTERNTSCP( lap_drop_2dlap_2dtemp_v ); TSCP ambdacode_ody_2dgenc_da78cf6b( l2539, e2540, v2541, v2542, b2543 ) TSCP l2539, e2540, v2541, v2542, b2543; { TSCP X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3278 ); l2539 = CONS( l2539, EMPTYLIST ); v2541 = CONS( v2541, EMPTYLIST ); v2542 = CONS( v2542, EMPTYLIST ); if ( NEQ( TSCPTAG( e2540 ), PAIRTAG ) ) goto L3280; X3 = PAIR_CAR( e2540 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2132 ) ) ); goto L3281; L3280: X2 = FALSEVALUE; L3281: if ( FALSE( X2 ) ) goto L3284; if ( EQ( TSCPTAG( e2540 ), PAIRTAG ) ) goto L3287; scrt1__24__cdr_2derror( e2540 ); L3287: X3 = PAIR_CDR( e2540 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3290; scrt1__24__car_2derror( X3 ); L3290: X1 = PAIR_CAR( X3 ); goto L3285; L3284: X1 = X2; L3285: X2 = gencode_e_2dlambda_7a3ae383_v; X3 = PAIR_CAR( l2539 ); X4 = gencode_free_2ddisplay_v; X5 = plist_get( X1, c2687 ); gencode_e_2dlambda_7a3ae383_v = X1; X6 = X5; L3298: if ( EQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L3299; if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3303; scrt1__24__car_2derror( X6 ); L3303: X7 = PAIR_CAR( X6 ); X10 = SYMBOL_VALUE( indirect_2dlambda_2dlexical_v ); X10 = UNKNOWNCALL( X10, 1 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( X7, PROCEDURE_CLOSURE( X10 ) ); X11 = plist_get( X7, c2250 ); X12 = plist_get( X7, c2608 ); X10 = scrt1_append_2dtwo( X11, X12 ); X8 = scrt1_append_2dtwo( X9, X10 ); X9 = X8; L3308: if ( EQ( _S2CUINT( X9 ), _S2CUINT( EMPTYLIST ) ) ) goto L3309; if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3313; scrt1__24__car_2derror( X9 ); L3313: X10 = PAIR_CAR( X9 ); if ( TRUE( scrt1_memq( X10, PAIR_CAR( v2541 ) ) ) ) goto L3316; X13 = sc_cons( X10, EMPTYLIST ); X12 = X13; X11 = scrt1_append_2dtwo( PAIR_CAR( v2541 ), X12 ); SETGEN( PAIR_CAR( v2541 ), X11 ); X11 = scrt1_append_2dtwo( PAIR_CAR( v2542 ), c2603 ); SETGEN( PAIR_CAR( v2542 ), X11 ); L3316: X9 = PAIR_CDR( X9 ); GOBACK( L3308 ); L3309: X6 = PAIR_CDR( X6 ); GOBACK( L3298 ); L3299: if ( FALSE( X5 ) ) goto L3324; if ( NEQ( _S2CUINT( PAIR_CAR( l2539 ) ), _S2CUINT( c2616 ) ) ) goto L3324; X6 = lap_use_2dlap_2dtemp( ); SETGEN( PAIR_CAR( l2539 ), X6 ); L3324: lambdacode_reserve_2ddisplay( PAIR_CAR( v2541 ), b2543 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2618, CONS( gencode_code_2dlabel( X1 ), X7 ) ); lap_emit_2dlap( X6 ); X6 = ambdacode_ind_2dvars_b19ac457( PAIR_CAR( v2541 ), PAIR_CAR( v2542 ), b2543 ); if ( NEQ( TSCPTAG( e2540 ), PAIRTAG ) ) goto L3327; X9 = PAIR_CAR( e2540 ); X8 = BOOLEAN( EQ( _S2CUINT( X9 ), _S2CUINT( c2132 ) ) ); goto L3328; L3327: X8 = FALSEVALUE; L3328: if ( FALSE( X8 ) ) goto L3331; if ( EQ( TSCPTAG( e2540 ), PAIRTAG ) ) goto L3334; scrt1__24__cdr_2derror( e2540 ); L3334: X9 = PAIR_CDR( e2540 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3337; scrt1__24__cdr_2derror( X9 ); L3337: X7 = PAIR_CDR( X9 ); goto L3332; L3331: X7 = X8; L3332: if ( NEQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L3340; ambdacode_ils_2dgenc_66c68d48( PAIR_CAR( l2539 ), e2540, X6 ); goto L3341; L3340: if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3344; scrt1__24__cdr_2derror( X7 ); L3344: if ( FALSE( PAIR_CDR( X7 ) ) ) goto L3346; X8 = PAIR_CAR( X7 ); gencode_exp_2dgenc( c2164, X8, X6 ); goto L3347; L3346: X8 = PAIR_CAR( X7 ); gencode_exp_2dgenc( PAIR_CAR( l2539 ), X8, X6 ); L3347: X7 = PAIR_CDR( X7 ); GOBACK( L3332 ); L3341: if ( EQ( _S2CUINT( PAIR_CAR( l2539 ) ), _S2CUINT( X3 ) ) ) goto L3351; X7 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( expform_vname( PAIR_CAR( l2539 ) ), X7 ); X6 = scrt1_cons_2a( c2165, CONS( expform_vname( X3 ), X7 ) ); lap_emit_2dlap( X6 ); lap_drop_2dlap_2dtemp( PAIR_CAR( l2539 ) ); L3351: gencode_free_2ddisplay_v = X4; gencode_e_2dlambda_7a3ae383_v = X2; if ( FALSE( X5 ) ) goto L3354; X8 = SYMBOL_VALUE( _tersection_b4e3b790_v ); X8 = UNKNOWNCALL( X8, 1 ); X7 = VIA( PROCEDURE_CODE( X8 ) )( X5, PROCEDURE_CLOSURE( X8 ) ); X6 = SYMBOL_VALUE( _ion_2dinfo_e0971c7d_v ); X6 = UNKNOWNCALL( X6, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X6 ) )( X7, PROCEDURE_CLOSURE( X6 ) ) ); L3354: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( ambdacode_ils_2dgenc_66c68d48_v ); DEFCSTRING( t3356, "LAMBDA-TAILS-GENC" ); EXTERNTSCPP( gencode_make_2dlabel, XAL0( ) ); EXTERNTSCP( gencode_make_2dlabel_v ); EXTERNTSCP( gencode_ion_2dinfo_f92fd619_v ); EXTERNTSCPP( lap_save_2dlap_2dtemps, XAL0( ) ); EXTERNTSCP( lap_save_2dlap_2dtemps_v ); EXTERNTSCPP( lap_restore_2dlap_2dtemps, XAL1( TSCP ) ); EXTERNTSCP( lap_restore_2dlap_2dtemps_v ); TSCP ambdacode_ils_2dgenc_66c68d48( l2720, e2721, b2722 ) TSCP l2720, e2721, b2722; { TSCP X19, X18, X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3356 ); if ( NEQ( TSCPTAG( e2721 ), PAIRTAG ) ) goto L3358; X3 = PAIR_CAR( e2721 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2132 ) ) ); goto L3359; L3358: X2 = FALSEVALUE; L3359: if ( FALSE( X2 ) ) goto L3362; if ( EQ( TSCPTAG( e2721 ), PAIRTAG ) ) goto L3365; scrt1__24__cdr_2derror( e2721 ); L3365: X3 = PAIR_CDR( e2721 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3368; scrt1__24__car_2derror( X3 ); L3368: X1 = PAIR_CAR( X3 ); goto L3363; L3362: X1 = X2; L3363: X2 = plist_get( X1, c2687 ); if ( FALSE( X2 ) ) goto L3372; if ( EQ( _S2CUINT( l2720 ), _S2CUINT( c2221 ) ) ) goto L3374; X3 = gencode_make_2dlabel( ); goto L3373; L3374: X3 = FALSEVALUE; goto L3373; L3372: X3 = FALSEVALUE; L3373: X4 = gencode_ion_2dinfo_f92fd619_v; X5 = X2; L3379: if ( EQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L3380; if ( FALSE( X3 ) ) goto L3383; X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2741, CONS( X3, X7 ) ); lap_emit_2dlap( X6 ); L3383: X6 = lap_save_2dlap_2dtemps( ); X7 = gencode_free_2ddisplay_v; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3388; scrt1__24__car_2derror( X5 ); L3388: X8 = PAIR_CAR( X5 ); X10 = plist_get( X8, c2250 ); X11 = plist_get( X8, c2608 ); X9 = scrt1_append_2dtwo( X10, X11 ); X10 = SYMBOL_VALUE( retrieve_2dcondition_2dinfo_v ); X10 = UNKNOWNCALL( X10, 1 ); gencode_ion_2dinfo_f92fd619_v = VIA( PROCEDURE_CODE( X10 ) )( X8, PROCEDURE_CLOSURE( X10 ) ); X10 = plist_get( X8, c2132 ); X12 = X9; X13 = EMPTYLIST; X14 = EMPTYLIST; L3393: if ( NEQ( _S2CUINT( X12 ), _S2CUINT( EMPTYLIST ) ) ) goto L3394; X11 = X13; goto L3405; L3394: if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L3397; scrt1__24__car_2derror( X12 ); L3397: X17 = PAIR_CAR( X12 ); X18 = plist_get( X17, c2218 ); if ( FALSE( X18 ) ) goto L3401; X19 = CONS( EMPTYLIST, EMPTYLIST ); X16 = scrt1_cons_2a( c2394, CONS( X18, X19 ) ); goto L3402; L3401: X16 = X17; L3402: X15 = sc_cons( X16, EMPTYLIST ); if ( NEQ( _S2CUINT( X13 ), _S2CUINT( EMPTYLIST ) ) ) goto L3404; X16 = PAIR_CDR( X12 ); X14 = X15; X13 = X15; X12 = X16; GOBACK( L3393 ); L3404: X16 = PAIR_CDR( X12 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L3409; scdebug_error( c2205, c2206, CONS( X14, EMPTYLIST ) ); L3409: X14 = SETGEN( PAIR_CDR( X14 ), X15 ); X12 = X16; GOBACK( L3393 ); L3405: ambdacode_ody_2dgenc_da78cf6b( l2720, X10, X9, X11, b2722 ); X10 = SYMBOL_VALUE( store_2dcondition_2dinfo_v ); X10 = UNKNOWNCALL( X10, 1 ); VIA( PROCEDURE_CODE( X10 ) )( X8, PROCEDURE_CLOSURE( X10 ) ); lap_restore_2dlap_2dtemps( X6 ); gencode_free_2ddisplay_v = X7; X5 = PAIR_CDR( X5 ); GOBACK( L3379 ); L3380: if ( FALSE( X3 ) ) goto L3412; X6 = CONS( EMPTYLIST, EMPTYLIST ); X5 = scrt1_cons_2a( c2618, CONS( X3, X6 ) ); lap_emit_2dlap( X5 ); L3412: POPSTACKTRACE( SET( gencode_ion_2dinfo_f92fd619_v, X4 ) ); } DEFTSCP( lambdacode_reserve_2ddisplay_v ); DEFCSTRING( t3414, "RESERVE-DISPLAY" ); EXTERNTSCPP( scrt2_max_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_max_2dtwo_v ); EXTERNTSCP( gencode_max_2ddisplay_v ); TSCP lambdacode_reserve_2ddisplay( v2855, b2856 ) TSCP v2855, b2856; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3414 ); X1 = v2855; L3417: if ( FALSE( X1 ) ) goto L3418; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3421; scrt1__24__car_2derror( X1 ); L3421: X2 = PAIR_CAR( X1 ); if ( FALSE( plist_get( X2, c2218 ) ) ) goto L3426; if ( TRUE( scrt1_memq( X2, b2856 ) ) ) goto L3426; X4 = gencode_free_2ddisplay_v; X5 = gencode_free_2ddisplay_v; if ( BITAND( BITOR( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3430; X6 = _TSCP( IPLUS( _S2CINT( X5 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L3431; L3430: X6 = scrt2__2b_2dtwo( X5, _TSCP( 4 ) ); L3431: gencode_free_2ddisplay_v = X6; X3 = X4; plist_put( X2, c2218, X3 ); L3426: X1 = PAIR_CDR( X1 ); GOBACK( L3417 ); L3418: X2 = SYMBOL_VALUE( lap_2dmax_2ddisplay_v ); X3 = gencode_free_2ddisplay_v; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X3 ) ), 3 ) ) goto L3435; if ( LTE( _S2CINT( X2 ), _S2CINT( X3 ) ) ) goto L3437; X4 = X2; goto L3436; L3437: X4 = X3; goto L3436; L3435: X4 = scrt2_max_2dtwo( X2, X3 ); L3436: SETGENTL( SYMBOL_VALUE( lap_2dmax_2ddisplay_v ), X4 ); X2 = gencode_max_2ddisplay_v; X3 = gencode_free_2ddisplay_v; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( X3 ) ), 3 ) ) goto L3440; if ( LTE( _S2CINT( X2 ), _S2CINT( X3 ) ) ) goto L3442; X4 = X2; goto L3441; L3442: X4 = X3; goto L3441; L3440: X4 = scrt2_max_2dtwo( X2, X3 ); L3441: POPSTACKTRACE( SET( gencode_max_2ddisplay_v, X4 ) ); } DEFTSCP( ambdacode_ind_2dvars_b19ac457_v ); DEFCSTRING( t3444, "LAMBDA-BIND-VARS" ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); TSCP ambdacode_ind_2dvars_b19ac457( v2907, v2908, b2909 ) TSCP v2907, v2908, b2909; { TSCP X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3444 ); X1 = v2907; X2 = v2908; X3 = b2909; L3447: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3448; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3452; scrt1__24__car_2derror( X2 ); L3452: X4 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3455; scrt1__24__car_2derror( X1 ); L3455: X5 = PAIR_CAR( X1 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2934 ) ) ) goto L3458; X6 = scrt1_memq( X5, X3 ); goto L3459; L3458: X6 = FALSEVALUE; L3459: if ( TRUE( X6 ) ) goto L3505; if ( FALSE( plist_get( X5, c2218 ) ) ) goto L3463; if ( EQ( _S2CUINT( X4 ), _S2CUINT( c2934 ) ) ) goto L3505; if ( FALSE( plist_get( X5, c2944 ) ) ) goto L3467; X8 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( c2169, X9 ); X8 = CONS( scrt1_cons_2a( c3019, CONS( expform_vname( X4 ), X9 ) ), X8 ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X7 = scrt1_cons_2a( c2165, CONS( scrt1_cons_2a( c2394, CONS( plist_get( X5, c2218 ), X9 ) ), X8 ) ); lap_emit_2dlap( X7 ); goto L3505; L3467: X8 = CONS( EMPTYLIST, EMPTYLIST ); X7 = scrt1_cons_2a( c2394, CONS( plist_get( X5, c2218 ), X8 ) ); if ( TRUE( scrt1_equal_3f( X4, X7 ) ) ) goto L3505; X8 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( expform_vname( X4 ), X8 ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X7 = scrt1_cons_2a( c2165, CONS( scrt1_cons_2a( c2394, CONS( plist_get( X5, c2218 ), X9 ) ), X8 ) ); lap_emit_2dlap( X7 ); goto L3505; L3463: X7 = plist_get( X5, c2944 ); if ( FALSE( X7 ) ) goto L3484; if ( FALSE( plist_get( X5, c2951 ) ) ) goto L3475; X8 = FALSEVALUE; goto L3476; L3475: X8 = TRUEVALUE; L3476: if ( TRUE( X8 ) ) goto L3481; X10 = plist_get( X5, c2951 ); X9 = plist_get( X10, c2111 ); if ( EQ( _S2CUINT( X9 ), _S2CUINT( c2106 ) ) ) goto L3481; L3484: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2934 ) ) ) goto L3486; if ( FALSE( plist_get( X5, c2951 ) ) ) goto L3488; X6 = FALSEVALUE; goto L3489; L3488: X6 = TRUEVALUE; L3489: if ( TRUE( X6 ) ) goto L3494; X8 = plist_get( X5, c2951 ); X7 = plist_get( X8, c2111 ); if ( EQ( _S2CUINT( X7 ), _S2CUINT( c2106 ) ) ) goto L3494; goto L3505; L3486: if ( EQ( _S2CUINT( X5 ), _S2CUINT( X4 ) ) ) goto L3505; if ( TRUE( scrt1_memq( X5, X3 ) ) ) goto L3500; X6 = lap_use_2dlap_2dtemp( ); plist_put( X5, c2970, X6 ); L3500: X7 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( expform_vname( X4 ), X7 ); X6 = scrt1_cons_2a( c2165, CONS( expform_vname( X5 ), X7 ) ); lap_emit_2dlap( X6 ); goto L3505; L3494: X6 = lap_use_2dlap_2dtemp( ); plist_put( X5, c2970, X6 ); goto L3505; L3481: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2934 ) ) ) goto L3502; X6 = lap_use_2dlap_2dtemp( ); plist_put( X5, c2970, X6 ); goto L3505; L3502: if ( FALSE( scrt1_memq( X5, X3 ) ) ) goto L3504; X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( c2169, X8 ); X7 = CONS( scrt1_cons_2a( c2992, CONS( expform_vname( X4 ), X8 ) ), X7 ); X6 = scrt1_cons_2a( c2165, CONS( expform_vname( X5 ), X7 ) ); lap_emit_2dlap( X6 ); goto L3505; L3504: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( X4 ) ) ) goto L3506; X7 = X4; goto L3507; L3506: X7 = lap_use_2dlap_2dtemp( ); L3507: X6 = plist_get( X7, c2970 ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( c2169, X9 ); X8 = CONS( scrt1_cons_2a( c2992, CONS( expform_vname( X4 ), X9 ) ), X8 ); X7 = scrt1_cons_2a( c2165, CONS( X6, X8 ) ); lap_emit_2dlap( X7 ); plist_put( X5, c2970, X6 ); L3505: X4 = PAIR_CDR( X1 ); X5 = PAIR_CDR( X2 ); X6 = PAIR_CAR( X1 ); if ( TRUE( scrt1_memq( X6, X3 ) ) ) goto L3512; X6 = PAIR_CAR( X1 ); X3 = sc_cons( X6, X3 ); L3512: X2 = X5; X1 = X4; GOBACK( L3447 ); L3448: POPSTACKTRACE( X3 ); } void scrt3__init(); void scrt2__init(); void scdebug__init(); void lap__init(); void expform__init(); void gencode__init(); void plist__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt3__init(); scrt2__init(); scdebug__init(); lap__init(); expform__init(); gencode__init(); plist__init(); scrt1__init(); MAXDISPLAY( 1 ); } void lambdacode__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(lambdacode SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3099, ADR( lambdacode__24lambda_2dgenc_v ), MAKEPROCEDURE( 3, 0, lambdacode__24lambda_2dgenc, EMPTYLIST ) ); INITIALIZEVAR( t3119, ADR( lambdacode_procedure_2demit_v ), MAKEPROCEDURE( 4, 0, lambdacode_procedure_2demit, EMPTYLIST ) ); INITIALIZEVAR( t3152, ADR( ambdacode_ure_2demit_8ce41db4_v ), MAKEPROCEDURE( 4, 0, ambdacode_ure_2demit_8ce41db4, EMPTYLIST ) ); INITIALIZEVAR( t3204, ADR( ambdacode__2ddisplay_cfffb4a9_v ), MAKEPROCEDURE( 2, 0, ambdacode__2ddisplay_cfffb4a9, EMPTYLIST ) ); INITIALIZEVAR( t3219, ADR( ambdacode__2dclosure_56745b5_v ), MAKEPROCEDURE( 1, 0, ambdacode__2dclosure_56745b5, EMPTYLIST ) ); INITIALIZEVAR( t3240, ADR( ambdacode__2ddisplay_41b1bac7_v ), MAKEPROCEDURE( 2, 0, ambdacode__2ddisplay_41b1bac7, EMPTYLIST ) ); INITIALIZEVAR( t3254, ADR( ambdacode_ace_2demit_561a03cc_v ), MAKEPROCEDURE( 1, 0, ambdacode_ace_2demit_561a03cc, EMPTYLIST ) ); INITIALIZEVAR( t3278, ADR( ambdacode_ody_2dgenc_da78cf6b_v ), MAKEPROCEDURE( 5, 0, ambdacode_ody_2dgenc_da78cf6b, EMPTYLIST ) ); INITIALIZEVAR( t3356, ADR( ambdacode_ils_2dgenc_66c68d48_v ), MAKEPROCEDURE( 3, 0, ambdacode_ils_2dgenc_66c68d48, EMPTYLIST ) ); INITIALIZEVAR( t3414, ADR( lambdacode_reserve_2ddisplay_v ), MAKEPROCEDURE( 2, 0, lambdacode_reserve_2ddisplay, EMPTYLIST ) ); INITIALIZEVAR( t3444, ADR( ambdacode_ind_2dvars_b19ac457_v ), MAKEPROCEDURE( 3, 0, ambdacode_ind_2dvars_b19ac457, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/lambdacode.sc000066400000000000000000000271261203736146400171460ustar00rootroot00000000000000;;; Code generator for $lambda expressions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module lambdacode) ;;; External and in-line declarations. (include "plist.sch") (include "expform.sch") (include "lambdaexp.sch") (include "miscexp.sch") (include "gencode.sch") (include "lap.sch") ;;; ($lambda id body) ==> just about anything. ;;; ;;; The first part of lambda code generation is to decide whether the code is ;;; really going to be generated at this place. If it is, then the actual ;;; code generation will be done in PROCEDURE-EMIT or CLOSED-PROCEDURE-EMIT. ;;; Functions which are identified as INLINE-TAIL will have their label ;;; allocated here. Their code will be generated in LAMBDA-TAILS-GENC. (define ($LAMBDA-GENC loc exp bindings) (let* ((id ($lambda-id exp)) (generate (lambda-generate id))) (cond ((eq? generate 'procedure) (procedure-emit loc id exp bindings)) ((eq? generate 'closed-procedure) (closed-procedure-emit loc id exp bindings))))) ;;; The most straight forward case to generate is that of a procedure which ;;; does not have a closure pointer. (define (PROCEDURE-EMIT loc id exp bindings) (let* ((req (lambda-reqvars id)) (opt (optional-args id)) (formals (append req (if opt (list opt) '()))) (name (cname id)) (save-lap '()) (top (eq? (lambda-nestin id) 'top-level))) (if (not (eq? loc 'no-value)) (emit-lap `(SET ,(vname loc) ("MAKEPROCEDURE" ,(length req) ,(if opt 1 0) ,(cname name) "EMPTYLIST")))) (set! save-lap (save-current-lap '())) (emit-lap `(PROC ,(cname name) ,@(map vname formals))) (emit-lap '(LIT "{")) (emit-lap '(INDENT 8)) (emit-lap `(LOCALS DISPLAY ,free-display)) (stack-trace-emit id) (lambda-body-genc 'return exp formals (proc-args-to-display formals free-display) bindings) (emit-lap `(INDENT 0)) (emit-lap '(LIT "}")) (if (not (null? (lambda-name id))) (set-id-external! (lambda-name id) #t)) (done-lap (save-current-lap save-lap)))) ;;; The next type of procedure to emit is one which is closed over its free ;;; variables. The pointer to the closure will be added as the last argument ;;; to the function. (define (CLOSED-PROCEDURE-EMIT loc id exp bindings) (let* ((req (lambda-reqvars id)) (opt (optional-args id)) (closep (newv 'close 'use 'closurep 'display (lambda-display-closep id))) (formals (append req (append (if opt (list opt) '()) (list closep)))) (name (cname id)) (save-lap '())) (emit-lap `(SET ,(vname loc) ("MAKEPROCEDURE" ,(length req) ,(if opt 1 0) ,(cname name) ,(closed-proc-closure id)))) (set! save-lap (save-current-lap '())) (emit-lap `(PROC ,(cname name) ,@(map vname formals))) (emit-lap '(LIT "{")) (emit-lap '(INDENT 8)) (emit-lap `(LOCALS DISPLAY ,free-display)) (stack-trace-emit id) (let ((restore (closed-proc-display id closep))) (if restore (let ((temp (use-lap-temp))) (lambda-body-genc temp exp formals (proc-args-to-display formals free-display) bindings) (map emit-lap restore) (emit-lap `(SET return ,(vname temp)))) (lambda-body-genc 'return exp formals formals bindings))) (emit-lap `(INDENT 0)) (emit-lap '(LIT "}")) (if (not (null? (lambda-name id))) (set-id-external! (lambda-name id) #t)) (done-lap (save-current-lap save-lap)))) ;;; The following function is called to load procedure arguments into their ;;; appropriate display slots. It will return a list of the locations holding ;;; the values to be bound to the variables, for use by lambda-body-genc. (define (PROC-ARGS-TO-DISPLAY formals displayx) (if formals (let ((var (car formals))) (if (id-display var) (begin (emit-lap `(SET ("DISPLAY" ,displayx) ,(vname var))) (cons `("DISPLAY" ,displayx) (proc-args-to-display (cdr formals) (+ displayx 1)))) (cons var (proc-args-to-display (cdr formals) displayx)))) '())) ;;; The following function is called to make code for creating a closure ;;; with copies of the appropriate slots in the display. (define (CLOSED-PROC-CLOSURE id) (let ((lexvars (indirect-lambda-lexical id))) (if lexvars `("MAKECLOSURE" "EMPTYLIST" ,(length lexvars) ,@(map (lambda (v) `("DISPLAY" ,(id-display v))) lexvars)) "EMPTYLIST"))) ;;; The following function emits code to save the appropriate portions of the ;;; display. It will return code to restore the display. (define (CLOSED-PROC-DISPLAY id closep) (let loop ((i 0) (vars (indirect-lambda-lexical id))) (if vars (let ((temp (use-lap-temp)) (displayx (id-display (car vars)))) (emit-lap `(SET ,(vname temp) ("DISPLAY" ,displayx))) (emit-lap `(SET ("DISPLAY" ,displayx) ("CLOSURE_VAR" ,(vname closep) ,i))) (cons `(SET ("DISPLAY" ,displayx) ,(vname temp)) (loop (+ i 1) (cdr vars)))) '()))) ;;; Code for the stack trace-back is emitted by the following routine when ;;; SC-STACK-TRACE is true. (define (STACK-TRACE-EMIT lid) (if sc-stack-trace (let ((id (lambda-name lid))) (if (and id (eq? (id-printname id) current-define-name) (eq? (lambda-nestin lid) 'top-level)) (emit-lap `(PUSHSTACKTRACE ,(vname current-define-string))) (let ((name (string-append (if id (symbol->string (id-printname id)) (cname lid)) " [inside " (symbol->string current-define-name) "]"))) (emit-lap `(PUSHSTACKTRACE (CSTRING ,name)))))))) ;;; Code for $LAMBDA bodies is generated by the following function. Any ;;; lambda bodies that are designated as "inline-tails" will have their ;;; lambda variables allocated and deallocated here. Any lexical variables ;;; that they reference will also be allocated here. (define (LAMBDA-BODY-GENC loc exp vars vals bindings) (let* ((id ($lambda-id exp)) (save-current-code-lambda current-code-lambda) (save-loc loc) (save-free-display free-display) (tails (lambda-inline-tails id))) (set! current-code-lambda id) (for-each (lambda (lid) (for-each (lambda (var) (unless (memq var vars) (set! vars (append vars (list var))) (set! vals (append vals '(undefined))))) (append (indirect-lambda-lexical lid) (append (lambda-reqvars lid) (lambda-optvars lid))))) tails) (if (and tails (eq? loc 'tos)) (set! loc (use-lap-temp))) (reserve-display vars bindings) (emit-lap `(LABEL ,(code-label id))) (do ((bindings (lambda-bind-vars vars vals bindings)) (expl ($lambda-body exp) (cdr expl))) ((null? expl) (lambda-tails-genc loc exp bindings)) (if (cdr expl) (exp-genc 'no-value (car expl) bindings) (exp-genc loc (car expl) bindings))) (when (not (eq? loc save-loc)) (emit-lap `(SET ,(vname save-loc) ,(vname loc))) (drop-lap-temp loc)) (set! free-display save-free-display) (set! current-code-lambda save-current-code-lambda) (if tails (intersect-with-global-condition-info (stored-conditions-intersection tails))))) ;;; Code for lambda expressions which are INLINE-TAIL's is generated after the ;;; code for the lambda body which they exit by this function. (define (LAMBDA-TAILS-GENC loc exp bindings) (let* ((id ($lambda-id exp)) (tails (lambda-inline-tails id)) (next (if (and tails (not (eq? loc 'return))) (make-label) #f)) (save-condition global-condition-info)) (do ((tails tails (cdr tails))) ((null? tails)) (if next (emit-lap `(GOTO ,next))) (let* ((save-temp (save-lap-temps)) (save-display free-display) (tail (car tails)) (vars (append (lambda-reqvars tail) (lambda-optvars tail)))) (set! global-condition-info (retrieve-condition-info tail)) (lambda-body-genc loc (lambda-$lambda tail) vars (map (lambda (var) (let ((x (id-display var))) (if x `("DISPLAY" ,x) var))) vars) bindings) (store-condition-info tail) (restore-lap-temps save-temp) (set! free-display save-display))) (if next (emit-lap `(LABEL ,next))) (set! global-condition-info save-condition))) ;;; The following function is called to allocate variables to the display. (define (RESERVE-DISPLAY vars bindings) (let loop ((vars vars)) (if vars (let ((var (car vars))) (if (and (id-display var) (not (memq var bindings))) (let ((displayx (let ((x free-display)) (set! free-display (+ free-display 1)) x))) (set-id-display! var displayx))) (loop (cdr vars))) (begin (set! lap-max-display (max lap-max-display free-display)) (set! max-display (max max-display free-display)))))) ;;; Variables are bound by calling the following function with the variables, ;;; the cells holding their initial values, and the current bindings. It ;;; will return the new bindings, which is a list of variables which are ;;; currently bound to the value held in either a display slot or a temporary. (define (LAMBDA-BIND-VARS vars vals bindings) (do ((vars vars (cdr vars)) (vals vals (cdr vals)) (bindings bindings (if (memq (car vars) bindings) bindings (cons (car vars) bindings)))) ((null? vals) bindings) (let ((var (car vars)) (val (car vals))) (cond ((and (eq? val 'undefined) (memq var bindings))) ((id-display var) (cond ((eq? val 'undefined)) ((id-set! var) (emit-lap `(SET ("DISPLAY" ,(id-display var)) (CONS ,(vname val) "EMPTYLIST")))) ((not (equal? val `("DISPLAY" ,(id-display var)))) (emit-lap `(SET ("DISPLAY" ,(id-display var)) ,(vname val)))))) ((and (id-set! var) (or (not (id-lambda var)) (eq? (lambda-generate (id-lambda var)) 'closed-procedure))) (cond ((eq? val 'undefined) (set-id-vname! var (use-lap-temp))) ((memq var bindings) (emit-lap `(SET ,(vname var) ("CONS" ,(vname val) "EMPTYLIST")))) (else (let ((vn (id-vname (if (eq? var val) val (use-lap-temp))))) (emit-lap `(SET ,vn ("CONS" ,(vname val) "EMPTYLIST"))) (set-id-vname! var vn))))) ((eq? val 'undefined) (if (or (not (id-lambda var)) (eq? (lambda-generate (id-lambda var)) 'closed-procedure)) (set-id-vname! var (use-lap-temp)))) ((not (eq? var val)) (if (not (memq var bindings)) (set-id-vname! var (use-lap-temp))) (emit-lap `(SET ,(vname var) ,(vname val)))))))) scheme2c-2012.10.14/scsc/lambdaexp.c000066400000000000000000001251061203736146400166420ustar00rootroot00000000000000 /* SCHEME->C */ #include void lambdaexp__init(); DEFSTATICTSCP( lexical_2dbound_2dvars_v ); DEFSTATICTSCP( lexical_2dfree_2dvars_v ); DEFSTATICTSCP( current_2dlambda_2did_v ); DEFSTATICTSCP( exp_2dform_2dlist_v ); DEFSTATICTSCP( newv_v ); DEFSTATICTSCP( expand_2derror_v ); DEFSTATICTSCP( assign_2dknown_2dname_v ); DEFSTATICTSCP( id_2dprintname_v ); DEFCSTRING( t2553, " CODE-LABEL: ~a~%" ); DEFSTATICTSCP( c2545 ); DEFCSTRING( t2554, " REAL-CALLS: ~a~%" ); DEFSTATICTSCP( c2542 ); DEFCSTRING( t2555, " TAIL-CALLS: ~a~%" ); DEFSTATICTSCP( c2539 ); DEFCSTRING( t2556, " STR-CALLS: ~a~%" ); DEFSTATICTSCP( c2536 ); DEFCSTRING( t2557, "INLINE-TAILS: ~a~%" ); DEFSTATICTSCP( c2533 ); DEFCSTRING( t2558, " EXITS: ~a~%" ); DEFSTATICTSCP( c2530 ); DEFCSTRING( t2559, " NESTIN: ~a~%" ); DEFSTATICTSCP( c2527 ); DEFCSTRING( t2560, " GENERATE: ~a ~a ~a~%" ); DEFSTATICTSCP( c2520 ); DEFCSTRING( t2561, " CALLS: ~a~%" ); DEFSTATICTSCP( c2517 ); DEFCSTRING( t2562, " LEXICAL: ~a~%" ); DEFSTATICTSCP( c2514 ); DEFCSTRING( t2563, " VARS: ~a ~a~%" ); DEFSTATICTSCP( c2509 ); DEFCSTRING( t2564, " LAMBDA-NAME: ~a ~a ~a~%" ); DEFSTATICTSCP( c2499 ); DEFSTATICTSCP( c2483 ); DEFSTATICTSCP( c2458 ); DEFSTATICTSCP( c2445 ); DEFSTATICTSCP( c2432 ); DEFSTATICTSCP( c2419 ); DEFSTATICTSCP( c2406 ); DEFSTATICTSCP( c2393 ); DEFSTATICTSCP( c2368 ); DEFSTATICTSCP( c2355 ); DEFSTATICTSCP( c2342 ); DEFSTATICTSCP( c2329 ); DEFCSTRING( t2565, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2283 ); DEFSTATICTSCP( c2282 ); DEFSTATICTSCP( c2157 ); DEFSTATICTSCP( c2130 ); DEFSTATICTSCP( c2097 ); DEFSTATICTSCP( c2086 ); DEFSTATICTSCP( c2077 ); DEFSTATICTSCP( c2076 ); DEFSTATICTSCP( c2073 ); DEFSTATICTSCP( c2054 ); DEFSTATICTSCP( c2053 ); DEFSTATICTSCP( c2052 ); DEFSTATICTSCP( c2039 ); DEFSTATICTSCP( c2025 ); static void init_constants() { lexical_2dbound_2dvars_v = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL-BO\ UND-VARS" ) ); CONSTANTEXP( ADR( lexical_2dbound_2dvars_v ) ); lexical_2dfree_2dvars_v = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL-FRE\ E-VARS" ) ); CONSTANTEXP( ADR( lexical_2dfree_2dvars_v ) ); current_2dlambda_2did_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-LAM\ BDA-ID" ) ); CONSTANTEXP( ADR( current_2dlambda_2did_v ) ); exp_2dform_2dlist_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXP-FORM-LIST" ) ); CONSTANTEXP( ADR( exp_2dform_2dlist_v ) ); newv_v = STRINGTOSYMBOL( CSTRING_TSCP( "NEWV" ) ); CONSTANTEXP( ADR( newv_v ) ); expand_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXPAND-ERROR" ) ); CONSTANTEXP( ADR( expand_2derror_v ) ); assign_2dknown_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "ASSIGN-KNOW\ N-NAME" ) ); CONSTANTEXP( ADR( assign_2dknown_2dname_v ) ); id_2dprintname_v = STRINGTOSYMBOL( CSTRING_TSCP( "ID-PRINTNAME" ) ); CONSTANTEXP( ADR( id_2dprintname_v ) ); c2545 = CSTRING_TSCP( t2553 ); CONSTANTEXP( ADR( c2545 ) ); c2542 = CSTRING_TSCP( t2554 ); CONSTANTEXP( ADR( c2542 ) ); c2539 = CSTRING_TSCP( t2555 ); CONSTANTEXP( ADR( c2539 ) ); c2536 = CSTRING_TSCP( t2556 ); CONSTANTEXP( ADR( c2536 ) ); c2533 = CSTRING_TSCP( t2557 ); CONSTANTEXP( ADR( c2533 ) ); c2530 = CSTRING_TSCP( t2558 ); CONSTANTEXP( ADR( c2530 ) ); c2527 = CSTRING_TSCP( t2559 ); CONSTANTEXP( ADR( c2527 ) ); c2520 = CSTRING_TSCP( t2560 ); CONSTANTEXP( ADR( c2520 ) ); c2517 = CSTRING_TSCP( t2561 ); CONSTANTEXP( ADR( c2517 ) ); c2514 = CSTRING_TSCP( t2562 ); CONSTANTEXP( ADR( c2514 ) ); c2509 = CSTRING_TSCP( t2563 ); CONSTANTEXP( ADR( c2509 ) ); c2499 = CSTRING_TSCP( t2564 ); CONSTANTEXP( ADR( c2499 ) ); c2483 = STRINGTOSYMBOL( CSTRING_TSCP( "NAME" ) ); CONSTANTEXP( ADR( c2483 ) ); c2458 = STRINGTOSYMBOL( CSTRING_TSCP( "CODE-LABEL" ) ); CONSTANTEXP( ADR( c2458 ) ); c2445 = STRINGTOSYMBOL( CSTRING_TSCP( "REAL-CALLS" ) ); CONSTANTEXP( ADR( c2445 ) ); c2432 = STRINGTOSYMBOL( CSTRING_TSCP( "TAIL-CALLS" ) ); CONSTANTEXP( ADR( c2432 ) ); c2419 = STRINGTOSYMBOL( CSTRING_TSCP( "STR-CALLS" ) ); CONSTANTEXP( ADR( c2419 ) ); c2406 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE-TAILS" ) ); CONSTANTEXP( ADR( c2406 ) ); c2393 = STRINGTOSYMBOL( CSTRING_TSCP( "EXITS" ) ); CONSTANTEXP( ADR( c2393 ) ); c2368 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY-CLOSEP" ) ); CONSTANTEXP( ADR( c2368 ) ); c2355 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED" ) ); CONSTANTEXP( ADR( c2355 ) ); c2342 = STRINGTOSYMBOL( CSTRING_TSCP( "GENERATE" ) ); CONSTANTEXP( ADR( c2342 ) ); c2329 = STRINGTOSYMBOL( CSTRING_TSCP( "CALLS" ) ); CONSTANTEXP( ADR( c2329 ) ); c2283 = CSTRING_TSCP( t2565 ); CONSTANTEXP( ADR( c2283 ) ); c2282 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2282 ) ); c2157 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c2157 ) ); c2130 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE" ) ); CONSTANTEXP( ADR( c2130 ) ); c2097 = STRINGTOSYMBOL( CSTRING_TSCP( "OPTVARS" ) ); CONSTANTEXP( ADR( c2097 ) ); c2086 = STRINGTOSYMBOL( CSTRING_TSCP( "REQVARS" ) ); CONSTANTEXP( ADR( c2086 ) ); c2077 = STRINGTOSYMBOL( CSTRING_TSCP( "BOUNDID" ) ); CONSTANTEXP( ADR( c2077 ) ); c2076 = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL" ) ); CONSTANTEXP( ADR( c2076 ) ); c2073 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA-VARIABLES" ) ); CONSTANTEXP( ADR( c2073 ) ); c2054 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2054 ) ); c2053 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2053 ) ); c2052 = STRINGTOSYMBOL( CSTRING_TSCP( "L" ) ); CONSTANTEXP( ADR( c2052 ) ); c2039 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); CONSTANTEXP( ADR( c2039 ) ); c2025 = STRINGTOSYMBOL( CSTRING_TSCP( "NESTIN" ) ); CONSTANTEXP( ADR( c2025 ) ); } DEFTSCP( lambdaexp_lambda_2dexp_v ); DEFCSTRING( t2566, "LAMBDA-EXP" ); EXTERNTSCPP( lambdaexp_lambda_2ddefines, XAL1( TSCP ) ); EXTERNTSCP( lambdaexp_lambda_2ddefines_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); EXTERNTSCPP( lambdaexp_ars_2dbind_5a7c2cf0, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( lambdaexp_ars_2dbind_5a7c2cf0_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); TSCP lambdaexp_lambda_2dexp( e2011, e2012 ) TSCP e2011, e2012; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2566 ); X1 = EMPTYLIST; X3 = SYMBOL_VALUE( newv_v ); X3 = UNKNOWNCALL( X3, 3 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( c2052, c2053, c2054, PROCEDURE_CLOSURE( X3 ) ); X3 = SYMBOL_VALUE( current_2dlambda_2did_v ); X4 = SYMBOL_VALUE( lexical_2dfree_2dvars_v ); X5 = SYMBOL_VALUE( lexical_2dbound_2dvars_v ); if ( EQ( TSCPTAG( e2011 ), PAIRTAG ) ) goto L2569; scrt1__24__cdr_2derror( e2011 ); L2569: X8 = PAIR_CDR( e2011 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L2572; scrt1__24__cdr_2derror( X8 ); L2572: X7 = PAIR_CDR( X8 ); X6 = lambdaexp_lambda_2ddefines( X7 ); X6 = CONS( X6, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); X7 = SYMBOL_VALUE( lexical_2dbound_2dvars_v ); X8 = SYMBOL_VALUE( lexical_2dfree_2dvars_v ); SETGENTL( SYMBOL_VALUE( lexical_2dfree_2dvars_v ), scrt1_append_2dtwo( X7, X8 ) ); SETGENTL( SYMBOL_VALUE( lexical_2dbound_2dvars_v ), EMPTYLIST ); X7 = SYMBOL_VALUE( current_2dlambda_2did_v ); plist_put( X2, c2025, X7 ); SETGENTL( SYMBOL_VALUE( current_2dlambda_2did_v ), X2 ); X8 = PAIR_CDR( e2011 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L2577; scrt1__24__car_2derror( X8 ); L2577: X7 = PAIR_CAR( X8 ); lambdaexp_ars_2dbind_5a7c2cf0( X7, PAIR_CAR( X6 ), X2 ); X8 = SYMBOL_VALUE( exp_2dform_2dlist_v ); X8 = UNKNOWNCALL( X8, 2 ); X7 = VIA( PROCEDURE_CODE( X8 ) )( PAIR_CAR( X6 ), e2012, PROCEDURE_CLOSURE( X8 ) ); SETGEN( PAIR_CAR( X6 ), X7 ); X9 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = CONS( scrt1_append_2dtwo( PAIR_CAR( X6 ), X9 ), EMPTYLIST ); X7 = scrt1_cons_2a( c2039, CONS( X2, X8 ) ); SETGEN( PAIR_CAR( X1 ), X7 ); SETGENTL( SYMBOL_VALUE( lexical_2dbound_2dvars_v ), X5 ); SETGENTL( SYMBOL_VALUE( lexical_2dfree_2dvars_v ), X4 ); SETGENTL( SYMBOL_VALUE( current_2dlambda_2did_v ), X3 ); POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( lambdaexp_ars_2dbind_5a7c2cf0_v ); DEFCSTRING( t2579, "LAMBDA-VARS-BIND" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); TSCP lambdaexp_ars_2dbind_5a7c2cf0( v2056, n2057, i2058 ) TSCP v2056, n2057, i2058; { TSCP X3, X2, X1; PUSHSTACKTRACE( t2579 ); v2056 = CONS( v2056, EMPTYLIST ); if ( EQ( _S2CUINT( PAIR_CAR( v2056 ) ), _S2CUINT( EMPTYLIST ) ) ) goto L2581; if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( v2056 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( v2056 ) ), SYMBOLTAG ) ) ) ) goto L2583; X2 = SYMBOL_VALUE( newv_v ); X2 = UNKNOWNCALL( X2, 5 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( PAIR_CAR( v2056 ), c2053, c2076, c2077, i2058, PROCEDURE_CLOSURE( X2 ) ); SETGEN( PAIR_CAR( v2056 ), X1 ); if ( FALSE( n2057 ) ) goto L2586; X1 = SYMBOL_VALUE( assign_2dknown_2dname_v ); X1 = UNKNOWNCALL( X1, 1 ); VIA( PROCEDURE_CODE( X1 ) )( PAIR_CAR( v2056 ), PROCEDURE_CLOSURE( X1 ) ); L2586: X2 = sc_cons( PAIR_CAR( v2056 ), EMPTYLIST ); X1 = X2; POPSTACKTRACE( plist_put( i2058, c2097, X1 ) ); L2583: if ( NEQ( TSCPTAG( PAIR_CAR( v2056 ) ), PAIRTAG ) ) goto L2589; X2 = PAIR_CAR( v2056 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2592; scrt1__24__car_2derror( X2 ); L2592: X1 = PAIR_CAR( X2 ); X1 = CONS( X1, EMPTYLIST ); X3 = SYMBOL_VALUE( newv_v ); X3 = UNKNOWNCALL( X3, 5 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( PAIR_CAR( X1 ), c2053, c2076, c2077, i2058, PROCEDURE_CLOSURE( X3 ) ); SETGEN( PAIR_CAR( X1 ), X2 ); if ( FALSE( n2057 ) ) goto L2595; X2 = SYMBOL_VALUE( assign_2dknown_2dname_v ); X2 = UNKNOWNCALL( X2, 1 ); VIA( PROCEDURE_CODE( X2 ) )( PAIR_CAR( X1 ), PROCEDURE_CLOSURE( X2 ) ); L2595: X3 = PAIR_CAR( v2056 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2598; scrt1__24__cdr_2derror( X3 ); L2598: X2 = PAIR_CDR( X3 ); lambdaexp_ars_2dbind_5a7c2cf0( X2, n2057, i2058 ); X3 = plist_get( i2058, c2086 ); X2 = sc_cons( PAIR_CAR( X1 ), X3 ); POPSTACKTRACE( plist_put( i2058, c2086, X2 ) ); L2589: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2073, PAIR_CAR( v2056 ), PROCEDURE_CLOSURE( X1 ) ) ); L2581: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( lambdaexp_lambda_2ddefines_v ); DEFCSTRING( t2600, "LAMBDA-DEFINES" ); EXTERNTSCPP( scrt1_caadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caadr_v ); EXTERNTSCPP( scrt1_cdadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdadr_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); EXTERNTSCPP( scrt4_vector_2d_3elist, XAL1( TSCP ) ); EXTERNTSCP( scrt4_vector_2d_3elist_v ); EXTERNTSCPP( sc_make_2dvector, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_make_2dvector_v ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); TSCP lambdaexp_lambda_2ddefines( b2101 ) TSCP b2101; { TSCP X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2600 ); X1 = b2101; X2 = EMPTYLIST; X3 = EMPTYLIST; X4 = EMPTYLIST; L2603: if ( FALSE( X1 ) ) goto L2604; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L2607; scrt1__24__car_2derror( X1 ); L2607: X5 = PAIR_CAR( X1 ); X6 = BOOLEAN( NEQ( TSCPTAG( X5 ), PAIRTAG ) ); if ( TRUE( X6 ) ) goto L2614; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L2618; scrt1__24__car_2derror( X5 ); L2618: X7 = PAIR_CAR( X5 ); if ( NEQ( _S2CUINT( X7 ), _S2CUINT( c2130 ) ) ) goto L2614; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L2623; scrt1__24__cdr_2derror( X5 ); L2623: X8 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L2626; scrt1__24__car_2derror( X8 ); L2626: X7 = PAIR_CAR( X8 ); if ( NEQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L2620; X7 = PAIR_CDR( X1 ); X9 = scrt1_caadr( X5 ); X8 = sc_cons( X9, X3 ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X13 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2631; scrt1__24__cdr_2derror( X13 ); L2631: X12 = PAIR_CDR( X13 ); X13 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X11 = CONS( scrt1_append_2dtwo( X12, X13 ), EMPTYLIST ); X10 = CONS( scrt1_cons_2a( c2054, CONS( scrt1_cdadr( X5 ), X11 ) ), X10 ); X9 = scrt1_cons_2a( c2157, CONS( scrt1_caadr( X5 ), X10 ) ); X4 = sc_cons( X9, X4 ); X3 = X8; X1 = X7; GOBACK( L2603 ); L2620: X7 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L2635; scrt1__24__cdr_2derror( X5 ); L2635: X10 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L2638; scrt1__24__car_2derror( X10 ); L2638: X9 = PAIR_CAR( X10 ); X8 = sc_cons( X9, X3 ); X10 = PAIR_CDR( X5 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X9 = scrt1_cons_2a( c2157, CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ) ); X4 = sc_cons( X9, X4 ); X3 = X8; X1 = X7; GOBACK( L2603 ); L2604: if ( FALSE( X3 ) ) goto L2641; X9 = scrt1_reverse( X4 ); X12 = scrt1_reverse( X2 ); X13 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X11 = scrt1_append_2dtwo( X12, X13 ); X10 = scrt1_cons_2a( X11, EMPTYLIST ); X8 = CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ); X7 = scrt1_cons_2a( c2054, CONS( X3, X8 ) ); X10 = scrt1_length( X3 ); X9 = sc_make_2dvector( X10, CONS( _TSCP( 0 ), EMPTYLIST ) ); X8 = scrt4_vector_2d_3elist( X9 ); X9 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( X7, CONS( scrt1_append_2dtwo( X8, X9 ), EMPTYLIST ) ); POPSTACKTRACE( scrt1_cons_2a( X6, CONS( EMPTYLIST, EMPTYLIST ) ) ); L2641: POPSTACKTRACE( b2101 ); L2614: X6 = PAIR_CDR( X1 ); X7 = sc_cons( X5, X2 ); X2 = X7; X1 = X6; GOBACK( L2603 ); } DEFTSCP( lambdaexp__24lambda_3f_v ); DEFCSTRING( t2644, "$LAMBDA?" ); TSCP lambdaexp__24lambda_3f( x2186 ) TSCP x2186; { TSCP X1; PUSHSTACKTRACE( t2644 ); if ( NEQ( TSCPTAG( x2186 ), PAIRTAG ) ) goto L2646; X1 = PAIR_CAR( x2186 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2039 ) ) ) ); L2646: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( lambdaexp__24lambda_2did_v ); DEFCSTRING( t2649, "$LAMBDA-ID" ); TSCP lambdaexp__24lambda_2did( x2204 ) TSCP x2204; { TSCP X2, X1; PUSHSTACKTRACE( t2649 ); if ( NEQ( TSCPTAG( x2204 ), PAIRTAG ) ) goto L2651; X2 = PAIR_CAR( x2204 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2039 ) ) ); goto L2652; L2651: X1 = FALSEVALUE; L2652: if ( FALSE( X1 ) ) goto L2655; if ( EQ( TSCPTAG( x2204 ), PAIRTAG ) ) goto L2658; scrt1__24__cdr_2derror( x2204 ); L2658: X2 = PAIR_CDR( x2204 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2661; scrt1__24__car_2derror( X2 ); L2661: POPSTACKTRACE( PAIR_CAR( X2 ) ); L2655: POPSTACKTRACE( X1 ); } DEFTSCP( lambdaexp__24lambda_2dbody_v ); DEFCSTRING( t2663, "$LAMBDA-BODY" ); TSCP lambdaexp__24lambda_2dbody( x2238 ) TSCP x2238; { TSCP X2, X1; PUSHSTACKTRACE( t2663 ); if ( NEQ( TSCPTAG( x2238 ), PAIRTAG ) ) goto L2665; X2 = PAIR_CAR( x2238 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2039 ) ) ); goto L2666; L2665: X1 = FALSEVALUE; L2666: if ( FALSE( X1 ) ) goto L2669; if ( EQ( TSCPTAG( x2238 ), PAIRTAG ) ) goto L2672; scrt1__24__cdr_2derror( x2238 ); L2672: X2 = PAIR_CDR( x2238 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2675; scrt1__24__cdr_2derror( X2 ); L2675: POPSTACKTRACE( PAIR_CDR( X2 ) ); L2669: POPSTACKTRACE( X1 ); } DEFTSCP( lambdaexp__2dbody_21_b7b60c74_v ); DEFCSTRING( t2677, "SET-$LAMBDA-BODY!" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP lambdaexp__2dbody_21_b7b60c74( x2272, b2273 ) TSCP x2272, b2273; { TSCP X1; PUSHSTACKTRACE( t2677 ); if ( EQ( TSCPTAG( x2272 ), PAIRTAG ) ) goto L2680; scrt1__24__cdr_2derror( x2272 ); L2680: X1 = PAIR_CDR( x2272 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L2683; scdebug_error( c2282, c2283, CONS( X1, EMPTYLIST ) ); L2683: POPSTACKTRACE( SETGEN( PAIR_CDR( X1 ), b2273 ) ); } DEFTSCP( lambdaexp_lambda_2dreqvars_v ); DEFCSTRING( t2685, "LAMBDA-REQVARS" ); TSCP lambdaexp_lambda_2dreqvars( i2290 ) TSCP i2290; { PUSHSTACKTRACE( t2685 ); POPSTACKTRACE( plist_get( i2290, c2086 ) ); } DEFTSCP( lambdaexp_reqvars_21_1ed68904_v ); DEFCSTRING( t2687, "SET-LAMBDA-REQVARS!" ); TSCP lambdaexp_reqvars_21_1ed68904( i2295, v2296 ) TSCP i2295, v2296; { PUSHSTACKTRACE( t2687 ); POPSTACKTRACE( plist_put( i2295, c2086, v2296 ) ); } DEFTSCP( lambdaexp_lambda_2doptvars_v ); DEFCSTRING( t2689, "LAMBDA-OPTVARS" ); TSCP lambdaexp_lambda_2doptvars( i2302 ) TSCP i2302; { PUSHSTACKTRACE( t2689 ); POPSTACKTRACE( plist_get( i2302, c2097 ) ); } DEFTSCP( lambdaexp_optvars_21_62318a06_v ); DEFCSTRING( t2691, "SET-LAMBDA-OPTVARS!" ); TSCP lambdaexp_optvars_21_62318a06( i2307, v2308 ) TSCP i2307, v2308; { PUSHSTACKTRACE( t2691 ); POPSTACKTRACE( plist_put( i2307, c2097, v2308 ) ); } DEFTSCP( lambdaexp_lambda_2dlexical_v ); DEFCSTRING( t2693, "LAMBDA-LEXICAL" ); TSCP lambdaexp_lambda_2dlexical( i2314 ) TSCP i2314; { PUSHSTACKTRACE( t2693 ); POPSTACKTRACE( plist_get( i2314, c2076 ) ); } DEFTSCP( lambdaexp_lexical_21_cb9ac4c3_v ); DEFCSTRING( t2695, "SET-LAMBDA-LEXICAL!" ); TSCP lambdaexp_lexical_21_cb9ac4c3( i2319, l2320 ) TSCP i2319, l2320; { PUSHSTACKTRACE( t2695 ); POPSTACKTRACE( plist_put( i2319, c2076, l2320 ) ); } DEFTSCP( lambdaexp_lambda_2dcalls_v ); DEFCSTRING( t2697, "LAMBDA-CALLS" ); TSCP lambdaexp_lambda_2dcalls( i2326 ) TSCP i2326; { PUSHSTACKTRACE( t2697 ); POPSTACKTRACE( plist_get( i2326, c2329 ) ); } DEFTSCP( lambdaexp_2dcalls_21_2e15beaf_v ); DEFCSTRING( t2699, "SET-LAMBDA-CALLS!" ); TSCP lambdaexp_2dcalls_21_2e15beaf( i2332, x2333 ) TSCP i2332, x2333; { PUSHSTACKTRACE( t2699 ); POPSTACKTRACE( plist_put( i2332, c2329, x2333 ) ); } DEFTSCP( lambdaexp_lambda_2dgenerate_v ); DEFCSTRING( t2701, "LAMBDA-GENERATE" ); TSCP lambdaexp_lambda_2dgenerate( i2339 ) TSCP i2339; { PUSHSTACKTRACE( t2701 ); POPSTACKTRACE( plist_get( i2339, c2342 ) ); } DEFTSCP( lambdaexp_enerate_21_9da1f848_v ); DEFCSTRING( t2703, "SET-LAMBDA-GENERATE!" ); TSCP lambdaexp_enerate_21_9da1f848( i2345, x2346 ) TSCP i2345, x2346; { PUSHSTACKTRACE( t2703 ); POPSTACKTRACE( plist_put( i2345, c2342, x2346 ) ); } DEFTSCP( lambdaexp_lambda_2dclosed_v ); DEFCSTRING( t2705, "LAMBDA-CLOSED" ); TSCP lambdaexp_lambda_2dclosed( i2352 ) TSCP i2352; { PUSHSTACKTRACE( t2705 ); POPSTACKTRACE( plist_get( i2352, c2355 ) ); } DEFTSCP( lambdaexp_dclosed_21_ec5c02cd_v ); DEFCSTRING( t2707, "SET-LAMBDA-CLOSED!" ); TSCP lambdaexp_dclosed_21_ec5c02cd( i2358, x2359 ) TSCP i2358, x2359; { PUSHSTACKTRACE( t2707 ); POPSTACKTRACE( plist_put( i2358, c2355, x2359 ) ); } DEFTSCP( lambdaexp_y_2dclosep_2ee78957_v ); DEFCSTRING( t2709, "LAMBDA-DISPLAY-CLOSEP" ); TSCP lambdaexp_y_2dclosep_2ee78957( i2365 ) TSCP i2365; { PUSHSTACKTRACE( t2709 ); POPSTACKTRACE( plist_get( i2365, c2368 ) ); } DEFTSCP( lambdaexp_dclosep_21_85634459_v ); DEFCSTRING( t2711, "SET-LAMBDA-DISPLAY-CLOSEP!" ); TSCP lambdaexp_dclosep_21_85634459( i2371, x2372 ) TSCP i2371, x2372; { PUSHSTACKTRACE( t2711 ); POPSTACKTRACE( plist_put( i2371, c2368, x2372 ) ); } DEFTSCP( lambdaexp_lambda_2dnestin_v ); DEFCSTRING( t2713, "LAMBDA-NESTIN" ); TSCP lambdaexp_lambda_2dnestin( i2378 ) TSCP i2378; { PUSHSTACKTRACE( t2713 ); POPSTACKTRACE( plist_get( i2378, c2025 ) ); } DEFTSCP( lambdaexp_dnestin_21_156a35d6_v ); DEFCSTRING( t2715, "SET-LAMBDA-NESTIN!" ); TSCP lambdaexp_dnestin_21_156a35d6( i2383, n2384 ) TSCP i2383, n2384; { PUSHSTACKTRACE( t2715 ); POPSTACKTRACE( plist_put( i2383, c2025, n2384 ) ); } DEFTSCP( lambdaexp_lambda_2dexits_v ); DEFCSTRING( t2717, "LAMBDA-EXITS" ); TSCP lambdaexp_lambda_2dexits( i2390 ) TSCP i2390; { PUSHSTACKTRACE( t2717 ); POPSTACKTRACE( plist_get( i2390, c2393 ) ); } DEFTSCP( lambdaexp_2dexits_21_1a6123c5_v ); DEFCSTRING( t2719, "SET-LAMBDA-EXITS!" ); TSCP lambdaexp_2dexits_21_1a6123c5( i2396, e2397 ) TSCP i2396, e2397; { PUSHSTACKTRACE( t2719 ); POPSTACKTRACE( plist_put( i2396, c2393, e2397 ) ); } DEFTSCP( lambdaexp_ne_2dtails_e7422159_v ); DEFCSTRING( t2721, "LAMBDA-INLINE-TAILS" ); TSCP lambdaexp_ne_2dtails_e7422159( i2403 ) TSCP i2403; { PUSHSTACKTRACE( t2721 ); POPSTACKTRACE( plist_get( i2403, c2406 ) ); } DEFTSCP( lambdaexp_2dtails_21_60af0e8d_v ); DEFCSTRING( t2723, "SET-LAMBDA-INLINE-TAILS!" ); TSCP lambdaexp_2dtails_21_60af0e8d( i2409, t2410 ) TSCP i2409, t2410; { PUSHSTACKTRACE( t2723 ); POPSTACKTRACE( plist_put( i2409, c2406, t2410 ) ); } DEFTSCP( lambdaexp_tr_2dcalls_63782d98_v ); DEFCSTRING( t2725, "LAMBDA-STR-CALLS" ); TSCP lambdaexp_tr_2dcalls_63782d98( i2416 ) TSCP i2416; { PUSHSTACKTRACE( t2725 ); POPSTACKTRACE( plist_get( i2416, c2419 ) ); } DEFTSCP( lambdaexp_2dcalls_21_6fe7acf4_v ); DEFCSTRING( t2727, "SET-LAMBDA-STR-CALLS!" ); TSCP lambdaexp_2dcalls_21_6fe7acf4( i2422, x2423 ) TSCP i2422, x2423; { PUSHSTACKTRACE( t2727 ); POPSTACKTRACE( plist_put( i2422, c2419, x2423 ) ); } DEFTSCP( lambdaexp_il_2dcalls_76e98af_v ); DEFCSTRING( t2729, "LAMBDA-TAIL-CALLS" ); TSCP lambdaexp_il_2dcalls_76e98af( i2429 ) TSCP i2429; { PUSHSTACKTRACE( t2729 ); POPSTACKTRACE( plist_get( i2429, c2432 ) ); } DEFTSCP( lambdaexp_2dcalls_21_a9a74c24_v ); DEFCSTRING( t2731, "SET-LAMBDA-TAIL-CALLS!" ); TSCP lambdaexp_2dcalls_21_a9a74c24( i2435, x2436 ) TSCP i2435, x2436; { PUSHSTACKTRACE( t2731 ); POPSTACKTRACE( plist_put( i2435, c2432, x2436 ) ); } DEFTSCP( lambdaexp_al_2dcalls_4b5d0e39_v ); DEFCSTRING( t2733, "LAMBDA-REAL-CALLS" ); TSCP lambdaexp_al_2dcalls_4b5d0e39( i2442 ) TSCP i2442; { PUSHSTACKTRACE( t2733 ); POPSTACKTRACE( plist_get( i2442, c2445 ) ); } DEFTSCP( lambdaexp_2dcalls_21_c8f2c4a0_v ); DEFCSTRING( t2735, "SET-LAMBDA-REAL-CALLS!" ); TSCP lambdaexp_2dcalls_21_c8f2c4a0( i2448, x2449 ) TSCP i2448, x2449; { PUSHSTACKTRACE( t2735 ); POPSTACKTRACE( plist_put( i2448, c2445, x2449 ) ); } DEFTSCP( lambdaexp_de_2dlabel_a0c18656_v ); DEFCSTRING( t2737, "LAMBDA-CODE-LABEL" ); TSCP lambdaexp_de_2dlabel_a0c18656( i2455 ) TSCP i2455; { PUSHSTACKTRACE( t2737 ); POPSTACKTRACE( plist_get( i2455, c2458 ) ); } DEFTSCP( lambdaexp_2dlabel_21_819a857a_v ); DEFCSTRING( t2739, "SET-LAMBDA-CODE-LABEL!" ); TSCP lambdaexp_2dlabel_21_819a857a( i2461, x2462 ) TSCP i2461, x2462; { PUSHSTACKTRACE( t2739 ); POPSTACKTRACE( plist_put( i2461, c2458, x2462 ) ); } DEFTSCP( lambdaexp_lambda_2d_24lambda_v ); DEFCSTRING( t2741, "LAMBDA-$LAMBDA" ); TSCP lambdaexp_lambda_2d_24lambda( i2468 ) TSCP i2468; { PUSHSTACKTRACE( t2741 ); POPSTACKTRACE( plist_get( i2468, c2039 ) ); } DEFTSCP( lambdaexp_4lambda_21_cedc504f_v ); DEFCSTRING( t2743, "SET-LAMBDA-$LAMBDA!" ); TSCP lambdaexp_4lambda_21_cedc504f( i2473, e2474 ) TSCP i2473, e2474; { PUSHSTACKTRACE( t2743 ); POPSTACKTRACE( plist_put( i2473, c2039, e2474 ) ); } DEFTSCP( lambdaexp_lambda_2dname_v ); DEFCSTRING( t2745, "LAMBDA-NAME" ); TSCP lambdaexp_lambda_2dname( i2480 ) TSCP i2480; { PUSHSTACKTRACE( t2745 ); POPSTACKTRACE( plist_get( i2480, c2483 ) ); } DEFTSCP( lambdaexp__2dname_21_f801d262_v ); DEFCSTRING( t2747, "SET-LAMBDA-NAME!" ); TSCP lambdaexp__2dname_21_f801d262( i2486, x2487 ) TSCP i2486, x2487; { PUSHSTACKTRACE( t2747 ); POPSTACKTRACE( plist_put( i2486, c2483, x2487 ) ); } DEFTSCP( lambdaexp_bda_2dinfo_dbd81905_v ); DEFCSTRING( t2749, "PRINT-LAMBDA-INFO" ); EXTERNTSCPP( scrt5_current_2doutput_2dport, XAL0( ) ); EXTERNTSCP( scrt5_current_2doutput_2dport_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); TSCP lambdaexp_bda_2dinfo_dbd81905( i2493, o2494 ) TSCP i2493, o2494; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t2749 ); o2494 = CONS( o2494, EMPTYLIST ); if ( FALSE( PAIR_CAR( o2494 ) ) ) goto L2751; X2 = PAIR_CAR( o2494 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2754; scrt1__24__car_2derror( X2 ); L2754: X1 = PAIR_CAR( X2 ); SETGEN( PAIR_CAR( o2494 ), X1 ); goto L2752; L2751: X1 = scrt5_current_2doutput_2dport( ); SETGEN( PAIR_CAR( o2494 ), X1 ); L2752: X4 = plist_get( i2493, c2483 ); if ( FALSE( X4 ) ) goto L2757; X3 = X4; goto L2758; L2757: X3 = i2493; L2758: X2 = SYMBOL_VALUE( id_2dprintname_v ); X2 = UNKNOWNCALL( X2, 1 ); X1 = CONS( VIA( PROCEDURE_CODE( X2 ) )( X3, PROCEDURE_CLOSURE( X2 ) ), EMPTYLIST ); X1 = CONS( i2493, X1 ); X1 = CONS( plist_get( i2493, c2483 ), X1 ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2499, X1 ) ); X1 = CONS( plist_get( i2493, c2097 ), EMPTYLIST ); X1 = CONS( plist_get( i2493, c2086 ), X1 ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2509, X1 ) ); X1 = CONS( plist_get( i2493, c2076 ), EMPTYLIST ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2514, X1 ) ); X1 = CONS( plist_get( i2493, c2329 ), EMPTYLIST ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2517, X1 ) ); X1 = CONS( plist_get( i2493, c2368 ), EMPTYLIST ); X1 = CONS( plist_get( i2493, c2355 ), X1 ); X1 = CONS( plist_get( i2493, c2342 ), X1 ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2520, X1 ) ); X1 = CONS( plist_get( i2493, c2025 ), EMPTYLIST ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2527, X1 ) ); X1 = CONS( plist_get( i2493, c2393 ), EMPTYLIST ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2530, X1 ) ); X1 = CONS( plist_get( i2493, c2406 ), EMPTYLIST ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2533, X1 ) ); X1 = CONS( plist_get( i2493, c2419 ), EMPTYLIST ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2536, X1 ) ); X1 = CONS( plist_get( i2493, c2432 ), EMPTYLIST ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2539, X1 ) ); X1 = CONS( plist_get( i2493, c2445 ), EMPTYLIST ); scrt6_format( PAIR_CAR( o2494 ), CONS( c2542, X1 ) ); X1 = CONS( plist_get( i2493, c2458 ), EMPTYLIST ); POPSTACKTRACE( scrt6_format( PAIR_CAR( o2494 ), CONS( c2545, X1 ) ) ); } void scrt6__init(); void scrt5__init(); void scdebug__init(); void scrt4__init(); void plist__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt6__init(); scrt5__init(); scdebug__init(); scrt4__init(); plist__init(); scrt1__init(); MAXDISPLAY( 0 ); } void lambdaexp__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(lambdaexp SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2566, ADR( lambdaexp_lambda_2dexp_v ), MAKEPROCEDURE( 2, 0, lambdaexp_lambda_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t2579, ADR( lambdaexp_ars_2dbind_5a7c2cf0_v ), MAKEPROCEDURE( 3, 0, lambdaexp_ars_2dbind_5a7c2cf0, EMPTYLIST ) ); INITIALIZEVAR( t2600, ADR( lambdaexp_lambda_2ddefines_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2ddefines, EMPTYLIST ) ); INITIALIZEVAR( t2644, ADR( lambdaexp__24lambda_3f_v ), MAKEPROCEDURE( 1, 0, lambdaexp__24lambda_3f, EMPTYLIST ) ); INITIALIZEVAR( t2649, ADR( lambdaexp__24lambda_2did_v ), MAKEPROCEDURE( 1, 0, lambdaexp__24lambda_2did, EMPTYLIST ) ); INITIALIZEVAR( t2663, ADR( lambdaexp__24lambda_2dbody_v ), MAKEPROCEDURE( 1, 0, lambdaexp__24lambda_2dbody, EMPTYLIST ) ); INITIALIZEVAR( t2677, ADR( lambdaexp__2dbody_21_b7b60c74_v ), MAKEPROCEDURE( 2, 0, lambdaexp__2dbody_21_b7b60c74, EMPTYLIST ) ); INITIALIZEVAR( t2685, ADR( lambdaexp_lambda_2dreqvars_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2dreqvars, EMPTYLIST ) ); INITIALIZEVAR( t2687, ADR( lambdaexp_reqvars_21_1ed68904_v ), MAKEPROCEDURE( 2, 0, lambdaexp_reqvars_21_1ed68904, EMPTYLIST ) ); INITIALIZEVAR( t2689, ADR( lambdaexp_lambda_2doptvars_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2doptvars, EMPTYLIST ) ); INITIALIZEVAR( t2691, ADR( lambdaexp_optvars_21_62318a06_v ), MAKEPROCEDURE( 2, 0, lambdaexp_optvars_21_62318a06, EMPTYLIST ) ); INITIALIZEVAR( t2693, ADR( lambdaexp_lambda_2dlexical_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2dlexical, EMPTYLIST ) ); INITIALIZEVAR( t2695, ADR( lambdaexp_lexical_21_cb9ac4c3_v ), MAKEPROCEDURE( 2, 0, lambdaexp_lexical_21_cb9ac4c3, EMPTYLIST ) ); INITIALIZEVAR( t2697, ADR( lambdaexp_lambda_2dcalls_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2dcalls, EMPTYLIST ) ); INITIALIZEVAR( t2699, ADR( lambdaexp_2dcalls_21_2e15beaf_v ), MAKEPROCEDURE( 2, 0, lambdaexp_2dcalls_21_2e15beaf, EMPTYLIST ) ); INITIALIZEVAR( t2701, ADR( lambdaexp_lambda_2dgenerate_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2dgenerate, EMPTYLIST ) ); INITIALIZEVAR( t2703, ADR( lambdaexp_enerate_21_9da1f848_v ), MAKEPROCEDURE( 2, 0, lambdaexp_enerate_21_9da1f848, EMPTYLIST ) ); INITIALIZEVAR( t2705, ADR( lambdaexp_lambda_2dclosed_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2dclosed, EMPTYLIST ) ); INITIALIZEVAR( t2707, ADR( lambdaexp_dclosed_21_ec5c02cd_v ), MAKEPROCEDURE( 2, 0, lambdaexp_dclosed_21_ec5c02cd, EMPTYLIST ) ); INITIALIZEVAR( t2709, ADR( lambdaexp_y_2dclosep_2ee78957_v ), MAKEPROCEDURE( 1, 0, lambdaexp_y_2dclosep_2ee78957, EMPTYLIST ) ); INITIALIZEVAR( t2711, ADR( lambdaexp_dclosep_21_85634459_v ), MAKEPROCEDURE( 2, 0, lambdaexp_dclosep_21_85634459, EMPTYLIST ) ); INITIALIZEVAR( t2713, ADR( lambdaexp_lambda_2dnestin_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2dnestin, EMPTYLIST ) ); INITIALIZEVAR( t2715, ADR( lambdaexp_dnestin_21_156a35d6_v ), MAKEPROCEDURE( 2, 0, lambdaexp_dnestin_21_156a35d6, EMPTYLIST ) ); INITIALIZEVAR( t2717, ADR( lambdaexp_lambda_2dexits_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2dexits, EMPTYLIST ) ); INITIALIZEVAR( t2719, ADR( lambdaexp_2dexits_21_1a6123c5_v ), MAKEPROCEDURE( 2, 0, lambdaexp_2dexits_21_1a6123c5, EMPTYLIST ) ); INITIALIZEVAR( t2721, ADR( lambdaexp_ne_2dtails_e7422159_v ), MAKEPROCEDURE( 1, 0, lambdaexp_ne_2dtails_e7422159, EMPTYLIST ) ); INITIALIZEVAR( t2723, ADR( lambdaexp_2dtails_21_60af0e8d_v ), MAKEPROCEDURE( 2, 0, lambdaexp_2dtails_21_60af0e8d, EMPTYLIST ) ); INITIALIZEVAR( t2725, ADR( lambdaexp_tr_2dcalls_63782d98_v ), MAKEPROCEDURE( 1, 0, lambdaexp_tr_2dcalls_63782d98, EMPTYLIST ) ); INITIALIZEVAR( t2727, ADR( lambdaexp_2dcalls_21_6fe7acf4_v ), MAKEPROCEDURE( 2, 0, lambdaexp_2dcalls_21_6fe7acf4, EMPTYLIST ) ); INITIALIZEVAR( t2729, ADR( lambdaexp_il_2dcalls_76e98af_v ), MAKEPROCEDURE( 1, 0, lambdaexp_il_2dcalls_76e98af, EMPTYLIST ) ); INITIALIZEVAR( t2731, ADR( lambdaexp_2dcalls_21_a9a74c24_v ), MAKEPROCEDURE( 2, 0, lambdaexp_2dcalls_21_a9a74c24, EMPTYLIST ) ); INITIALIZEVAR( t2733, ADR( lambdaexp_al_2dcalls_4b5d0e39_v ), MAKEPROCEDURE( 1, 0, lambdaexp_al_2dcalls_4b5d0e39, EMPTYLIST ) ); INITIALIZEVAR( t2735, ADR( lambdaexp_2dcalls_21_c8f2c4a0_v ), MAKEPROCEDURE( 2, 0, lambdaexp_2dcalls_21_c8f2c4a0, EMPTYLIST ) ); INITIALIZEVAR( t2737, ADR( lambdaexp_de_2dlabel_a0c18656_v ), MAKEPROCEDURE( 1, 0, lambdaexp_de_2dlabel_a0c18656, EMPTYLIST ) ); INITIALIZEVAR( t2739, ADR( lambdaexp_2dlabel_21_819a857a_v ), MAKEPROCEDURE( 2, 0, lambdaexp_2dlabel_21_819a857a, EMPTYLIST ) ); INITIALIZEVAR( t2741, ADR( lambdaexp_lambda_2d_24lambda_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2d_24lambda, EMPTYLIST ) ); INITIALIZEVAR( t2743, ADR( lambdaexp_4lambda_21_cedc504f_v ), MAKEPROCEDURE( 2, 0, lambdaexp_4lambda_21_cedc504f, EMPTYLIST ) ); INITIALIZEVAR( t2745, ADR( lambdaexp_lambda_2dname_v ), MAKEPROCEDURE( 1, 0, lambdaexp_lambda_2dname, EMPTYLIST ) ); INITIALIZEVAR( t2747, ADR( lambdaexp__2dname_21_f801d262_v ), MAKEPROCEDURE( 2, 0, lambdaexp__2dname_21_f801d262, EMPTYLIST ) ); INITIALIZEVAR( t2749, ADR( lambdaexp_bda_2dinfo_dbd81905_v ), MAKEPROCEDURE( 1, 1, lambdaexp_bda_2dinfo_dbd81905, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/lambdaexp.sc000066400000000000000000000205201203736146400170170ustar00rootroot00000000000000;;; This file contains the functions which handle LAMBDA expressions. LET ;;; expressions are converted to LAMBDA expressions to ease later analysis at ;;; the expense of muddying the intermediate code. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module lambdaexp) ;;; External and in-line definitions. (include "plist.sch") (include "lambdaexp.sch") ;;; (lambda ...) ==> ($lambda '...) ;;; ;;; Renames variables and then expands the body of the lambda expression. ;;; The result is a form which contains an id for later reference in , ;;; and the converted body in '. (define (LAMBDA-EXP exp exp-func) (let ((body (lambda-defines (cddr exp))) (old-lexical-bound-vars lexical-bound-vars) (old-lexical-free-vars lexical-free-vars) (old-current-lambda-id current-lambda-id) (id (newv 'l 'use 'lambda)) (result '())) (set! lexical-free-vars (append lexical-bound-vars lexical-free-vars)) (set! lexical-bound-vars '()) (set-lambda-nestin! id current-lambda-id) (set! current-lambda-id id) (lambda-vars-bind (cadr exp) body id) (set! body (exp-form-list body exp-func)) (set! result `($lambda ,id ,@body)) (set! lexical-bound-vars old-lexical-bound-vars) (set! lexical-free-vars old-lexical-free-vars) (set! current-lambda-id old-current-lambda-id) result)) (define (LAMBDA-VARS-BIND vars name id) (cond ((null? vars)) ((symbol? vars) (set! vars (newv vars 'use 'lexical 'boundid id)) (if name (assign-known-name vars)) (set-lambda-optvars! id (list vars))) ((pair? vars) (let ((var (car vars))) (set! var (newv var 'use 'lexical 'boundid id)) (if name (assign-known-name var)) (lambda-vars-bind (cdr vars) name id) (set-lambda-reqvars! id (cons var (lambda-reqvars id))))) (else (expand-error 'lambda-variables vars)))) ;;; The following procedure is called to rewrite the body of any lambda ;;; expression which contains DEFINE's to an equivilant lambda form. (define (LAMBDA-DEFINES body) (let loop ((oldforms body) (newforms '()) (vars '()) (sets '())) (if oldforms (let ((form (car oldforms))) (cond ((or (not (pair? form)) (not (eq? (car form) 'define))) (loop (cdr oldforms) (cons form newforms) vars sets)) ((pair? (cadr form)) (loop (cdr oldforms) newforms (cons (caadr form) vars) (cons `(set! ,(caadr form) (lambda ,(cdadr form) ,@(cddr form))) sets))) (else (loop (cdr oldforms) newforms (cons (cadr form) vars) (cons `(set! ,@(cdr form)) sets))))) (if vars `(((lambda ,vars ,@(reverse sets) ,@(reverse newforms)) ,@(vector->list (make-vector (length vars) 0)))) body)))) ;;; Attributes of the lambda expression are stored as properties of the : ;;; ;;; REQVARS list of required arguments ;;; OPTVARS list of optional arguments ;;; LEXICAL lexically bound variables used in ;;; CALLS lambda id's which it uses ;;; NAME name bound to the function ;;; GENERATE indicates code generation strategy. The possible ;;; values are INLINE, INLINE-TAIL, CLOSED-PROCEDURE, ;;; and PROCEDURE. ;;; CLOSED lambda expression must be closed. ;;; DISPLAY-CLOSEP closure pointer must be placed in the display. ;;; NESTIN lambda id that this is nested in ;;; EXITS lambda id which this lambda expression exits when it ;;; is tail-called ;;; INLINE-TAILS list of lambda id's for expressions which are tail ;;; called to exit this expression ;;; STR-CALLS list of (caller-lambda-id exit-lambda-id) for "self" ;;; tail-recursive calls ;;; TAIL-CALLS list of (caller-lambda-id exit-lambda-id) for ;;; tail-calls from other lambda expressions ;;; REAL-CALLS list of lambda-id's for "real" (not tail-recursive) ;;; calls ;;; CODE-LABEL label for start of function's code ;;; $LAMBDA $lambda expression for in-line compilation (define ($LAMBDA? x) ($lambda? x)) (define ($LAMBDA-ID x) ($lambda-id x)) (define ($LAMBDA-BODY x) ($lambda-body x)) (define (SET-$LAMBDA-BODY! x body) (set-$lambda-body! x body)) (define (LAMBDA-REQVARS id) (lambda-reqvars id)) (define (SET-LAMBDA-REQVARS! id vars) (set-lambda-reqvars! id vars)) (define (LAMBDA-OPTVARS id) (lambda-optvars id)) (define (SET-LAMBDA-OPTVARS! id vars) (set-lambda-optvars! id vars)) (define (LAMBDA-LEXICAL id) (lambda-lexical id)) (define (SET-LAMBDA-LEXICAL! id lexvars) (set-lambda-lexical! id lexvars)) (define (LAMBDA-CALLS id) (lambda-calls id)) (define (SET-LAMBDA-CALLS! id x) (set-lambda-calls! id x)) (define (LAMBDA-GENERATE id) (lambda-generate id)) (define (SET-LAMBDA-GENERATE! id x) (set-lambda-generate! id x)) (define (LAMBDA-CLOSED id) (lambda-closed id)) (define (SET-LAMBDA-CLOSED! id x) (set-lambda-closed! id x)) (define (LAMBDA-DISPLAY-CLOSEP id) (lambda-display-closep id)) (define (SET-LAMBDA-DISPLAY-CLOSEP! id x) (set-lambda-display-closep! id x)) (define (LAMBDA-NESTIN id) (lambda-nestin id)) (define (SET-LAMBDA-NESTIN! id nestin) (set-lambda-nestin! id nestin)) (define (LAMBDA-EXITS id) (lambda-exits id)) (define (SET-LAMBDA-EXITS! id exits) (set-lambda-exits! id exits)) (define (LAMBDA-INLINE-TAILS id) (lambda-inline-tails id)) (define (SET-LAMBDA-INLINE-TAILS! id tails) (set-lambda-inline-tails! id tails)) (define (LAMBDA-STR-CALLS id) (lambda-str-calls id)) (define (SET-LAMBDA-STR-CALLS! id x) (set-lambda-str-calls! id x)) (define (LAMBDA-TAIL-CALLS id) (lambda-tail-calls id)) (define (SET-LAMBDA-TAIL-CALLS! id x) (set-lambda-tail-calls! id x)) (define (LAMBDA-REAL-CALLS id) (lambda-real-calls id)) (define (SET-LAMBDA-REAL-CALLS! id x) (set-lambda-real-calls! id x)) (define (LAMBDA-CODE-LABEL id) (lambda-code-label id)) (define (SET-LAMBDA-CODE-LABEL! id x) (set-lambda-code-label! id x)) (define (LAMBDA-$LAMBDA id) (lambda-$lambda id)) (define (SET-LAMBDA-$LAMBDA! id exp) (set-lambda-$lambda! id exp)) (define (LAMBDA-NAME id) (lambda-name id)) (define (SET-LAMBDA-NAME! id x) (set-lambda-name! id x)) ;;; All information relating to lambda expressions can be dumped by the ;;; following function. Note that the body is not printed as it is a little ;;; large. (define (PRINT-LAMBDA-INFO id . out) (if out (set! out (car out)) (set! out (current-output-port))) (format out " LAMBDA-NAME: ~a ~a ~a~%" (lambda-name id) id (id-printname (or (lambda-name id) id))) (format out " VARS: ~a ~a~%" (lambda-reqvars id) (lambda-optvars id)) (format out " LEXICAL: ~a~%" (lambda-lexical id)) (format out " CALLS: ~a~%" (lambda-calls id)) (format out " GENERATE: ~a ~a ~a~%" (lambda-generate id) (lambda-closed id) (lambda-display-closep id)) (format out " NESTIN: ~a~%" (lambda-nestin id)) (format out " EXITS: ~a~%" (lambda-exits id)) (format out "INLINE-TAILS: ~a~%" (lambda-inline-tails id)) (format out " STR-CALLS: ~a~%" (lambda-str-calls id)) (format out " TAIL-CALLS: ~a~%" (lambda-tail-calls id)) (format out " REAL-CALLS: ~a~%" (lambda-real-calls id)) (format out " CODE-LABEL: ~a~%" (lambda-code-label id))) scheme2c-2012.10.14/scsc/lambdaexp.sch000066400000000000000000000045241203736146400171750ustar00rootroot00000000000000;;; External and in-line definitions for lambdaexp.sc (define-in-line ($LAMBDA? x) (and (pair? x) (eq? (car x) '$lambda))) (define-in-line ($LAMBDA-ID x) (and ($lambda? x) (cadr x))) (define-in-line ($LAMBDA-BODY x) (and ($lambda? x) (cddr x))) (define-in-line (SET-$LAMBDA-BODY! x body) (set-cdr! (cdr x) body)) (define-in-line (LAMBDA-REQVARS id) (get id 'reqvars)) (define-in-line (SET-LAMBDA-REQVARS! id vars) (put id 'reqvars vars)) (define-in-line (LAMBDA-OPTVARS id) (get id 'optvars)) (define-in-line (SET-LAMBDA-OPTVARS! id vars) (put id 'optvars vars)) (define-in-line (LAMBDA-LEXICAL id) (get id 'lexical)) (define-in-line (SET-LAMBDA-LEXICAL! id lexvars) (put id 'lexical lexvars)) (define-in-line (LAMBDA-CALLS id) (get id 'calls)) (define-in-line (SET-LAMBDA-CALLS! id x) (put id 'calls x)) (define-in-line (LAMBDA-GENERATE id) (get id 'generate)) (define-in-line (SET-LAMBDA-GENERATE! id x) (put id 'generate x)) (define-in-line (LAMBDA-CLOSED id) (get id 'closed)) (define-in-line (SET-LAMBDA-CLOSED! id x) (put id 'closed x)) (define-in-line (LAMBDA-DISPLAY-CLOSEP id) (get id 'display-closep)) (define-in-line (SET-LAMBDA-DISPLAY-CLOSEP! id x) (put id 'display-closep x)) (define-in-line (LAMBDA-NESTIN id) (get id 'nestin)) (define-in-line (SET-LAMBDA-NESTIN! id nestin) (put id 'nestin nestin)) (define-in-line (LAMBDA-EXITS id) (get id 'exits)) (define-in-line (SET-LAMBDA-EXITS! id exits) (put id 'exits exits)) (define-in-line (LAMBDA-INLINE-TAILS id) (get id 'inline-tails)) (define-in-line (SET-LAMBDA-INLINE-TAILS! id tails) (put id 'inline-tails tails)) (define-in-line (LAMBDA-STR-CALLS id) (get id 'str-calls)) (define-in-line (SET-LAMBDA-STR-CALLS! id x) (put id 'str-calls x)) (define-in-line (LAMBDA-TAIL-CALLS id) (get id 'tail-calls)) (define-in-line (SET-LAMBDA-TAIL-CALLS! id x) (put id 'tail-calls x)) (define-in-line (LAMBDA-REAL-CALLS id) (get id 'real-calls)) (define-in-line (SET-LAMBDA-REAL-CALLS! id x) (put id 'real-calls x)) (define-in-line (LAMBDA-CODE-LABEL id) (get id 'code-label)) (define-in-line (SET-LAMBDA-CODE-LABEL! id x) (put id 'code-label x)) (define-in-line (LAMBDA-$LAMBDA id) (get id '$lambda)) (define-in-line (SET-LAMBDA-$LAMBDA! id exp) (put id '$lambda exp)) (define-in-line (LAMBDA-NAME id) (get id 'name)) (define-in-line (SET-LAMBDA-NAME! id x) (put id 'name x)) scheme2c-2012.10.14/scsc/lap.c000066400000000000000000003712261203736146400154670ustar00rootroot00000000000000 /* SCHEME->C */ #include void lap__init(); DEFSTATICTSCP( log_3f_v ); DEFSTATICTSCP( sc_2dicode_v ); DEFSTATICTSCP( set_2did_2dalias_21_v ); DEFSTATICTSCP( set_2did_2dgotos_21_v ); DEFSTATICTSCP( id_2dgotos_v ); DEFSTATICTSCP( free_2ddisplay_v ); DEFSTATICTSCP( report_2derror_v ); DEFSTATICTSCP( pretty_2dprint_2d_24tree_v ); DEFSTATICTSCP( id_2dalias_v ); DEFSTATICTSCP( sc_2dstack_2dtrace_v ); DEFSTATICTSCP( vname_v ); DEFSTATICTSCP( id_2duse_v ); DEFSTATICTSCP( char_2d_3edl_v ); DEFSTATICTSCP( set_2dwrite_2dcount_21_v ); DEFSTATICTSCP( string_2ddowncase_v ); DEFSTATICTSCP( set_2did_2dvname_21_v ); DEFSTATICTSCP( set_2did_2duse_21_v ); DEFSTATICTSCP( c3433 ); DEFSTATICTSCP( t3604 ); DEFSTATICTSCP( t3605 ); DEFSTATICTSCP( t3606 ); DEFSTATICTSCP( t3607 ); DEFSTATICTSCP( t3608 ); DEFSTATICTSCP( t3609 ); DEFSTATICTSCP( t3610 ); DEFSTATICTSCP( t3611 ); DEFSTATICTSCP( t3612 ); DEFSTATICTSCP( t3613 ); DEFSTATICTSCP( t3614 ); DEFSTATICTSCP( t3615 ); DEFSTATICTSCP( t3616 ); DEFSTATICTSCP( t3617 ); DEFSTATICTSCP( t3618 ); DEFSTATICTSCP( t3619 ); DEFSTATICTSCP( t3620 ); DEFSTATICTSCP( t3621 ); DEFSTATICTSCP( t3622 ); DEFSTATICTSCP( t3623 ); DEFSTATICTSCP( t3624 ); DEFSTATICTSCP( t3625 ); DEFSTATICTSCP( t3626 ); DEFSTATICTSCP( t3627 ); DEFSTATICTSCP( t3628 ); DEFSTATICTSCP( t3629 ); DEFSTATICTSCP( t3630 ); DEFSTATICTSCP( t3631 ); DEFSTATICTSCP( t3632 ); DEFSTATICTSCP( t3633 ); DEFSTATICTSCP( t3634 ); DEFSTATICTSCP( t3635 ); DEFSTATICTSCP( t3636 ); DEFSTATICTSCP( t3637 ); DEFSTATICTSCP( t3638 ); DEFSTATICTSCP( t3639 ); DEFSTATICTSCP( t3640 ); DEFSTATICTSCP( t3641 ); DEFSTATICTSCP( t3642 ); DEFSTATICTSCP( t3643 ); DEFSTATICTSCP( t3644 ); DEFSTATICTSCP( t3645 ); DEFSTATICTSCP( t3646 ); DEFSTATICTSCP( t3647 ); DEFSTATICTSCP( t3648 ); DEFSTATICTSCP( t3649 ); DEFSTATICTSCP( t3650 ); DEFSTATICTSCP( t3651 ); DEFSTATICTSCP( t3652 ); DEFSTATICTSCP( t3653 ); DEFSTATICTSCP( t3654 ); DEFSTATICTSCP( t3655 ); DEFSTATICTSCP( t3656 ); DEFSTATICTSCP( t3657 ); DEFSTATICTSCP( t3658 ); DEFSTATICTSCP( t3659 ); DEFSTATICTSCP( t3660 ); DEFSTATICTSCP( t3661 ); DEFSTATICTSCP( t3662 ); DEFSTATICTSCP( t3663 ); DEFSTATICTSCP( t3664 ); DEFSTATICTSCP( t3665 ); DEFSTATICTSCP( t3666 ); DEFSTATICTSCP( t3667 ); DEFSTATICTSCP( t3668 ); DEFSTATICTSCP( t3669 ); DEFSTATICTSCP( t3670 ); DEFSTATICTSCP( t3671 ); DEFSTATICTSCP( t3672 ); DEFSTATICTSCP( t3673 ); DEFSTATICTSCP( t3674 ); DEFSTATICTSCP( t3675 ); DEFSTATICTSCP( t3676 ); DEFSTATICTSCP( t3677 ); DEFSTATICTSCP( t3678 ); DEFSTATICTSCP( t3679 ); DEFSTATICTSCP( t3680 ); DEFSTATICTSCP( t3681 ); DEFSTATICTSCP( t3682 ); DEFSTATICTSCP( t3683 ); DEFSTATICTSCP( t3684 ); DEFSTATICTSCP( t3685 ); DEFSTATICTSCP( t3686 ); DEFSTATICTSCP( t3687 ); DEFSTATICTSCP( t3688 ); DEFSTATICTSCP( t3689 ); DEFSTATICTSCP( t3690 ); DEFSTATICTSCP( t3691 ); DEFSTATICTSCP( t3692 ); DEFSTATICTSCP( t3693 ); DEFSTATICTSCP( t3694 ); DEFSTATICTSCP( t3695 ); DEFSTATICTSCP( t3696 ); DEFSTATICTSCP( t3697 ); DEFSTATICTSCP( t3698 ); DEFSTATICTSCP( t3699 ); DEFSTATICTSCP( t3700 ); DEFSTATICTSCP( t3701 ); DEFSTATICTSCP( t3702 ); DEFSTATICTSCP( t3703 ); DEFSTATICTSCP( t3704 ); DEFSTATICTSCP( t3705 ); DEFSTATICTSCP( t3706 ); DEFSTATICTSCP( t3707 ); DEFSTATICTSCP( t3708 ); DEFSTATICTSCP( t3709 ); DEFSTATICTSCP( t3710 ); DEFSTATICTSCP( t3711 ); DEFSTATICTSCP( t3712 ); DEFSTATICTSCP( t3713 ); DEFSTATICTSCP( t3714 ); DEFSTATICTSCP( t3715 ); DEFSTATICTSCP( t3716 ); DEFSTATICTSCP( t3717 ); DEFSTATICTSCP( t3718 ); DEFSTATICTSCP( t3719 ); DEFSTATICTSCP( t3720 ); DEFSTATICTSCP( t3721 ); DEFSTATICTSCP( t3722 ); DEFSTATICTSCP( t3723 ); DEFSTATICTSCP( t3724 ); DEFSTATICTSCP( t3725 ); DEFSTATICTSCP( t3726 ); DEFSTATICTSCP( t3727 ); DEFSTATICTSCP( t3728 ); DEFSTATICTSCP( t3729 ); DEFSTATICTSCP( t3730 ); DEFSTATICTSCP( t3731 ); DEFSTATICTSCP( t3732 ); DEFSTATICTSCP( t3733 ); DEFSTATICTSCP( t3734 ); DEFSTATICTSCP( t3735 ); DEFSTATICTSCP( t3736 ); DEFSTATICTSCP( t3737 ); DEFSTATICTSCP( t3738 ); DEFSTATICTSCP( t3739 ); DEFSTATICTSCP( t3740 ); DEFSTATICTSCP( t3741 ); DEFSTATICTSCP( t3742 ); DEFSTATICTSCP( t3743 ); DEFSTATICTSCP( t3744 ); DEFSTATICTSCP( t3745 ); DEFSTATICTSCP( t3746 ); DEFSTATICTSCP( t3747 ); DEFSTATICTSCP( t3748 ); DEFSTATICTSCP( t3749 ); DEFSTATICTSCP( t3750 ); DEFSTATICTSCP( t3751 ); DEFSTATICTSCP( t3752 ); DEFSTATICTSCP( t3753 ); DEFSTATICTSCP( t3754 ); DEFSTATICTSCP( t3755 ); DEFSTATICTSCP( t3756 ); DEFSTATICTSCP( t3757 ); DEFSTATICTSCP( t3758 ); DEFSTATICTSCP( t3759 ); DEFSTATICTSCP( t3760 ); DEFSTATICTSCP( t3761 ); DEFSTATICTSCP( t3762 ); DEFSTATICTSCP( t3763 ); DEFSTATICTSCP( t3764 ); DEFSTATICTSCP( t3765 ); DEFSTATICTSCP( t3766 ); DEFSTATICTSCP( t3767 ); DEFSTATICTSCP( t3768 ); DEFSTATICTSCP( t3769 ); DEFSTATICTSCP( t3770 ); DEFSTATICTSCP( t3771 ); DEFSTATICTSCP( t3772 ); DEFSTATICTSCP( t3773 ); DEFSTATICTSCP( t3774 ); DEFSTATICTSCP( t3775 ); DEFSTATICTSCP( t3776 ); DEFSTATICTSCP( t3777 ); DEFSTATICTSCP( t3778 ); DEFSTATICTSCP( t3779 ); DEFSTATICTSCP( t3780 ); DEFSTATICTSCP( t3781 ); DEFSTATICTSCP( t3782 ); DEFSTATICTSCP( t3783 ); DEFSTATICTSCP( t3784 ); DEFSTATICTSCP( t3785 ); DEFSTATICTSCP( t3786 ); DEFSTATICTSCP( t3787 ); DEFSTATICTSCP( t3788 ); DEFSTATICTSCP( t3789 ); DEFSTATICTSCP( t3790 ); DEFSTATICTSCP( t3791 ); DEFSTATICTSCP( t3792 ); DEFSTATICTSCP( t3793 ); DEFSTATICTSCP( t3794 ); DEFSTATICTSCP( t3795 ); DEFSTATICTSCP( t3796 ); DEFSTATICTSCP( t3797 ); DEFSTATICTSCP( t3798 ); DEFSTATICTSCP( t3799 ); DEFSTATICTSCP( t3800 ); DEFSTATICTSCP( t3801 ); DEFSTATICTSCP( t3802 ); DEFSTATICTSCP( t3803 ); DEFSTATICTSCP( t3804 ); DEFSTATICTSCP( t3805 ); DEFSTATICTSCP( t3806 ); DEFSTATICTSCP( t3807 ); DEFSTATICTSCP( t3808 ); DEFSTATICTSCP( t3809 ); DEFSTATICTSCP( t3810 ); DEFSTATICTSCP( t3811 ); DEFSTATICTSCP( t3812 ); DEFSTATICTSCP( t3813 ); DEFSTATICTSCP( t3814 ); DEFSTATICTSCP( t3815 ); DEFSTATICTSCP( t3816 ); DEFSTATICTSCP( t3817 ); DEFSTATICTSCP( t3818 ); DEFSTATICTSCP( t3819 ); DEFSTATICTSCP( t3820 ); DEFSTATICTSCP( t3821 ); DEFSTATICTSCP( t3822 ); DEFSTATICTSCP( t3823 ); DEFSTATICTSCP( t3824 ); DEFSTATICTSCP( t3825 ); DEFSTATICTSCP( t3826 ); DEFSTATICTSCP( t3827 ); DEFSTATICTSCP( t3828 ); DEFSTATICTSCP( t3829 ); DEFSTATICTSCP( t3830 ); DEFSTATICTSCP( t3831 ); DEFSTATICTSCP( t3832 ); DEFSTATICTSCP( t3833 ); DEFSTATICTSCP( t3834 ); DEFSTATICTSCP( t3835 ); DEFSTATICTSCP( t3836 ); DEFSTATICTSCP( t3837 ); DEFSTATICTSCP( t3838 ); DEFSTATICTSCP( t3839 ); DEFSTATICTSCP( t3840 ); DEFSTATICTSCP( t3841 ); DEFSTATICTSCP( t3842 ); DEFSTATICTSCP( t3843 ); DEFSTATICTSCP( t3844 ); DEFSTATICTSCP( t3845 ); DEFSTATICTSCP( t3846 ); DEFSTATICTSCP( t3847 ); DEFSTATICTSCP( t3848 ); DEFSTATICTSCP( t3849 ); DEFSTATICTSCP( t3850 ); DEFSTATICTSCP( t3851 ); DEFSTATICTSCP( t3852 ); DEFSTATICTSCP( t3853 ); DEFSTATICTSCP( t3854 ); DEFSTATICTSCP( t3855 ); DEFSTATICTSCP( t3856 ); DEFSTATICTSCP( t3857 ); DEFSTATICTSCP( t3858 ); DEFSTATICTSCP( t3859 ); DEFSTATICTSCP( t3860 ); DEFSTATICTSCP( t3861 ); DEFSTATICTSCP( t3862 ); DEFSTATICTSCP( t3863 ); DEFSTATICTSCP( t3864 ); DEFSTATICTSCP( t3865 ); DEFSTATICTSCP( t3866 ); DEFSTATICTSCP( t3867 ); DEFSTATICTSCP( t3868 ); DEFSTATICTSCP( t3869 ); DEFSTATICTSCP( t3870 ); DEFSTATICTSCP( t3871 ); DEFSTATICTSCP( t3872 ); DEFSTATICTSCP( t3873 ); DEFSTATICTSCP( t3874 ); DEFSTATICTSCP( t3875 ); DEFSTATICTSCP( t3876 ); DEFSTATICTSCP( t3877 ); DEFSTATICTSCP( t3878 ); DEFSTATICTSCP( t3879 ); DEFSTATICTSCP( t3880 ); DEFSTATICTSCP( t3881 ); DEFSTATICTSCP( t3882 ); DEFSTATICTSCP( t3883 ); DEFSTATICTSCP( t3884 ); DEFSTATICTSCP( t3885 ); DEFSTATICTSCP( t3886 ); DEFSTATICTSCP( t3887 ); DEFSTATICTSCP( t3888 ); DEFSTATICTSCP( t3889 ); DEFSTATICTSCP( t3890 ); DEFSTATICTSCP( t3891 ); DEFSTATICTSCP( t3892 ); DEFSTATICTSCP( t3893 ); DEFSTATICTSCP( t3894 ); DEFSTATICTSCP( t3895 ); DEFSTATICTSCP( t3896 ); DEFSTATICTSCP( t3897 ); DEFSTATICTSCP( t3898 ); DEFSTATICTSCP( t3899 ); DEFSTATICTSCP( t3900 ); DEFSTATICTSCP( t3901 ); DEFSTATICTSCP( t3902 ); DEFSTATICTSCP( t3903 ); DEFSTATICTSCP( t3904 ); DEFSTATICTSCP( t3905 ); DEFSTATICTSCP( c3432 ); DEFCSTRING( t3906, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c3404 ); DEFSTATICTSCP( c3403 ); DEFCSTRING( t3907, "~a.." ); DEFSTATICTSCP( c3338 ); DEFCSTRING( t3908, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c3337 ); DEFSTATICTSCP( c3336 ); DEFCSTRING( t3909, ", " ); DEFSTATICTSCP( c3287 ); DEFSTATICTSCP( c3245 ); DEFSTATICTSCP( c3233 ); DEFCSTRING( t3910, "Argument(s) not CHAR: ~s ~s" ); DEFSTATICTSCP( c3225 ); DEFSTATICTSCP( c3224 ); DEFSTATICTSCP( c3181 ); DEFSTATICTSCP( t3911 ); DEFSTATICTSCP( t3912 ); DEFSTATICTSCP( t3913 ); DEFSTATICTSCP( t3914 ); DEFSTATICTSCP( t3915 ); DEFSTATICTSCP( t3916 ); DEFSTATICTSCP( t3917 ); DEFSTATICTSCP( t3918 ); DEFCSTRING( t3919, "~a( " ); DEFSTATICTSCP( c3164 ); DEFCSTRING( t3920, " )" ); DEFSTATICTSCP( c3153 ); DEFCSTRING( t3921, "( " ); DEFSTATICTSCP( c3148 ); DEFSTATICTSCP( c3122 ); DEFSTATICTSCP( c3111 ); DEFSTATICTSCP( c3090 ); DEFSTATICTSCP( c3042 ); DEFSTATICTSCP( t3922 ); DEFSTATICTSCP( c3034 ); DEFCSTRING( t3923, "PPLAP looked up a symbol:" ); DEFSTATICTSCP( c3026 ); DEFCSTRING( t3924, "POP-TOS compiler error" ); DEFSTATICTSCP( c2989 ); DEFCSTRING( t3925, "~a:~%" ); DEFSTATICTSCP( c2940 ); DEFCSTRING( t3926, ";" ); DEFSTATICTSCP( c2899 ); DEFCSTRING( t3927, " TSCP " ); DEFSTATICTSCP( c2888 ); DEFCSTRING( t3928, "TSCP " ); DEFSTATICTSCP( c2872 ); DEFCSTRING( t3929, "~aTSCP SDVAL;~%" ); DEFSTATICTSCP( c2866 ); DEFCSTRING( t3930, "~aTSCP SD~a = DISPLAY( ~a );~%" ); DEFSTATICTSCP( c2849 ); DEFCSTRING( t3931, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2820 ); DEFSTATICTSCP( c2819 ); DEFCSTRING( t3932, "~aTSCP " ); DEFSTATICTSCP( c2783 ); DEFCSTRING( t3933, " ) " ); DEFSTATICTSCP( c2770 ); DEFCSTRING( t3934, "~%~a " ); DEFSTATICTSCP( c2769 ); DEFCSTRING( t3935, "~aif ( " ); DEFSTATICTSCP( c2745 ); DEFCSTRING( t3936, "PPLAP compiler error" ); DEFSTATICTSCP( c2731 ); DEFSTATICTSCP( c2728 ); DEFCSTRING( t3938, "SDVAL" ); DEFSTATICTSCP( t3937 ); DEFCSTRING( t3939, "POPSTACKTRACE" ); DEFSTATICTSCP( c2717 ); DEFCSTRING( t3940, "return" ); DEFSTATICTSCP( c2716 ); DEFCSTRING( t3941, "~aDISPLAY( ~a ) = SD~a;~%" ); DEFSTATICTSCP( c2706 ); DEFCSTRING( t3942, "~aSDVAL = " ); DEFSTATICTSCP( c2692 ); DEFCSTRING( t3943, "void" ); DEFSTATICTSCP( c2690 ); DEFCSTRING( t3944, " = " ); DEFSTATICTSCP( c2687 ); DEFCSTRING( t3945, ";~%" ); DEFSTATICTSCP( c2664 ); DEFSTATICTSCP( c2652 ); DEFSTATICTSCP( c2648 ); DEFSTATICTSCP( c2644 ); DEFSTATICTSCP( c2637 ); DEFCSTRING( t3946, "~aGOBACK( ~a );~%" ); DEFSTATICTSCP( c2607 ); DEFCSTRING( t3947, "~agoto ~a;~%" ); DEFSTATICTSCP( c2606 ); DEFSTATICTSCP( c2563 ); DEFSTATICTSCP( c2546 ); DEFCSTRING( t3948, "Procedure required >= 300 temporary variables" ); DEFSTATICTSCP( c2545 ); DEFSTATICTSCP( c2518 ); DEFSTATICTSCP( c2407 ); DEFSTATICTSCP( c2354 ); DEFSTATICTSCP( c2213 ); DEFSTATICTSCP( t3949 ); DEFSTATICTSCP( c2207 ); DEFSTATICTSCP( c2185 ); DEFSTATICTSCP( c2143 ); DEFSTATICTSCP( c2132 ); DEFSTATICTSCP( c2111 ); DEFSTATICTSCP( c2100 ); DEFCSTRING( t3950, " */~%" ); DEFSTATICTSCP( c2084 ); DEFCSTRING( t3951, " ~A~% =>" ); DEFSTATICTSCP( c2053 ); DEFCSTRING( t3952, " ~A" ); DEFSTATICTSCP( c2032 ); DEFCSTRING( t3953, "/* " ); DEFSTATICTSCP( c2020 ); DEFSTATICTSCP( c2016 ); static void init_constants() { TSCP X1; log_3f_v = STRINGTOSYMBOL( CSTRING_TSCP( "LOG?" ) ); CONSTANTEXP( ADR( log_3f_v ) ); sc_2dicode_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-ICODE" ) ); CONSTANTEXP( ADR( sc_2dicode_v ) ); set_2did_2dalias_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-ID-ALIAS!\ " ) ); CONSTANTEXP( ADR( set_2did_2dalias_21_v ) ); set_2did_2dgotos_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-ID-GOTOS!\ " ) ); CONSTANTEXP( ADR( set_2did_2dgotos_21_v ) ); id_2dgotos_v = STRINGTOSYMBOL( CSTRING_TSCP( "ID-GOTOS" ) ); CONSTANTEXP( ADR( id_2dgotos_v ) ); free_2ddisplay_v = STRINGTOSYMBOL( CSTRING_TSCP( "FREE-DISPLAY" ) ); CONSTANTEXP( ADR( free_2ddisplay_v ) ); report_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-ERROR" ) ); CONSTANTEXP( ADR( report_2derror_v ) ); pretty_2dprint_2d_24tree_v = STRINGTOSYMBOL( CSTRING_TSCP( "PRETTY-P\ RINT-$TREE" ) ); CONSTANTEXP( ADR( pretty_2dprint_2d_24tree_v ) ); id_2dalias_v = STRINGTOSYMBOL( CSTRING_TSCP( "ID-ALIAS" ) ); CONSTANTEXP( ADR( id_2dalias_v ) ); sc_2dstack_2dtrace_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-STACK-TRACE\ " ) ); CONSTANTEXP( ADR( sc_2dstack_2dtrace_v ) ); vname_v = STRINGTOSYMBOL( CSTRING_TSCP( "VNAME" ) ); CONSTANTEXP( ADR( vname_v ) ); id_2duse_v = STRINGTOSYMBOL( CSTRING_TSCP( "ID-USE" ) ); CONSTANTEXP( ADR( id_2duse_v ) ); char_2d_3edl_v = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR->DL" ) ); CONSTANTEXP( ADR( char_2d_3edl_v ) ); set_2dwrite_2dcount_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-WRITE-\ COUNT!" ) ); CONSTANTEXP( ADR( set_2dwrite_2dcount_21_v ) ); string_2ddowncase_v = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-DOWNCASE\ " ) ); CONSTANTEXP( ADR( string_2ddowncase_v ) ); set_2did_2dvname_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-ID-VNAME!\ " ) ); CONSTANTEXP( ADR( set_2did_2dvname_21_v ) ); set_2did_2duse_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-ID-USE!" ) ); CONSTANTEXP( ADR( set_2did_2duse_21_v ) ); c3433 = EMPTYLIST; t3604 = STRINGTOSYMBOL( CSTRING_TSCP( "RETURN" ) ); c3433 = CONS( t3604, c3433 ); t3605 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-VALUE" ) ); c3433 = CONS( t3605, c3433 ); t3606 = STRINGTOSYMBOL( CSTRING_TSCP( "TOS" ) ); c3433 = CONS( t3606, c3433 ); t3607 = STRINGTOSYMBOL( CSTRING_TSCP( "X299" ) ); c3433 = CONS( t3607, c3433 ); t3608 = STRINGTOSYMBOL( CSTRING_TSCP( "X298" ) ); c3433 = CONS( t3608, c3433 ); t3609 = STRINGTOSYMBOL( CSTRING_TSCP( "X297" ) ); c3433 = CONS( t3609, c3433 ); t3610 = STRINGTOSYMBOL( CSTRING_TSCP( "X296" ) ); c3433 = CONS( t3610, c3433 ); t3611 = STRINGTOSYMBOL( CSTRING_TSCP( "X295" ) ); c3433 = CONS( t3611, c3433 ); t3612 = STRINGTOSYMBOL( CSTRING_TSCP( "X294" ) ); c3433 = CONS( t3612, c3433 ); t3613 = STRINGTOSYMBOL( CSTRING_TSCP( "X293" ) ); c3433 = CONS( t3613, c3433 ); t3614 = STRINGTOSYMBOL( CSTRING_TSCP( "X292" ) ); c3433 = CONS( t3614, c3433 ); t3615 = STRINGTOSYMBOL( CSTRING_TSCP( "X291" ) ); c3433 = CONS( t3615, c3433 ); t3616 = STRINGTOSYMBOL( CSTRING_TSCP( "X290" ) ); c3433 = CONS( t3616, c3433 ); t3617 = STRINGTOSYMBOL( CSTRING_TSCP( "X289" ) ); c3433 = CONS( t3617, c3433 ); t3618 = STRINGTOSYMBOL( CSTRING_TSCP( "X288" ) ); c3433 = CONS( t3618, c3433 ); t3619 = STRINGTOSYMBOL( CSTRING_TSCP( "X287" ) ); c3433 = CONS( t3619, c3433 ); t3620 = STRINGTOSYMBOL( CSTRING_TSCP( "X286" ) ); c3433 = CONS( t3620, c3433 ); t3621 = STRINGTOSYMBOL( CSTRING_TSCP( "X285" ) ); c3433 = CONS( t3621, c3433 ); t3622 = STRINGTOSYMBOL( CSTRING_TSCP( "X284" ) ); c3433 = CONS( t3622, c3433 ); t3623 = STRINGTOSYMBOL( CSTRING_TSCP( "X283" ) ); c3433 = CONS( t3623, c3433 ); t3624 = STRINGTOSYMBOL( CSTRING_TSCP( "X282" ) ); c3433 = CONS( t3624, c3433 ); t3625 = STRINGTOSYMBOL( CSTRING_TSCP( "X281" ) ); c3433 = CONS( t3625, c3433 ); t3626 = STRINGTOSYMBOL( CSTRING_TSCP( "X280" ) ); c3433 = CONS( t3626, c3433 ); t3627 = STRINGTOSYMBOL( CSTRING_TSCP( "X279" ) ); c3433 = CONS( t3627, c3433 ); t3628 = STRINGTOSYMBOL( CSTRING_TSCP( "X278" ) ); c3433 = CONS( t3628, c3433 ); t3629 = STRINGTOSYMBOL( CSTRING_TSCP( "X277" ) ); c3433 = CONS( t3629, c3433 ); t3630 = STRINGTOSYMBOL( CSTRING_TSCP( "X276" ) ); c3433 = CONS( t3630, c3433 ); t3631 = STRINGTOSYMBOL( CSTRING_TSCP( "X275" ) ); c3433 = CONS( t3631, c3433 ); t3632 = STRINGTOSYMBOL( CSTRING_TSCP( "X274" ) ); c3433 = CONS( t3632, c3433 ); t3633 = STRINGTOSYMBOL( CSTRING_TSCP( "X273" ) ); c3433 = CONS( t3633, c3433 ); t3634 = STRINGTOSYMBOL( CSTRING_TSCP( "X272" ) ); c3433 = CONS( t3634, c3433 ); t3635 = STRINGTOSYMBOL( CSTRING_TSCP( "X271" ) ); c3433 = CONS( t3635, c3433 ); t3636 = STRINGTOSYMBOL( CSTRING_TSCP( "X270" ) ); c3433 = CONS( t3636, c3433 ); t3637 = STRINGTOSYMBOL( CSTRING_TSCP( "X269" ) ); c3433 = CONS( t3637, c3433 ); t3638 = STRINGTOSYMBOL( CSTRING_TSCP( "X268" ) ); c3433 = CONS( t3638, c3433 ); t3639 = STRINGTOSYMBOL( CSTRING_TSCP( "X267" ) ); c3433 = CONS( t3639, c3433 ); t3640 = STRINGTOSYMBOL( CSTRING_TSCP( "X266" ) ); c3433 = CONS( t3640, c3433 ); t3641 = STRINGTOSYMBOL( CSTRING_TSCP( "X265" ) ); c3433 = CONS( t3641, c3433 ); t3642 = STRINGTOSYMBOL( CSTRING_TSCP( "X264" ) ); c3433 = CONS( t3642, c3433 ); t3643 = STRINGTOSYMBOL( CSTRING_TSCP( "X263" ) ); c3433 = CONS( t3643, c3433 ); t3644 = STRINGTOSYMBOL( CSTRING_TSCP( "X262" ) ); c3433 = CONS( t3644, c3433 ); t3645 = STRINGTOSYMBOL( CSTRING_TSCP( "X261" ) ); c3433 = CONS( t3645, c3433 ); t3646 = STRINGTOSYMBOL( CSTRING_TSCP( "X260" ) ); c3433 = CONS( t3646, c3433 ); t3647 = STRINGTOSYMBOL( CSTRING_TSCP( "X259" ) ); c3433 = CONS( t3647, c3433 ); t3648 = STRINGTOSYMBOL( CSTRING_TSCP( "X258" ) ); c3433 = CONS( t3648, c3433 ); t3649 = STRINGTOSYMBOL( CSTRING_TSCP( "X257" ) ); c3433 = CONS( t3649, c3433 ); t3650 = STRINGTOSYMBOL( CSTRING_TSCP( "X256" ) ); c3433 = CONS( t3650, c3433 ); t3651 = STRINGTOSYMBOL( CSTRING_TSCP( "X255" ) ); c3433 = CONS( t3651, c3433 ); t3652 = STRINGTOSYMBOL( CSTRING_TSCP( "X254" ) ); c3433 = CONS( t3652, c3433 ); t3653 = STRINGTOSYMBOL( CSTRING_TSCP( "X253" ) ); c3433 = CONS( t3653, c3433 ); t3654 = STRINGTOSYMBOL( CSTRING_TSCP( "X252" ) ); c3433 = CONS( t3654, c3433 ); t3655 = STRINGTOSYMBOL( CSTRING_TSCP( "X251" ) ); c3433 = CONS( t3655, c3433 ); t3656 = STRINGTOSYMBOL( CSTRING_TSCP( "X250" ) ); c3433 = CONS( t3656, c3433 ); t3657 = STRINGTOSYMBOL( CSTRING_TSCP( "X249" ) ); c3433 = CONS( t3657, c3433 ); t3658 = STRINGTOSYMBOL( CSTRING_TSCP( "X248" ) ); c3433 = CONS( t3658, c3433 ); t3659 = STRINGTOSYMBOL( CSTRING_TSCP( "X247" ) ); c3433 = CONS( t3659, c3433 ); t3660 = STRINGTOSYMBOL( CSTRING_TSCP( "X246" ) ); c3433 = CONS( t3660, c3433 ); t3661 = STRINGTOSYMBOL( CSTRING_TSCP( "X245" ) ); c3433 = CONS( t3661, c3433 ); t3662 = STRINGTOSYMBOL( CSTRING_TSCP( "X244" ) ); c3433 = CONS( t3662, c3433 ); t3663 = STRINGTOSYMBOL( CSTRING_TSCP( "X243" ) ); c3433 = CONS( t3663, c3433 ); t3664 = STRINGTOSYMBOL( CSTRING_TSCP( "X242" ) ); c3433 = CONS( t3664, c3433 ); t3665 = STRINGTOSYMBOL( CSTRING_TSCP( "X241" ) ); c3433 = CONS( t3665, c3433 ); t3666 = STRINGTOSYMBOL( CSTRING_TSCP( "X240" ) ); c3433 = CONS( t3666, c3433 ); t3667 = STRINGTOSYMBOL( CSTRING_TSCP( "X239" ) ); c3433 = CONS( t3667, c3433 ); t3668 = STRINGTOSYMBOL( CSTRING_TSCP( "X238" ) ); c3433 = CONS( t3668, c3433 ); t3669 = STRINGTOSYMBOL( CSTRING_TSCP( "X237" ) ); c3433 = CONS( t3669, c3433 ); t3670 = STRINGTOSYMBOL( CSTRING_TSCP( "X236" ) ); c3433 = CONS( t3670, c3433 ); t3671 = STRINGTOSYMBOL( CSTRING_TSCP( "X235" ) ); c3433 = CONS( t3671, c3433 ); t3672 = STRINGTOSYMBOL( CSTRING_TSCP( "X234" ) ); c3433 = CONS( t3672, c3433 ); t3673 = STRINGTOSYMBOL( CSTRING_TSCP( "X233" ) ); c3433 = CONS( t3673, c3433 ); t3674 = STRINGTOSYMBOL( CSTRING_TSCP( "X232" ) ); c3433 = CONS( t3674, c3433 ); t3675 = STRINGTOSYMBOL( CSTRING_TSCP( "X231" ) ); c3433 = CONS( t3675, c3433 ); t3676 = STRINGTOSYMBOL( CSTRING_TSCP( "X230" ) ); c3433 = CONS( t3676, c3433 ); t3677 = STRINGTOSYMBOL( CSTRING_TSCP( "X229" ) ); c3433 = CONS( t3677, c3433 ); t3678 = STRINGTOSYMBOL( CSTRING_TSCP( "X228" ) ); c3433 = CONS( t3678, c3433 ); t3679 = STRINGTOSYMBOL( CSTRING_TSCP( "X227" ) ); c3433 = CONS( t3679, c3433 ); t3680 = STRINGTOSYMBOL( CSTRING_TSCP( "X226" ) ); c3433 = CONS( t3680, c3433 ); t3681 = STRINGTOSYMBOL( CSTRING_TSCP( "X225" ) ); c3433 = CONS( t3681, c3433 ); t3682 = STRINGTOSYMBOL( CSTRING_TSCP( "X224" ) ); c3433 = CONS( t3682, c3433 ); t3683 = STRINGTOSYMBOL( CSTRING_TSCP( "X223" ) ); c3433 = CONS( t3683, c3433 ); t3684 = STRINGTOSYMBOL( CSTRING_TSCP( "X222" ) ); c3433 = CONS( t3684, c3433 ); t3685 = STRINGTOSYMBOL( CSTRING_TSCP( "X221" ) ); c3433 = CONS( t3685, c3433 ); t3686 = STRINGTOSYMBOL( CSTRING_TSCP( "X220" ) ); c3433 = CONS( t3686, c3433 ); t3687 = STRINGTOSYMBOL( CSTRING_TSCP( "X219" ) ); c3433 = CONS( t3687, c3433 ); t3688 = STRINGTOSYMBOL( CSTRING_TSCP( "X218" ) ); c3433 = CONS( t3688, c3433 ); t3689 = STRINGTOSYMBOL( CSTRING_TSCP( "X217" ) ); c3433 = CONS( t3689, c3433 ); t3690 = STRINGTOSYMBOL( CSTRING_TSCP( "X216" ) ); c3433 = CONS( t3690, c3433 ); t3691 = STRINGTOSYMBOL( CSTRING_TSCP( "X215" ) ); c3433 = CONS( t3691, c3433 ); t3692 = STRINGTOSYMBOL( CSTRING_TSCP( "X214" ) ); c3433 = CONS( t3692, c3433 ); t3693 = STRINGTOSYMBOL( CSTRING_TSCP( "X213" ) ); c3433 = CONS( t3693, c3433 ); t3694 = STRINGTOSYMBOL( CSTRING_TSCP( "X212" ) ); c3433 = CONS( t3694, c3433 ); t3695 = STRINGTOSYMBOL( CSTRING_TSCP( "X211" ) ); c3433 = CONS( t3695, c3433 ); t3696 = STRINGTOSYMBOL( CSTRING_TSCP( "X210" ) ); c3433 = CONS( t3696, c3433 ); t3697 = STRINGTOSYMBOL( CSTRING_TSCP( "X209" ) ); c3433 = CONS( t3697, c3433 ); t3698 = STRINGTOSYMBOL( CSTRING_TSCP( "X208" ) ); c3433 = CONS( t3698, c3433 ); t3699 = STRINGTOSYMBOL( CSTRING_TSCP( "X207" ) ); c3433 = CONS( t3699, c3433 ); t3700 = STRINGTOSYMBOL( CSTRING_TSCP( "X206" ) ); c3433 = CONS( t3700, c3433 ); t3701 = STRINGTOSYMBOL( CSTRING_TSCP( "X205" ) ); c3433 = CONS( t3701, c3433 ); t3702 = STRINGTOSYMBOL( CSTRING_TSCP( "X204" ) ); c3433 = CONS( t3702, c3433 ); t3703 = STRINGTOSYMBOL( CSTRING_TSCP( "X203" ) ); c3433 = CONS( t3703, c3433 ); t3704 = STRINGTOSYMBOL( CSTRING_TSCP( "X202" ) ); c3433 = CONS( t3704, c3433 ); t3705 = STRINGTOSYMBOL( CSTRING_TSCP( "X201" ) ); c3433 = CONS( t3705, c3433 ); t3706 = STRINGTOSYMBOL( CSTRING_TSCP( "X200" ) ); c3433 = CONS( t3706, c3433 ); t3707 = STRINGTOSYMBOL( CSTRING_TSCP( "X199" ) ); c3433 = CONS( t3707, c3433 ); t3708 = STRINGTOSYMBOL( CSTRING_TSCP( "X198" ) ); c3433 = CONS( t3708, c3433 ); t3709 = STRINGTOSYMBOL( CSTRING_TSCP( "X197" ) ); c3433 = CONS( t3709, c3433 ); t3710 = STRINGTOSYMBOL( CSTRING_TSCP( "X196" ) ); c3433 = CONS( t3710, c3433 ); t3711 = STRINGTOSYMBOL( CSTRING_TSCP( "X195" ) ); c3433 = CONS( t3711, c3433 ); t3712 = STRINGTOSYMBOL( CSTRING_TSCP( "X194" ) ); c3433 = CONS( t3712, c3433 ); t3713 = STRINGTOSYMBOL( CSTRING_TSCP( "X193" ) ); c3433 = CONS( t3713, c3433 ); t3714 = STRINGTOSYMBOL( CSTRING_TSCP( "X192" ) ); c3433 = CONS( t3714, c3433 ); t3715 = STRINGTOSYMBOL( CSTRING_TSCP( "X191" ) ); c3433 = CONS( t3715, c3433 ); t3716 = STRINGTOSYMBOL( CSTRING_TSCP( "X190" ) ); c3433 = CONS( t3716, c3433 ); t3717 = STRINGTOSYMBOL( CSTRING_TSCP( "X189" ) ); c3433 = CONS( t3717, c3433 ); t3718 = STRINGTOSYMBOL( CSTRING_TSCP( "X188" ) ); c3433 = CONS( t3718, c3433 ); t3719 = STRINGTOSYMBOL( CSTRING_TSCP( "X187" ) ); c3433 = CONS( t3719, c3433 ); t3720 = STRINGTOSYMBOL( CSTRING_TSCP( "X186" ) ); c3433 = CONS( t3720, c3433 ); t3721 = STRINGTOSYMBOL( CSTRING_TSCP( "X185" ) ); c3433 = CONS( t3721, c3433 ); t3722 = STRINGTOSYMBOL( CSTRING_TSCP( "X184" ) ); c3433 = CONS( t3722, c3433 ); t3723 = STRINGTOSYMBOL( CSTRING_TSCP( "X183" ) ); c3433 = CONS( t3723, c3433 ); t3724 = STRINGTOSYMBOL( CSTRING_TSCP( "X182" ) ); c3433 = CONS( t3724, c3433 ); t3725 = STRINGTOSYMBOL( CSTRING_TSCP( "X181" ) ); c3433 = CONS( t3725, c3433 ); t3726 = STRINGTOSYMBOL( CSTRING_TSCP( "X180" ) ); c3433 = CONS( t3726, c3433 ); t3727 = STRINGTOSYMBOL( CSTRING_TSCP( "X179" ) ); c3433 = CONS( t3727, c3433 ); t3728 = STRINGTOSYMBOL( CSTRING_TSCP( "X178" ) ); c3433 = CONS( t3728, c3433 ); t3729 = STRINGTOSYMBOL( CSTRING_TSCP( "X177" ) ); c3433 = CONS( t3729, c3433 ); t3730 = STRINGTOSYMBOL( CSTRING_TSCP( "X176" ) ); c3433 = CONS( t3730, c3433 ); t3731 = STRINGTOSYMBOL( CSTRING_TSCP( "X175" ) ); c3433 = CONS( t3731, c3433 ); t3732 = STRINGTOSYMBOL( CSTRING_TSCP( "X174" ) ); c3433 = CONS( t3732, c3433 ); t3733 = STRINGTOSYMBOL( CSTRING_TSCP( "X173" ) ); c3433 = CONS( t3733, c3433 ); t3734 = STRINGTOSYMBOL( CSTRING_TSCP( "X172" ) ); c3433 = CONS( t3734, c3433 ); t3735 = STRINGTOSYMBOL( CSTRING_TSCP( "X171" ) ); c3433 = CONS( t3735, c3433 ); t3736 = STRINGTOSYMBOL( CSTRING_TSCP( "X170" ) ); c3433 = CONS( t3736, c3433 ); t3737 = STRINGTOSYMBOL( CSTRING_TSCP( "X169" ) ); c3433 = CONS( t3737, c3433 ); t3738 = STRINGTOSYMBOL( CSTRING_TSCP( "X168" ) ); c3433 = CONS( t3738, c3433 ); t3739 = STRINGTOSYMBOL( CSTRING_TSCP( "X167" ) ); c3433 = CONS( t3739, c3433 ); t3740 = STRINGTOSYMBOL( CSTRING_TSCP( "X166" ) ); c3433 = CONS( t3740, c3433 ); t3741 = STRINGTOSYMBOL( CSTRING_TSCP( "X165" ) ); c3433 = CONS( t3741, c3433 ); t3742 = STRINGTOSYMBOL( CSTRING_TSCP( "X164" ) ); c3433 = CONS( t3742, c3433 ); t3743 = STRINGTOSYMBOL( CSTRING_TSCP( "X163" ) ); c3433 = CONS( t3743, c3433 ); t3744 = STRINGTOSYMBOL( CSTRING_TSCP( "X162" ) ); c3433 = CONS( t3744, c3433 ); t3745 = STRINGTOSYMBOL( CSTRING_TSCP( "X161" ) ); c3433 = CONS( t3745, c3433 ); t3746 = STRINGTOSYMBOL( CSTRING_TSCP( "X160" ) ); c3433 = CONS( t3746, c3433 ); t3747 = STRINGTOSYMBOL( CSTRING_TSCP( "X159" ) ); c3433 = CONS( t3747, c3433 ); t3748 = STRINGTOSYMBOL( CSTRING_TSCP( "X158" ) ); c3433 = CONS( t3748, c3433 ); t3749 = STRINGTOSYMBOL( CSTRING_TSCP( "X157" ) ); c3433 = CONS( t3749, c3433 ); t3750 = STRINGTOSYMBOL( CSTRING_TSCP( "X156" ) ); c3433 = CONS( t3750, c3433 ); t3751 = STRINGTOSYMBOL( CSTRING_TSCP( "X155" ) ); c3433 = CONS( t3751, c3433 ); t3752 = STRINGTOSYMBOL( CSTRING_TSCP( "X154" ) ); c3433 = CONS( t3752, c3433 ); t3753 = STRINGTOSYMBOL( CSTRING_TSCP( "X153" ) ); c3433 = CONS( t3753, c3433 ); t3754 = STRINGTOSYMBOL( CSTRING_TSCP( "X152" ) ); c3433 = CONS( t3754, c3433 ); t3755 = STRINGTOSYMBOL( CSTRING_TSCP( "X151" ) ); c3433 = CONS( t3755, c3433 ); t3756 = STRINGTOSYMBOL( CSTRING_TSCP( "X150" ) ); c3433 = CONS( t3756, c3433 ); t3757 = STRINGTOSYMBOL( CSTRING_TSCP( "X149" ) ); c3433 = CONS( t3757, c3433 ); t3758 = STRINGTOSYMBOL( CSTRING_TSCP( "X148" ) ); c3433 = CONS( t3758, c3433 ); t3759 = STRINGTOSYMBOL( CSTRING_TSCP( "X147" ) ); c3433 = CONS( t3759, c3433 ); t3760 = STRINGTOSYMBOL( CSTRING_TSCP( "X146" ) ); c3433 = CONS( t3760, c3433 ); t3761 = STRINGTOSYMBOL( CSTRING_TSCP( "X145" ) ); c3433 = CONS( t3761, c3433 ); t3762 = STRINGTOSYMBOL( CSTRING_TSCP( "X144" ) ); c3433 = CONS( t3762, c3433 ); t3763 = STRINGTOSYMBOL( CSTRING_TSCP( "X143" ) ); c3433 = CONS( t3763, c3433 ); t3764 = STRINGTOSYMBOL( CSTRING_TSCP( "X142" ) ); c3433 = CONS( t3764, c3433 ); t3765 = STRINGTOSYMBOL( CSTRING_TSCP( "X141" ) ); c3433 = CONS( t3765, c3433 ); t3766 = STRINGTOSYMBOL( CSTRING_TSCP( "X140" ) ); c3433 = CONS( t3766, c3433 ); t3767 = STRINGTOSYMBOL( CSTRING_TSCP( "X139" ) ); c3433 = CONS( t3767, c3433 ); t3768 = STRINGTOSYMBOL( CSTRING_TSCP( "X138" ) ); c3433 = CONS( t3768, c3433 ); t3769 = STRINGTOSYMBOL( CSTRING_TSCP( "X137" ) ); c3433 = CONS( t3769, c3433 ); t3770 = STRINGTOSYMBOL( CSTRING_TSCP( "X136" ) ); c3433 = CONS( t3770, c3433 ); t3771 = STRINGTOSYMBOL( CSTRING_TSCP( "X135" ) ); c3433 = CONS( t3771, c3433 ); t3772 = STRINGTOSYMBOL( CSTRING_TSCP( "X134" ) ); c3433 = CONS( t3772, c3433 ); t3773 = STRINGTOSYMBOL( CSTRING_TSCP( "X133" ) ); c3433 = CONS( t3773, c3433 ); t3774 = STRINGTOSYMBOL( CSTRING_TSCP( "X132" ) ); c3433 = CONS( t3774, c3433 ); t3775 = STRINGTOSYMBOL( CSTRING_TSCP( "X131" ) ); c3433 = CONS( t3775, c3433 ); t3776 = STRINGTOSYMBOL( CSTRING_TSCP( "X130" ) ); c3433 = CONS( t3776, c3433 ); t3777 = STRINGTOSYMBOL( CSTRING_TSCP( "X129" ) ); c3433 = CONS( t3777, c3433 ); t3778 = STRINGTOSYMBOL( CSTRING_TSCP( "X128" ) ); c3433 = CONS( t3778, c3433 ); t3779 = STRINGTOSYMBOL( CSTRING_TSCP( "X127" ) ); c3433 = CONS( t3779, c3433 ); t3780 = STRINGTOSYMBOL( CSTRING_TSCP( "X126" ) ); c3433 = CONS( t3780, c3433 ); t3781 = STRINGTOSYMBOL( CSTRING_TSCP( "X125" ) ); c3433 = CONS( t3781, c3433 ); t3782 = STRINGTOSYMBOL( CSTRING_TSCP( "X124" ) ); c3433 = CONS( t3782, c3433 ); t3783 = STRINGTOSYMBOL( CSTRING_TSCP( "X123" ) ); c3433 = CONS( t3783, c3433 ); t3784 = STRINGTOSYMBOL( CSTRING_TSCP( "X122" ) ); c3433 = CONS( t3784, c3433 ); t3785 = STRINGTOSYMBOL( CSTRING_TSCP( "X121" ) ); c3433 = CONS( t3785, c3433 ); t3786 = STRINGTOSYMBOL( CSTRING_TSCP( "X120" ) ); c3433 = CONS( t3786, c3433 ); t3787 = STRINGTOSYMBOL( CSTRING_TSCP( "X119" ) ); c3433 = CONS( t3787, c3433 ); t3788 = STRINGTOSYMBOL( CSTRING_TSCP( "X118" ) ); c3433 = CONS( t3788, c3433 ); t3789 = STRINGTOSYMBOL( CSTRING_TSCP( "X117" ) ); c3433 = CONS( t3789, c3433 ); t3790 = STRINGTOSYMBOL( CSTRING_TSCP( "X116" ) ); c3433 = CONS( t3790, c3433 ); t3791 = STRINGTOSYMBOL( CSTRING_TSCP( "X115" ) ); c3433 = CONS( t3791, c3433 ); t3792 = STRINGTOSYMBOL( CSTRING_TSCP( "X114" ) ); c3433 = CONS( t3792, c3433 ); t3793 = STRINGTOSYMBOL( CSTRING_TSCP( "X113" ) ); c3433 = CONS( t3793, c3433 ); t3794 = STRINGTOSYMBOL( CSTRING_TSCP( "X112" ) ); c3433 = CONS( t3794, c3433 ); t3795 = STRINGTOSYMBOL( CSTRING_TSCP( "X111" ) ); c3433 = CONS( t3795, c3433 ); t3796 = STRINGTOSYMBOL( CSTRING_TSCP( "X110" ) ); c3433 = CONS( t3796, c3433 ); t3797 = STRINGTOSYMBOL( CSTRING_TSCP( "X109" ) ); c3433 = CONS( t3797, c3433 ); t3798 = STRINGTOSYMBOL( CSTRING_TSCP( "X108" ) ); c3433 = CONS( t3798, c3433 ); t3799 = STRINGTOSYMBOL( CSTRING_TSCP( "X107" ) ); c3433 = CONS( t3799, c3433 ); t3800 = STRINGTOSYMBOL( CSTRING_TSCP( "X106" ) ); c3433 = CONS( t3800, c3433 ); t3801 = STRINGTOSYMBOL( CSTRING_TSCP( "X105" ) ); c3433 = CONS( t3801, c3433 ); t3802 = STRINGTOSYMBOL( CSTRING_TSCP( "X104" ) ); c3433 = CONS( t3802, c3433 ); t3803 = STRINGTOSYMBOL( CSTRING_TSCP( "X103" ) ); c3433 = CONS( t3803, c3433 ); t3804 = STRINGTOSYMBOL( CSTRING_TSCP( "X102" ) ); c3433 = CONS( t3804, c3433 ); t3805 = STRINGTOSYMBOL( CSTRING_TSCP( "X101" ) ); c3433 = CONS( t3805, c3433 ); t3806 = STRINGTOSYMBOL( CSTRING_TSCP( "X100" ) ); c3433 = CONS( t3806, c3433 ); t3807 = STRINGTOSYMBOL( CSTRING_TSCP( "X99" ) ); c3433 = CONS( t3807, c3433 ); t3808 = STRINGTOSYMBOL( CSTRING_TSCP( "X98" ) ); c3433 = CONS( t3808, c3433 ); t3809 = STRINGTOSYMBOL( CSTRING_TSCP( "X97" ) ); c3433 = CONS( t3809, c3433 ); t3810 = STRINGTOSYMBOL( CSTRING_TSCP( "X96" ) ); c3433 = CONS( t3810, c3433 ); t3811 = STRINGTOSYMBOL( CSTRING_TSCP( "X95" ) ); c3433 = CONS( t3811, c3433 ); t3812 = STRINGTOSYMBOL( CSTRING_TSCP( "X94" ) ); c3433 = CONS( t3812, c3433 ); t3813 = STRINGTOSYMBOL( CSTRING_TSCP( "X93" ) ); c3433 = CONS( t3813, c3433 ); t3814 = STRINGTOSYMBOL( CSTRING_TSCP( "X92" ) ); c3433 = CONS( t3814, c3433 ); t3815 = STRINGTOSYMBOL( CSTRING_TSCP( "X91" ) ); c3433 = CONS( t3815, c3433 ); t3816 = STRINGTOSYMBOL( CSTRING_TSCP( "X90" ) ); c3433 = CONS( t3816, c3433 ); t3817 = STRINGTOSYMBOL( CSTRING_TSCP( "X89" ) ); c3433 = CONS( t3817, c3433 ); t3818 = STRINGTOSYMBOL( CSTRING_TSCP( "X88" ) ); c3433 = CONS( t3818, c3433 ); t3819 = STRINGTOSYMBOL( CSTRING_TSCP( "X87" ) ); c3433 = CONS( t3819, c3433 ); t3820 = STRINGTOSYMBOL( CSTRING_TSCP( "X86" ) ); c3433 = CONS( t3820, c3433 ); t3821 = STRINGTOSYMBOL( CSTRING_TSCP( "X85" ) ); c3433 = CONS( t3821, c3433 ); t3822 = STRINGTOSYMBOL( CSTRING_TSCP( "X84" ) ); c3433 = CONS( t3822, c3433 ); t3823 = STRINGTOSYMBOL( CSTRING_TSCP( "X83" ) ); c3433 = CONS( t3823, c3433 ); t3824 = STRINGTOSYMBOL( CSTRING_TSCP( "X82" ) ); c3433 = CONS( t3824, c3433 ); t3825 = STRINGTOSYMBOL( CSTRING_TSCP( "X81" ) ); c3433 = CONS( t3825, c3433 ); t3826 = STRINGTOSYMBOL( CSTRING_TSCP( "X80" ) ); c3433 = CONS( t3826, c3433 ); t3827 = STRINGTOSYMBOL( CSTRING_TSCP( "X79" ) ); c3433 = CONS( t3827, c3433 ); t3828 = STRINGTOSYMBOL( CSTRING_TSCP( "X78" ) ); c3433 = CONS( t3828, c3433 ); t3829 = STRINGTOSYMBOL( CSTRING_TSCP( "X77" ) ); c3433 = CONS( t3829, c3433 ); t3830 = STRINGTOSYMBOL( CSTRING_TSCP( "X76" ) ); c3433 = CONS( t3830, c3433 ); t3831 = STRINGTOSYMBOL( CSTRING_TSCP( "X75" ) ); c3433 = CONS( t3831, c3433 ); t3832 = STRINGTOSYMBOL( CSTRING_TSCP( "X74" ) ); c3433 = CONS( t3832, c3433 ); t3833 = STRINGTOSYMBOL( CSTRING_TSCP( "X73" ) ); c3433 = CONS( t3833, c3433 ); t3834 = STRINGTOSYMBOL( CSTRING_TSCP( "X72" ) ); c3433 = CONS( t3834, c3433 ); t3835 = STRINGTOSYMBOL( CSTRING_TSCP( "X71" ) ); c3433 = CONS( t3835, c3433 ); t3836 = STRINGTOSYMBOL( CSTRING_TSCP( "X70" ) ); c3433 = CONS( t3836, c3433 ); t3837 = STRINGTOSYMBOL( CSTRING_TSCP( "X69" ) ); c3433 = CONS( t3837, c3433 ); t3838 = STRINGTOSYMBOL( CSTRING_TSCP( "X68" ) ); c3433 = CONS( t3838, c3433 ); t3839 = STRINGTOSYMBOL( CSTRING_TSCP( "X67" ) ); c3433 = CONS( t3839, c3433 ); t3840 = STRINGTOSYMBOL( CSTRING_TSCP( "X66" ) ); c3433 = CONS( t3840, c3433 ); t3841 = STRINGTOSYMBOL( CSTRING_TSCP( "X65" ) ); c3433 = CONS( t3841, c3433 ); t3842 = STRINGTOSYMBOL( CSTRING_TSCP( "X64" ) ); c3433 = CONS( t3842, c3433 ); t3843 = STRINGTOSYMBOL( CSTRING_TSCP( "X63" ) ); c3433 = CONS( t3843, c3433 ); t3844 = STRINGTOSYMBOL( CSTRING_TSCP( "X62" ) ); c3433 = CONS( t3844, c3433 ); t3845 = STRINGTOSYMBOL( CSTRING_TSCP( "X61" ) ); c3433 = CONS( t3845, c3433 ); t3846 = STRINGTOSYMBOL( CSTRING_TSCP( "X60" ) ); c3433 = CONS( t3846, c3433 ); t3847 = STRINGTOSYMBOL( CSTRING_TSCP( "X59" ) ); c3433 = CONS( t3847, c3433 ); t3848 = STRINGTOSYMBOL( CSTRING_TSCP( "X58" ) ); c3433 = CONS( t3848, c3433 ); t3849 = STRINGTOSYMBOL( CSTRING_TSCP( "X57" ) ); c3433 = CONS( t3849, c3433 ); t3850 = STRINGTOSYMBOL( CSTRING_TSCP( "X56" ) ); c3433 = CONS( t3850, c3433 ); t3851 = STRINGTOSYMBOL( CSTRING_TSCP( "X55" ) ); c3433 = CONS( t3851, c3433 ); t3852 = STRINGTOSYMBOL( CSTRING_TSCP( "X54" ) ); c3433 = CONS( t3852, c3433 ); t3853 = STRINGTOSYMBOL( CSTRING_TSCP( "X53" ) ); c3433 = CONS( t3853, c3433 ); t3854 = STRINGTOSYMBOL( CSTRING_TSCP( "X52" ) ); c3433 = CONS( t3854, c3433 ); t3855 = STRINGTOSYMBOL( CSTRING_TSCP( "X51" ) ); c3433 = CONS( t3855, c3433 ); t3856 = STRINGTOSYMBOL( CSTRING_TSCP( "X50" ) ); c3433 = CONS( t3856, c3433 ); t3857 = STRINGTOSYMBOL( CSTRING_TSCP( "X49" ) ); c3433 = CONS( t3857, c3433 ); t3858 = STRINGTOSYMBOL( CSTRING_TSCP( "X48" ) ); c3433 = CONS( t3858, c3433 ); t3859 = STRINGTOSYMBOL( CSTRING_TSCP( "X47" ) ); c3433 = CONS( t3859, c3433 ); t3860 = STRINGTOSYMBOL( CSTRING_TSCP( "X46" ) ); c3433 = CONS( t3860, c3433 ); t3861 = STRINGTOSYMBOL( CSTRING_TSCP( "X45" ) ); c3433 = CONS( t3861, c3433 ); t3862 = STRINGTOSYMBOL( CSTRING_TSCP( "X44" ) ); c3433 = CONS( t3862, c3433 ); t3863 = STRINGTOSYMBOL( CSTRING_TSCP( "X43" ) ); c3433 = CONS( t3863, c3433 ); t3864 = STRINGTOSYMBOL( CSTRING_TSCP( "X42" ) ); c3433 = CONS( t3864, c3433 ); t3865 = STRINGTOSYMBOL( CSTRING_TSCP( "X41" ) ); c3433 = CONS( t3865, c3433 ); t3866 = STRINGTOSYMBOL( CSTRING_TSCP( "X40" ) ); c3433 = CONS( t3866, c3433 ); t3867 = STRINGTOSYMBOL( CSTRING_TSCP( "X39" ) ); c3433 = CONS( t3867, c3433 ); t3868 = STRINGTOSYMBOL( CSTRING_TSCP( "X38" ) ); c3433 = CONS( t3868, c3433 ); t3869 = STRINGTOSYMBOL( CSTRING_TSCP( "X37" ) ); c3433 = CONS( t3869, c3433 ); t3870 = STRINGTOSYMBOL( CSTRING_TSCP( "X36" ) ); c3433 = CONS( t3870, c3433 ); t3871 = STRINGTOSYMBOL( CSTRING_TSCP( "X35" ) ); c3433 = CONS( t3871, c3433 ); t3872 = STRINGTOSYMBOL( CSTRING_TSCP( "X34" ) ); c3433 = CONS( t3872, c3433 ); t3873 = STRINGTOSYMBOL( CSTRING_TSCP( "X33" ) ); c3433 = CONS( t3873, c3433 ); t3874 = STRINGTOSYMBOL( CSTRING_TSCP( "X32" ) ); c3433 = CONS( t3874, c3433 ); t3875 = STRINGTOSYMBOL( CSTRING_TSCP( "X31" ) ); c3433 = CONS( t3875, c3433 ); t3876 = STRINGTOSYMBOL( CSTRING_TSCP( "X30" ) ); c3433 = CONS( t3876, c3433 ); t3877 = STRINGTOSYMBOL( CSTRING_TSCP( "X29" ) ); c3433 = CONS( t3877, c3433 ); t3878 = STRINGTOSYMBOL( CSTRING_TSCP( "X28" ) ); c3433 = CONS( t3878, c3433 ); t3879 = STRINGTOSYMBOL( CSTRING_TSCP( "X27" ) ); c3433 = CONS( t3879, c3433 ); t3880 = STRINGTOSYMBOL( CSTRING_TSCP( "X26" ) ); c3433 = CONS( t3880, c3433 ); t3881 = STRINGTOSYMBOL( CSTRING_TSCP( "X25" ) ); c3433 = CONS( t3881, c3433 ); t3882 = STRINGTOSYMBOL( CSTRING_TSCP( "X24" ) ); c3433 = CONS( t3882, c3433 ); t3883 = STRINGTOSYMBOL( CSTRING_TSCP( "X23" ) ); c3433 = CONS( t3883, c3433 ); t3884 = STRINGTOSYMBOL( CSTRING_TSCP( "X22" ) ); c3433 = CONS( t3884, c3433 ); t3885 = STRINGTOSYMBOL( CSTRING_TSCP( "X21" ) ); c3433 = CONS( t3885, c3433 ); t3886 = STRINGTOSYMBOL( CSTRING_TSCP( "X20" ) ); c3433 = CONS( t3886, c3433 ); t3887 = STRINGTOSYMBOL( CSTRING_TSCP( "X19" ) ); c3433 = CONS( t3887, c3433 ); t3888 = STRINGTOSYMBOL( CSTRING_TSCP( "X18" ) ); c3433 = CONS( t3888, c3433 ); t3889 = STRINGTOSYMBOL( CSTRING_TSCP( "X17" ) ); c3433 = CONS( t3889, c3433 ); t3890 = STRINGTOSYMBOL( CSTRING_TSCP( "X16" ) ); c3433 = CONS( t3890, c3433 ); t3891 = STRINGTOSYMBOL( CSTRING_TSCP( "X15" ) ); c3433 = CONS( t3891, c3433 ); t3892 = STRINGTOSYMBOL( CSTRING_TSCP( "X14" ) ); c3433 = CONS( t3892, c3433 ); t3893 = STRINGTOSYMBOL( CSTRING_TSCP( "X13" ) ); c3433 = CONS( t3893, c3433 ); t3894 = STRINGTOSYMBOL( CSTRING_TSCP( "X12" ) ); c3433 = CONS( t3894, c3433 ); t3895 = STRINGTOSYMBOL( CSTRING_TSCP( "X11" ) ); c3433 = CONS( t3895, c3433 ); t3896 = STRINGTOSYMBOL( CSTRING_TSCP( "X10" ) ); c3433 = CONS( t3896, c3433 ); t3897 = STRINGTOSYMBOL( CSTRING_TSCP( "X9" ) ); c3433 = CONS( t3897, c3433 ); t3898 = STRINGTOSYMBOL( CSTRING_TSCP( "X8" ) ); c3433 = CONS( t3898, c3433 ); t3899 = STRINGTOSYMBOL( CSTRING_TSCP( "X7" ) ); c3433 = CONS( t3899, c3433 ); t3900 = STRINGTOSYMBOL( CSTRING_TSCP( "X6" ) ); c3433 = CONS( t3900, c3433 ); t3901 = STRINGTOSYMBOL( CSTRING_TSCP( "X5" ) ); c3433 = CONS( t3901, c3433 ); t3902 = STRINGTOSYMBOL( CSTRING_TSCP( "X4" ) ); c3433 = CONS( t3902, c3433 ); t3903 = STRINGTOSYMBOL( CSTRING_TSCP( "X3" ) ); c3433 = CONS( t3903, c3433 ); t3904 = STRINGTOSYMBOL( CSTRING_TSCP( "X2" ) ); c3433 = CONS( t3904, c3433 ); t3905 = STRINGTOSYMBOL( CSTRING_TSCP( "X1" ) ); c3433 = CONS( t3905, c3433 ); CONSTANTEXP( ADR( c3433 ) ); c3432 = STRINGTOSYMBOL( CSTRING_TSCP( "$LEXICAL" ) ); CONSTANTEXP( ADR( c3432 ) ); c3404 = CSTRING_TSCP( t3906 ); CONSTANTEXP( ADR( c3404 ) ); c3403 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c3403 ) ); c3338 = CSTRING_TSCP( t3907 ); CONSTANTEXP( ADR( c3338 ) ); c3337 = CSTRING_TSCP( t3908 ); CONSTANTEXP( ADR( c3337 ) ); c3336 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c3336 ) ); c3287 = CSTRING_TSCP( t3909 ); CONSTANTEXP( ADR( c3287 ) ); c3245 = EMPTYLIST; X1 = _TSCP( 23570 ); X1 = CONS( _TSCP( 23570 ), X1 ); c3245 = CONS( X1, c3245 ); X1 = _TSCP( 8722 ); X1 = CONS( _TSCP( 8722 ), X1 ); c3245 = CONS( X1, c3245 ); X1 = _TSCP( 29202 ); X1 = CONS( _TSCP( 3346 ), X1 ); c3245 = CONS( X1, c3245 ); X1 = _TSCP( 26130 ); X1 = CONS( _TSCP( 3090 ), X1 ); c3245 = CONS( X1, c3245 ); X1 = _TSCP( 28178 ); X1 = CONS( _TSCP( 2578 ), X1 ); c3245 = CONS( X1, c3245 ); X1 = _TSCP( 28178 ); X1 = CONS( _TSCP( 2578 ), X1 ); c3245 = CONS( X1, c3245 ); X1 = _TSCP( 29714 ); X1 = CONS( _TSCP( 2322 ), X1 ); c3245 = CONS( X1, c3245 ); CONSTANTEXP( ADR( c3245 ) ); c3233 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR>?" ) ); CONSTANTEXP( ADR( c3233 ) ); c3225 = CSTRING_TSCP( t3910 ); CONSTANTEXP( ADR( c3225 ) ); c3224 = STRINGTOSYMBOL( CSTRING_TSCP( "CHARC COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3954, ADR( lap_global_2dlap_2dcode_v ), EMPTYLIST ); INITIALIZEVAR( t3955, ADR( lap_emit_2dglobal_2dlap_v ), MAKEPROCEDURE( 1, 0, lap_emit_2dglobal_2dlap, EMPTYLIST ) ); INITIALIZEVAR( t3957, ADR( lap_lap_2dcode_v ), EMPTYLIST ); INITIALIZEVAR( t3958, ADR( lap_emit_2dlap_v ), MAKEPROCEDURE( 1, 0, lap_emit_2dlap, EMPTYLIST ) ); INITIALIZEVAR( t4011, ADR( lap_peep_2dlap_v ), MAKEPROCEDURE( 1, 0, lap_peep_2dlap, EMPTYLIST ) ); INITIALIZEVAR( t4266, ADR( lap_bump_2dlabel_2dgotos_v ), MAKEPROCEDURE( 2, 0, lap_bump_2dlabel_2dgotos, EMPTYLIST ) ); INITIALIZEVAR( t4287, ADR( lap_save_2dcurrent_2dlap_v ), MAKEPROCEDURE( 1, 0, lap_save_2dcurrent_2dlap, EMPTYLIST ) ); INITIALIZEVAR( t4295, ADR( lap_lap_2dtemps_2dused_v ), EMPTYLIST ); INITIALIZEVAR( t4296, ADR( lap_lap_2dtemps_2dfree_v ), EMPTYLIST ); INITIALIZEVAR( t4297, ADR( lap_lap_2dmax_2ddisplay_v ), _TSCP( 0 ) ); INITIALIZEVAR( t4298, ADR( lap_use_2dlap_2dtemp_v ), MAKEPROCEDURE( 0, 0, lap_use_2dlap_2dtemp, EMPTYLIST ) ); INITIALIZEVAR( t4312, ADR( lap_drop_2dlap_2dtemp_v ), MAKEPROCEDURE( 1, 0, lap_drop_2dlap_2dtemp, EMPTYLIST ) ); INITIALIZEVAR( t4314, ADR( lap_save_2dlap_2dtemps_v ), MAKEPROCEDURE( 0, 0, lap_save_2dlap_2dtemps, EMPTYLIST ) ); INITIALIZEVAR( t4316, ADR( lap_restore_2dlap_2dtemps_v ), MAKEPROCEDURE( 1, 0, lap_restore_2dlap_2dtemps, EMPTYLIST ) ); INITIALIZEVAR( t4318, ADR( lap_done_2dlap_2dlap_v ), EMPTYLIST ); INITIALIZEVAR( t4319, ADR( lap_done_2dlap_v ), MAKEPROCEDURE( 1, 0, lap_done_2dlap, EMPTYLIST ) ); INITIALIZEVAR( t4338, ADR( lap_resolve_2dlabel_v ), MAKEPROCEDURE( 1, 0, lap_resolve_2dlabel, EMPTYLIST ) ); INITIALIZEVAR( t4343, ADR( lap_pplap_v ), MAKEPROCEDURE( 4, 0, lap_pplap, EMPTYLIST ) ); INITIALIZEVAR( t4564, ADR( lap_pplap_2dtos_v ), EMPTYLIST ); INITIALIZEVAR( t4565, ADR( lap_pop_2dtos_v ), MAKEPROCEDURE( 0, 0, lap_pop_2dtos, EMPTYLIST ) ); INITIALIZEVAR( t4570, ADR( lap_subst_2dtos_v ), MAKEPROCEDURE( 1, 0, lap_subst_2dtos, EMPTYLIST ) ); INITIALIZEVAR( t4578, ADR( lap_pplap_2dcall_v ), MAKEPROCEDURE( 2, 0, lap_pplap_2dcall, EMPTYLIST ) ); INITIALIZEVAR( t4727, ADR( lap_pplap_2dcomma_2dlist_v ), MAKEPROCEDURE( 2, 0, lap_pplap_2dcomma_2dlist, EMPTYLIST ) ); INITIALIZEVAR( t4751, ADR( lap_pplap_2dsize_v ), MAKEPROCEDURE( 2, 0, lap_pplap_2dsize, EMPTYLIST ) ); INITIALIZEVAR( t4797, ADR( lap_downshift_v ), MAKEPROCEDURE( 1, 0, lap_downshift, EMPTYLIST ) ); INITIALIZEVAR( t4802, ADR( lap_load_2dplist_2dlap_v ), MAKEPROCEDURE( 0, 0, lap_load_2dplist_2dlap, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/lap.sc000066400000000000000000000420111203736146400156350ustar00rootroot00000000000000;;; The functions in this module are used to emit C code. At the ;;; current time, the only functions are to collect the code and then print ;;; it out when each block completes. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module lap) ;;; Global code is emitted by calling the following function. As it consists ;;; solely of declarations, no peep-hole optimization need be down. (define GLOBAL-LAP-CODE '()) (define (EMIT-GLOBAL-LAP code) (set! global-lap-code (cons code global-lap-code))) ;;; LAP-CODE is a list of the current generated code. As items are cons'ed ;;; onto it, it is in reverse order. (define LAP-CODE '()) ;;; CODE is generated by calling EMIT-CODE with a list which consists ;;; of the operator followed by any operands. At this point, a small ;;; amount of peep-hole optimization is done. (define (EMIT-LAP code) (let* ((old lap-code) (new (peep-lap code))) (if (and (log? 'peep) (not (equal? new (cons code old)))) (begin (format sc-icode "/* ") (do ((i (min 1 (- (length old) 1)) (- i 1))) ((negative? i)) (format sc-icode " ~A" (list-ref old i))) (format sc-icode " ~A~% =>" code) (do ((i (min 2 (- (length new) 1)) (- i 1))) ((negative? i)) (format sc-icode " ~A" (list-ref new i))) (format sc-icode " */~%"))))) (define (PEEP-LAP code) (cond ((null? lap-code) (set! lap-code (cons code lap-code))) ((eq? (car code) 'LABEL) (cond ((eq? (caar lap-code) 'LABEL) ; L1 => L1 ; L2 (let ((l1 (cadar lap-code)) (l2 (cadr code))) (set-id-alias! l2 l1) (set-id-gotos! (resolve-label l2) (+ (id-gotos (resolve-label l2)) (id-gotos l2))) (set! code (car lap-code)) (set! lap-code (cdr lap-code)) (emit-lap code))) ((equal? (car lap-code) (list 'goto (cadr code))) ; GOTO L => L ; L (bump-label-gotos (car lap-code) -1) (set! lap-code (cdr lap-code)) (emit-lap code)) ((and (eq? (caar lap-code) 'goto) (eq? (caadr lap-code) 'if) (eq? (resolve-label (caddr (cadr lap-code))) (resolve-label (cadr code)))) ; IF TEST GOTO L1 => IF NOT TEST GOTO L2 ; GOTO L2 L1 ; L1 (let* ((test (cadadr lap-code)) (op (and (pair? test) (car test)))) (bump-label-gotos (cadr lap-code) -1) (set! test (if (and (pair? test) (eq? (car test) 'NOT)) (cadr test) `(NOT ,test))) (set! lap-code (cons code (cons (list 'if test (cadar lap-code)) (cddr lap-code)))))) (else (set! lap-code (cons code lap-code))))) ((and (eq? (car code) 'SET) (or (and (eq? (cadr code) 'no-value) (and (not (pair? (caddr code))) (not (eq? (caddr code) 'tos)))) (eq? (caddr code) 'no-value) (equal? (cadr code) (caddr code)))) ; no-value := x => ; x := no-value => ; x := x => ; Flush Loads or Stores which are "nop's". #t) ((and lap-code (or (eq? (caar lap-code) 'goto) (and (eq? (caar lap-code) 'set) (eq? (cadar lap-code) 'return))) (not (memq (car code) '(LIT INDENT LABEL)))) ; GOTO L / RETURN => GOTO L / RETURN ; << anything but a label or end >> #t) ((and (eq? (car code) 'goto) (eq? (caar lap-code) 'label) (not (eq? (resolve-label (cadr code)) (cadar lap-code)))) ; L1 => GOTO L2 (maybe!) ; GOTO L2 (set-id-alias! (cadar lap-code) (resolve-label (cadr code))) (set-id-gotos! (resolve-label (cadr code)) (+ (id-gotos (resolve-label (cadr code))) (id-gotos (cadar lap-code)))) (set! lap-code (cdr lap-code)) (emit-lap code)) (else (bump-label-gotos code 1) (set! lap-code (cons code lap-code)))) lap-code) (define (BUMP-LABEL-GOTOS lap incdec) (let ((label (case (car lap) ((if) (caddr lap)) ((goto) (cadr lap)) (else #f)))) (if label (begin (set! label (resolve-label label)) (set-id-gotos! label (+ (id-gotos label) incdec)))))) (define (SAVE-CURRENT-LAP lap) (let ((result (list lap-code lap-temps-used lap-temps-free lap-max-display))) (if lap (begin (set! lap-code (list-ref lap 0)) (set! lap-temps-used (list-ref lap 1)) (set! lap-temps-free (list-ref lap 2)) (set! lap-max-display (list-ref lap 3))) (begin (set! lap-code '()) (set! lap-temps-used '()) (set! lap-temps-free '( X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15 X16 X17 X18 X19 X20 X21 X22 X23 X24 X25 X26 X27 X28 X29 X30 X31 X32 X33 X34 X35 X36 X37 X38 X39 X40 X41 X42 X43 X44 X45 X46 X47 X48 X49 X50 X51 X52 X53 X54 X55 X56 X57 X58 X59 X60 X61 X62 X63 X64 X65 X66 X67 X68 X69 X70 X71 X72 X73 X74 X75 X76 X77 X78 X79 X80 X81 X82 X83 X84 X85 X86 X87 X88 X89 X90 X91 X92 X93 X94 X95 X96 X97 X98 X99 X100 X101 X102 X103 X104 X105 X106 X107 X108 X109 X110 X111 X112 X113 X114 X115 X116 X117 X118 X119 X120 X121 X122 X123 X124 X125 X126 X127 X128 X129 X130 X131 X132 X133 X134 X135 X136 X137 X138 X139 X140 X141 X142 X143 X144 X145 X146 X147 X148 X149 X150 X151 X152 X153 X154 X155 X156 X157 X158 X159 X160 X161 X162 X163 X164 X165 X166 X167 X168 X169 X170 X171 X172 X173 X174 X175 X176 X177 X178 X179 X180 X181 X182 X183 X184 X185 X186 X187 X188 X189 X190 X191 X192 X193 X194 X195 X196 X197 X198 X199 X200 X201 X202 X203 X204 X205 X206 X207 X208 X209 X210 X211 X212 X213 X214 X215 X216 X217 X218 X219 X220 X221 X222 X223 X224 X225 X226 X227 X228 X229 X230 X231 X232 X233 X234 X235 X236 X237 X238 X239 X240 X241 X242 X243 X244 X245 X246 X247 X248 X249 X250 X251 X252 X253 X254 X255 X256 X257 X258 X259 X260 X261 X262 X263 X264 X265 X266 X267 X268 X269 X270 X271 X272 X273 X274 X275 X276 X277 X278 X279 X280 X281 X282 X283 X284 X285 X286 X287 X288 X289 X290 X291 X292 X293 X294 X295 X296 X297 X298 X299)) (set! lap-max-display free-display))) result)) (define LAP-TEMPS-USED '()) (define LAP-TEMPS-FREE '()) (define LAP-MAX-DISPLAY 0) (define (USE-LAP-TEMP) (if (null? lap-temps-free) (begin (report-error "Procedure required >= 300 temporary variables") 'x299) (let ((temp (car lap-temps-free))) (if (not (memq temp lap-temps-used)) (set! lap-temps-used (cons temp lap-temps-used))) (set! lap-temps-free (cdr lap-temps-free)) temp))) (define (DROP-LAP-TEMP temp) (set! lap-temps-free (cons temp lap-temps-free))) (define (SAVE-LAP-TEMPS) lap-temps-free) (define (RESTORE-LAP-TEMPS state) (set! lap-temps-free state)) (define DONE-LAP-LAP '()) (define (DONE-LAP lap) (if global-lap-code (let ((lap (list global-lap-code '() '() '()))) (set! global-lap-code '()) (done-lap lap))) (if (log? 'lap) (begin (format sc-icode "/* ") (pretty-print-$tree (reverse (car lap)) sc-icode) (format sc-icode " */~%"))) (set! done-lap-lap lap) (pplap (reverse (car lap)) (cadr lap) (cadddr lap) sc-icode)) (define (RESOLVE-LABEL label) (let ((new (id-alias label))) (if new (resolve-label new) label))) (define (PPLAP laps temps lap-max-display port) (let ((indent "") (display-base #f) (emitted-labels '())) (define (PRINT-GOTO prefix label) (if (memq label emitted-labels) (format port "~aGOBACK( ~a );~%" prefix label) (format port "~agoto ~a;~%" prefix label))) (newline port) (set! pplap-tos #f) (for-each (lambda (lap) (case (car lap) ((LIT) (display indent port) (for-each (lambda (x) (if (pair? x) (pplap-call x port) (display x port))) (cdr lap)) (newline port)) ((LABEL) (let ((label (resolve-label (cadr lap)))) (when (and (eq? label (cadr lap)) (not (zero? (id-gotos label)))) (set! emitted-labels (cons label emitted-labels)) (format port "~a:~%" label)))) ((INDENT) (set! indent (make-string (cadr lap) #\space))) ((PROC) (display "TSCP " port) (pplap-call (cdr lap) port) (newline port) (when (cddr lap) (display " TSCP " port) (pplap-comma-list (cddr lap) port) (display ";" port) (newline port))) ((LOCALS) (when temps (format port "~aTSCP " indent) (pplap-comma-list (map vname temps) port) (format port ";~%")) (if (cdr lap) (let ((base (caddr lap))) (let loop ((x base)) (when (< x lap-max-display) (format port "~aTSCP SD~a = DISPLAY( ~a );~%" indent x x) (loop (+ x 1)))) (if (not (= base lap-max-display)) (begin (set! display-base base) (format port "~aTSCP SDVAL;~%" indent))))) (if (or temps display-base) (newline port))) ((GOTO) (print-goto indent (resolve-label (cadr lap)))) ((IF) (format port "~aif ( " indent) (pplap-call (cadr lap) port) (if (< (- (write-width port) (write-count port)) 20) (format port "~%~a " indent)) (print-goto " ) " (resolve-label (caddr lap)))) ((SET) (case (cadr lap) ((NO-VALUE) (display indent port) (pplap-call (caddr lap) port) (format port ";~%")) ((TOS) (let ((new-tos (subst-tos (caddr lap)))) (if pplap-tos (report-error "PPLAP compiler error")) (set! pplap-tos new-tos))) ((RETURN) (when display-base (unless (equal? (caddr lap) "void") (format port "~aSDVAL = " indent) (pplap-call (caddr lap) port) (format port ";~%")) (let loop ((x display-base)) (when (< x lap-max-display) (format port "~aDISPLAY( ~a ) = SD~a;~%" indent x x) (loop (+ x 1))))) (let ((val (if display-base '("SDVAL") (cddr lap)))) (display indent port) (cond ((equal? (caddr lap) "void") (display "return" port)) (sc-stack-trace (pplap-call (cons "POPSTACKTRACE" val) port)) (else (pplap-call (cons "return" val) port)))) (format port ";~%")) (else (display indent port) (pplap-call (cadr lap) port) (display " = " port) (pplap-call (caddr lap) port) (format port ";~%")))) (else (display indent port) (pplap-call lap port) (format port ";~%")))) laps))) (define PPLAP-TOS '()) (define (POP-TOS) (let ((tos pplap-tos)) (set! pplap-tos #f) (if tos tos (report-error "POP-TOS compiler error")))) (define (SUBST-TOS form) (cond ((eq? form 'tos) (pop-tos)) ((pair? form) (cons (subst-tos (car form)) (subst-tos (cdr form)))) (else form))) (define (PPLAP-CALL lap port) (let ((limit (- (write-width port) 5))) (cond ((pair? lap) (cond ((eq? (car lap) 'CSTRING) (display #\" port) (for-each (lambda (c) (cond ((assq c '((#\tab . #\t) (#\newline . #\n) (#\linefeed . #\n) (#\formfeed . #\f) (#\return . #\r) (#\" . #\") (#\\ . #\\))) => (lambda (old.new) (display #\\ port) (display (cdr old.new) port))) ((or (char? c #\~)) (display #\\ port) (display (list->string (char->dl c 8 3)) port)) (else (display c port))) (when (> (write-count port) limit) (display #\\ port) (newline port))) (string->list (cadr lap))) (display #\" port)) ((and (memq (car lap) '(TRUE FALSE NOT)) (eq? (cadr lap) 'TOS)) (pplap-call (list (car lap) (pop-tos)) port)) ((and (eq? (car lap) 'NOT) (pair? (cadr lap))) (let* ((op (caadr lap)) (operands (cdadr lap)) (invert (assq op '((EQ . NEQ) (NEQ . EQ) (TRUE . FALSE) (FALSE . TRUE) (LT . GTE) (GTE . LT) (GT . LTE) (LTE . GT))))) (cond ((eq? op 'NOT) (pplap-call (car operands) port)) (invert (pplap-call (cons (cdr invert) operands) port)) (else (format port "~a( " (car lap)) (pplap-comma-list (cdr lap) port) (display " )" port))))) ((and (eq? (car lap) 'TRUE) (pair? (cadr lap)) (eq? (caadr lap) 'BOOLEAN)) (pplap-call (cadadr lap) port)) ((and (eq? (car lap) 'FALSE) (pair? (cadr lap)) (eq? (caadr lap) 'BOOLEAN)) (pplap-call `(NOT ,(cadadr lap)) port)) (else (pplap-call (car lap) port) (display "( " port) (pplap-comma-list (cdr lap) port) (display " )" port)))) ((eq? lap 'TOS) (pplap-call (pop-tos) port)) ((and (symbol? lap) (id-use lap)) (if (not (eq? (vname lap) lap)) (report-error "PPLAP looked up a symbol:" lap)) (display (vname lap) port)) (else (display lap port))))) (define (PPLAP-COMMA-LIST lap port) (let* ((indent (write-count port)) (nextline (negative? (pplap-size lap (- (write-width port) indent))))) (when lap (pplap-call (car lap) port) (when (cdr lap) (display ", " port) (when nextline (newline port) (set-write-count! port indent)) (pplap-comma-list (cdr lap) port))))) (define (PPLAP-SIZE lap left) (cond ((negative? left) left) ((null? lap) left) ((pair? lap) (if (eq? (car lap) 'CSTRING) (- left (+ (string-length (cadr lap)) 5)) (pplap-size (cdr lap) (pplap-size (car lap) (- left 4))))) ((eq? lap 'TOS) (pplap-size pplap-tos left)) (else (- left (string-length (format "~a.." (if (and (symbol? lap) (id-use lap)) (vname lap) lap))))))) ;;; Downshift a symbol name. Leave any other value unchanged. (define (DOWNSHIFT op) (if (symbol? op) (string-downcase (symbol->string op)) op)) ;;; Initialization for this module is preformed by the following procedure. (define (LOAD-PLIST-LAP) (for-each (lambda (x) (set-id-vname! x x) (set-id-use! x '$lexical)) '( X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15 X16 X17 X18 X19 X20 X21 X22 X23 X24 X25 X26 X27 X28 X29 X30 X31 X32 X33 X34 X35 X36 X37 X38 X39 X40 X41 X42 X43 X44 X45 X46 X47 X48 X49 X50 X51 X52 X53 X54 X55 X56 X57 X58 X59 X60 X61 X62 X63 X64 X65 X66 X67 X68 X69 X70 X71 X72 X73 X74 X75 X76 X77 X78 X79 X80 X81 X82 X83 X84 X85 X86 X87 X88 X89 X90 X91 X92 X93 X94 X95 X96 X97 X98 X99 X100 X101 X102 X103 X104 X105 X106 X107 X108 X109 X110 X111 X112 X113 X114 X115 X116 X117 X118 X119 X120 X121 X122 X123 X124 X125 X126 X127 X128 X129 X130 X131 X132 X133 X134 X135 X136 X137 X138 X139 X140 X141 X142 X143 X144 X145 X146 X147 X148 X149 X150 X151 X152 X153 X154 X155 X156 X157 X158 X159 X160 X161 X162 X163 X164 X165 X166 X167 X168 X169 X170 X171 X172 X173 X174 X175 X176 X177 X178 X179 X180 X181 X182 X183 X184 X185 X186 X187 X188 X189 X190 X191 X192 X193 X194 X195 X196 X197 X198 X199 X200 X201 X202 X203 X204 X205 X206 X207 X208 X209 X210 X211 X212 X213 X214 X215 X216 X217 X218 X219 X220 X221 X222 X223 X224 X225 X226 X227 X228 X229 X230 X231 X232 X233 X234 X235 X236 X237 X238 X239 X240 X241 X242 X243 X244 X245 X246 X247 X248 X249 X250 X251 X252 X253 X254 X255 X256 X257 X258 X259 X260 X261 X262 X263 X264 X265 X266 X267 X268 X269 X270 X271 X272 X273 X274 X275 X276 X277 X278 X279 X280 X281 X282 X283 X284 X285 X286 X287 X288 X289 X290 X291 X292 X293 X294 X295 X296 X297 X298 X299 TOS NO-VALUE RETURN))) scheme2c-2012.10.14/scsc/lap.sch000066400000000000000000000005671203736146400160170ustar00rootroot00000000000000;;; External functions from lap.sc (define-external (EMIT-GLOBAL-LAP code) lap) (define-external (EMIT-LAP code) lap) (define-external (SAVE-CURRENT-LAP lap) lap) (define-external (USE-LAP-TEMP) lap) (define-external (DROP-LAP-TEMP temp) lap) (define-external (SAVE-LAP-TEMPS) lap) (define-external (RESTORE-LAP-TEMPS state) lap) (define-external (DONE-LAP lap) lap) scheme2c-2012.10.14/scsc/macros.c000066400000000000000000003101321203736146400161640ustar00rootroot00000000000000 /* SCHEME->C */ #include void macros__init(); DEFSTATICTSCP( islist_v ); DEFSTATICTSCP( expand_2derror_v ); DEFSTATICTSCP( quasiquotation_v ); DEFSTATICTSCP( make_2dalpha_v ); DEFSTATICTSCP( get_v ); DEFSTATICTSCP( current_2ddefine_2dname_v ); DEFSTATICTSCP( report_2derror_v ); DEFSTATICTSCP( do_2ddefine_2dmacro_v ); DEFSTATICTSCP( do_2ddefine_2dconstant_v ); DEFSTATICTSCP( put_v ); DEFSTATICTSCP( _xpander_2a_9e90dc74_v ); DEFSTATICTSCP( _xpander_2a_ecf97896_v ); DEFSTATICTSCP( c3676 ); DEFSTATICTSCP( c3652 ); DEFSTATICTSCP( c3628 ); DEFSTATICTSCP( c3617 ); DEFSTATICTSCP( c3603 ); DEFSTATICTSCP( c3602 ); DEFSTATICTSCP( c3591 ); DEFSTATICTSCP( c3587 ); DEFSTATICTSCP( c3562 ); DEFSTATICTSCP( c3550 ); DEFSTATICTSCP( c3546 ); DEFCSTRING( t3922, "Duplicately defined symbol:" ); DEFSTATICTSCP( c3505 ); DEFCSTRING( t3923, "Argument must be a symbol:" ); DEFSTATICTSCP( c3504 ); DEFCSTRING( t3924, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c3380 ); DEFSTATICTSCP( c3379 ); DEFSTATICTSCP( c3278 ); DEFCSTRING( t3925, "DOLOOP" ); DEFSTATICTSCP( c3275 ); DEFSTATICTSCP( c3202 ); DEFSTATICTSCP( c3146 ); DEFSTATICTSCP( c3130 ); DEFSTATICTSCP( c2910 ); DEFCSTRING( t3926, "x" ); DEFSTATICTSCP( c2853 ); DEFSTATICTSCP( c2780 ); DEFCSTRING( t3927, "$_~s" ); DEFSTATICTSCP( c2763 ); DEFSTATICTSCP( c2655 ); DEFSTATICTSCP( c2544 ); DEFSTATICTSCP( c2327 ); DEFSTATICTSCP( c2326 ); DEFSTATICTSCP( c2325 ); DEFSTATICTSCP( c2314 ); DEFSTATICTSCP( c2272 ); DEFSTATICTSCP( c2242 ); DEFSTATICTSCP( c2231 ); DEFSTATICTSCP( c2210 ); DEFSTATICTSCP( c2209 ); DEFSTATICTSCP( c2133 ); DEFSTATICTSCP( c2109 ); DEFSTATICTSCP( c2104 ); DEFCSTRING( t3928, "TEST" ); DEFSTATICTSCP( c2103 ); DEFSTATICTSCP( c2098 ); DEFSTATICTSCP( c2091 ); DEFSTATICTSCP( c2086 ); DEFSTATICTSCP( c2081 ); DEFSTATICTSCP( c2080 ); DEFSTATICTSCP( c2061 ); DEFSTATICTSCP( c2035 ); DEFSTATICTSCP( c2012 ); static void init_constants() { islist_v = STRINGTOSYMBOL( CSTRING_TSCP( "ISLIST" ) ); CONSTANTEXP( ADR( islist_v ) ); expand_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXPAND-ERROR" ) ); CONSTANTEXP( ADR( expand_2derror_v ) ); quasiquotation_v = STRINGTOSYMBOL( CSTRING_TSCP( "QUASIQUOTATION" ) ); CONSTANTEXP( ADR( quasiquotation_v ) ); make_2dalpha_v = STRINGTOSYMBOL( CSTRING_TSCP( "MAKE-ALPHA" ) ); CONSTANTEXP( ADR( make_2dalpha_v ) ); get_v = STRINGTOSYMBOL( CSTRING_TSCP( "GET" ) ); CONSTANTEXP( ADR( get_v ) ); current_2ddefine_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-D\ EFINE-NAME" ) ); CONSTANTEXP( ADR( current_2ddefine_2dname_v ) ); report_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-ERROR" ) ); CONSTANTEXP( ADR( report_2derror_v ) ); do_2ddefine_2dmacro_v = STRINGTOSYMBOL( CSTRING_TSCP( "DO-DEFINE-MAC\ RO" ) ); CONSTANTEXP( ADR( do_2ddefine_2dmacro_v ) ); do_2ddefine_2dconstant_v = STRINGTOSYMBOL( CSTRING_TSCP( "DO-DEFINE-\ CONSTANT" ) ); CONSTANTEXP( ADR( do_2ddefine_2dconstant_v ) ); put_v = STRINGTOSYMBOL( CSTRING_TSCP( "PUT" ) ); CONSTANTEXP( ADR( put_v ) ); _xpander_2a_9e90dc74_v = STRINGTOSYMBOL( CSTRING_TSCP( "*SC-IDENTIFI\ ER-EXPANDER*" ) ); CONSTANTEXP( ADR( _xpander_2a_9e90dc74_v ) ); _xpander_2a_ecf97896_v = STRINGTOSYMBOL( CSTRING_TSCP( "*SC-APPLICAT\ ION-EXPANDER*" ) ); CONSTANTEXP( ADR( _xpander_2a_ecf97896_v ) ); c3676 = STRINGTOSYMBOL( CSTRING_TSCP( "UNLESS" ) ); CONSTANTEXP( ADR( c3676 ) ); c3652 = STRINGTOSYMBOL( CSTRING_TSCP( "WHEN" ) ); CONSTANTEXP( ADR( c3652 ) ); c3628 = STRINGTOSYMBOL( CSTRING_TSCP( "PUT" ) ); CONSTANTEXP( ADR( c3628 ) ); c3617 = STRINGTOSYMBOL( CSTRING_TSCP( "LIST" ) ); CONSTANTEXP( ADR( c3617 ) ); c3603 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-CONSTANT" ) ); CONSTANTEXP( ADR( c3603 ) ); c3602 = STRINGTOSYMBOL( CSTRING_TSCP( "*EXPANDER*" ) ); CONSTANTEXP( ADR( c3602 ) ); c3591 = STRINGTOSYMBOL( CSTRING_TSCP( "PUTPROP" ) ); CONSTANTEXP( ADR( c3591 ) ); c3587 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-MACRO" ) ); CONSTANTEXP( ADR( c3587 ) ); c3562 = STRINGTOSYMBOL( CSTRING_TSCP( "LOAD" ) ); CONSTANTEXP( ADR( c3562 ) ); c3550 = STRINGTOSYMBOL( CSTRING_TSCP( "COMPILE" ) ); CONSTANTEXP( ADR( c3550 ) ); c3546 = STRINGTOSYMBOL( CSTRING_TSCP( "EVAL-WHEN" ) ); CONSTANTEXP( ADR( c3546 ) ); c3505 = CSTRING_TSCP( t3922 ); CONSTANTEXP( ADR( c3505 ) ); c3504 = CSTRING_TSCP( t3923 ); CONSTANTEXP( ADR( c3504 ) ); c3380 = CSTRING_TSCP( t3924 ); CONSTANTEXP( ADR( c3380 ) ); c3379 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c3379 ) ); c3278 = EMPTYLIST; c3278 = CONS( FALSEVALUE, c3278 ); CONSTANTEXP( ADR( c3278 ) ); c3275 = CSTRING_TSCP( t3925 ); CONSTANTEXP( ADR( c3275 ) ); c3202 = STRINGTOSYMBOL( CSTRING_TSCP( "DO" ) ); CONSTANTEXP( ADR( c3202 ) ); c3146 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c3146 ) ); c3130 = EMPTYLIST; c3130 = CONS( FALSEVALUE, c3130 ); c3130 = CONS( TRUEVALUE, c3130 ); CONSTANTEXP( ADR( c3130 ) ); c2910 = STRINGTOSYMBOL( CSTRING_TSCP( "LET*" ) ); CONSTANTEXP( ADR( c2910 ) ); c2853 = CSTRING_TSCP( t3926 ); CONSTANTEXP( ADR( c2853 ) ); c2780 = STRINGTOSYMBOL( CSTRING_TSCP( "LETREC" ) ); CONSTANTEXP( ADR( c2780 ) ); c2763 = CSTRING_TSCP( t3927 ); CONSTANTEXP( ADR( c2763 ) ); c2655 = STRINGTOSYMBOL( CSTRING_TSCP( "MACRO" ) ); CONSTANTEXP( ADR( c2655 ) ); c2544 = STRINGTOSYMBOL( CSTRING_TSCP( "NOT" ) ); CONSTANTEXP( ADR( c2544 ) ); c2327 = STRINGTOSYMBOL( CSTRING_TSCP( "AND" ) ); CONSTANTEXP( ADR( c2327 ) ); c2326 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2326 ) ); c2325 = STRINGTOSYMBOL( CSTRING_TSCP( "THUNK" ) ); CONSTANTEXP( ADR( c2325 ) ); c2314 = STRINGTOSYMBOL( CSTRING_TSCP( "X" ) ); CONSTANTEXP( ADR( c2314 ) ); c2272 = STRINGTOSYMBOL( CSTRING_TSCP( "K" ) ); CONSTANTEXP( ADR( c2272 ) ); c2242 = STRINGTOSYMBOL( CSTRING_TSCP( "EQ?" ) ); CONSTANTEXP( ADR( c2242 ) ); c2231 = STRINGTOSYMBOL( CSTRING_TSCP( "EQV?" ) ); CONSTANTEXP( ADR( c2231 ) ); c2210 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2210 ) ); c2209 = STRINGTOSYMBOL( CSTRING_TSCP( "MEMV" ) ); CONSTANTEXP( ADR( c2209 ) ); c2133 = STRINGTOSYMBOL( CSTRING_TSCP( "CASE" ) ); CONSTANTEXP( ADR( c2133 ) ); c2109 = STRINGTOSYMBOL( CSTRING_TSCP( "COND-CLAUSE" ) ); CONSTANTEXP( ADR( c2109 ) ); c2104 = STRINGTOSYMBOL( CSTRING_TSCP( "OR" ) ); CONSTANTEXP( ADR( c2104 ) ); c2103 = CSTRING_TSCP( t3928 ); CONSTANTEXP( ADR( c2103 ) ); c2098 = STRINGTOSYMBOL( CSTRING_TSCP( "LET" ) ); CONSTANTEXP( ADR( c2098 ) ); c2091 = STRINGTOSYMBOL( CSTRING_TSCP( "COND" ) ); CONSTANTEXP( ADR( c2091 ) ); c2086 = STRINGTOSYMBOL( CSTRING_TSCP( "BEGIN" ) ); CONSTANTEXP( ADR( c2086 ) ); c2081 = STRINGTOSYMBOL( CSTRING_TSCP( "IF" ) ); CONSTANTEXP( ADR( c2081 ) ); c2080 = STRINGTOSYMBOL( CSTRING_TSCP( "ELSE" ) ); CONSTANTEXP( ADR( c2080 ) ); c2061 = STRINGTOSYMBOL( CSTRING_TSCP( "=>" ) ); CONSTANTEXP( ADR( c2061 ) ); c2035 = EMPTYLIST; c2035 = CONS( c2080, c2035 ); CONSTANTEXP( ADR( c2035 ) ); c2012 = STRINGTOSYMBOL( CSTRING_TSCP( "QUASIQUOTE" ) ); CONSTANTEXP( ADR( c2012 ) ); } DEFTSCP( macros_old_2dmacro_v ); DEFCSTRING( t3929, "OLD-MACRO" ); TSCP macros_l2003( e2004, e2005, c3931 ) TSCP e2004, e2005, c3931; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "macros_l2003 [inside OLD-MACRO]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3931, 0 ); X5 = DISPLAY( 0 ); X5 = UNKNOWNCALL( X5, 1 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( e2004, PROCEDURE_CLOSURE( X5 ) ); X3 = e2005; X3 = UNKNOWNCALL( X3, 2 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( X4, e2005, PROCEDURE_CLOSURE( X3 ) ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } TSCP macros_old_2dmacro( e2002 ) TSCP e2002; { TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t3929 ); DISPLAY( 0 ) = e2002; SDVAL = MAKEPROCEDURE( 2, 0, macros_l2003, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } DEFTSCP( macros_quasiquote_2dmacro_v ); DEFCSTRING( t3933, "QUASIQUOTE-MACRO" ); TSCP macros_quasiquote_2dmacro( e2008 ) TSCP e2008; { TSCP X1; PUSHSTACKTRACE( t3933 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( e2008, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L3935; X1 = SYMBOL_VALUE( quasiquotation_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( _TSCP( 4 ), e2008, PROCEDURE_CLOSURE( X1 ) ) ); L3935: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2012, e2008, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( macros_cond_2dmacro_v ); DEFCSTRING( t3937, "COND-MACRO" ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( sc_d_2dsymbol_ab4b4447, XAL1( TSCP ) ); EXTERNTSCP( sc_d_2dsymbol_ab4b4447_v ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); TSCP macros_cond_2dmacro( e2017 ) TSCP e2017; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3937 ); if ( EQ( TSCPTAG( e2017 ), PAIRTAG ) ) goto L3940; scrt1__24__cdr_2derror( e2017 ); L3940: X3 = PAIR_CDR( e2017 ); if ( FALSE( X3 ) ) goto L3943; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3946; scrt1__24__car_2derror( X3 ); L3946: X2 = PAIR_CAR( X3 ); goto L3944; L3943: X2 = X3; L3944: if ( FALSE( X2 ) ) goto L3949; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3952; scrt1__24__cdr_2derror( X3 ); L3952: X1 = PAIR_CDR( X3 ); goto L3950; L3949: X1 = X2; L3950: if ( EQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3955; X4 = BOOLEAN( NEQ( TSCPTAG( X2 ), PAIRTAG ) ); if ( TRUE( X4 ) ) goto L3961; if ( TRUE( scrt1_equal_3f( X2, c2035 ) ) ) goto L3961; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3967; scrt1__24__cdr_2derror( X2 ); L3967: X5 = PAIR_CDR( X2 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L3964; X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_cons_2a( c2091, CONS( scrt1_append_2dtwo( X1, X6 ), EMPTYLIST ) ), X5 ); POPSTACKTRACE( scrt1_cons_2a( c2104, CONS( PAIR_CAR( X2 ), X5 ) ) ); L3964: if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3971; scrt1__24__cdr_2derror( X2 ); L3971: X7 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3974; scrt1__24__car_2derror( X7 ); L3974: X6 = PAIR_CAR( X7 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2061 ) ) ); if ( FALSE( X5 ) ) goto L3990; X6 = scrt1_length( X2 ); if ( BITAND( BITOR( _S2CINT( X6 ), _S2CINT( _TSCP( 12 ) ) ), 3 ) ) goto L3982; if ( EQ( _S2CUINT( X6 ), _S2CUINT( _TSCP( 12 ) ) ) ) goto L3986; goto L3990; L3982: if ( TRUE( scrt2__3d_2dtwo( X6, _TSCP( 12 ) ) ) ) goto L3986; goto L3990; L3955: POPSTACKTRACE( FALSEVALUE ); L3961: X3 = SYMBOL_VALUE( expand_2derror_v ); X3 = UNKNOWNCALL( X3, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X3 ) )( c2109, e2017, PROCEDURE_CLOSURE( X3 ) ) ); L3986: X3 = sc_d_2dsymbol_ab4b4447( c2103 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_cons_2a( c2091, CONS( scrt1_append_2dtwo( X1, X6 ), EMPTYLIST ) ), X5 ); X6 = scrt1_caddr( X2 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_cons_2a( X6, CONS( X3, X7 ) ), X5 ); X4 = CONS( scrt1_cons_2a( c2081, CONS( X3, X5 ) ), X4 ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X5 = scrt1_cons_2a( X3, CONS( PAIR_CAR( X2 ), X6 ) ); POPSTACKTRACE( scrt1_cons_2a( c2098, CONS( scrt1_cons_2a( X5, CONS( EMPTYLIST, EMPTYLIST ) ), X4 ) ) ); L3990: X3 = PAIR_CAR( X2 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2080 ) ) ) goto L3993; X3 = PAIR_CDR( X2 ); X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2086, CONS( scrt1_append_2dtwo( X3, X4 ), EMPTYLIST ) ) ); L3993: X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c2091, CONS( scrt1_append_2dtwo( X1, X4 ), EMPTYLIST ) ), X3 ); X4 = PAIR_CDR( X2 ); X5 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c2086, CONS( scrt1_append_2dtwo( X4, X5 ), EMPTYLIST ) ), X3 ); POPSTACKTRACE( scrt1_cons_2a( c2081, CONS( PAIR_CAR( X2 ), X3 ) ) ); } DEFTSCP( macros_case_2dmacro_v ); DEFCSTRING( t3999, "CASE-MACRO" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt1_caaar, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caaar_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); TSCP macros_case_2dmacro( e2132 ) TSCP e2132; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3999 ); X5 = SYMBOL_VALUE( islist_v ); X5 = UNKNOWNCALL( X5, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X5 ) )( e2132, _TSCP( 12 ), PROCEDURE_CLOSURE( X5 ) ) ) ) goto L4001; if ( EQ( TSCPTAG( e2132 ), PAIRTAG ) ) goto L4005; scrt1__24__cdr_2derror( e2132 ); L4005: X5 = PAIR_CDR( e2132 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4008; scrt1__24__car_2derror( X5 ); L4008: X2 = PAIR_CAR( X5 ); X5 = SYMBOL_VALUE( make_2dalpha_v ); X5 = UNKNOWNCALL( X5, 1 ); X3 = VIA( PROCEDURE_CODE( X5 ) )( c2272, PROCEDURE_CLOSURE( X5 ) ); X5 = PAIR_CDR( e2132 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4012; scrt1__24__cdr_2derror( X5 ); L4012: X4 = PAIR_CDR( X5 ); X1 = EMPTYLIST; L4014: X1 = CONS( X1, EMPTYLIST ); X5 = BOOLEAN( NEQ( TSCPTAG( X4 ), PAIRTAG ) ); if ( TRUE( X5 ) ) goto L4019; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4023; scrt1__24__car_2derror( X4 ); L4023: X7 = PAIR_CAR( X4 ); X6 = SYMBOL_VALUE( islist_v ); X6 = UNKNOWNCALL( X6, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X6 ) )( X7, _TSCP( 8 ), PROCEDURE_CLOSURE( X6 ) ) ) ) goto L4019; X7 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L4030; scrt1__24__car_2derror( X7 ); L4030: X6 = PAIR_CAR( X7 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( c2080 ) ) ) goto L4026; X7 = PAIR_CAR( X4 ); X6 = sc_cons( X7, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X6 ); goto L4051; L4026: X9 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4035; scrt1__24__car_2derror( X9 ); L4035: X8 = PAIR_CAR( X9 ); X7 = scrt1_length( X8 ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4038; X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( _TSCP( 4 ) ) ) ); goto L4039; L4038: X6 = scrt2__3d_2dtwo( X7, _TSCP( 4 ) ); L4039: if ( FALSE( X6 ) ) goto L4050; X7 = scrt1_caaar( X4 ); if ( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), DOUBLEFLOATTAG ) ) ) goto L4050; X10 = CONS( EMPTYLIST, EMPTYLIST ); X11 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( scrt1_cons_2a( c2210, CONS( scrt1_caaar( X4 ), X11 ) ), X10 ); X9 = scrt1_cons_2a( c2242, CONS( X3, X10 ) ); X11 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L4048; scrt1__24__cdr_2derror( X11 ); L4048: X10 = PAIR_CDR( X11 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( X9, CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ) ); X7 = sc_cons( X8, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X7 ); goto L4051; L4050: X9 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4054; scrt1__24__car_2derror( X9 ); L4054: X8 = PAIR_CAR( X9 ); X7 = scrt1_length( X8 ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4058; if ( EQ( _S2CUINT( X7 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L4062; goto L4063; L4058: if ( TRUE( scrt2__3d_2dtwo( X7, _TSCP( 4 ) ) ) ) goto L4062; L4063: X10 = CONS( EMPTYLIST, EMPTYLIST ); X11 = CONS( EMPTYLIST, EMPTYLIST ); X12 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L4068; scrt1__24__car_2derror( X12 ); L4068: X10 = CONS( scrt1_cons_2a( c2210, CONS( PAIR_CAR( X12 ), X11 ) ), X10 ); X9 = scrt1_cons_2a( c2209, CONS( X3, X10 ) ); X11 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L4072; scrt1__24__cdr_2derror( X11 ); L4072: X10 = PAIR_CDR( X11 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( X9, CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ) ); X7 = sc_cons( X8, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X7 ); goto L4051; L4062: X10 = CONS( EMPTYLIST, EMPTYLIST ); X11 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( scrt1_cons_2a( c2210, CONS( scrt1_caaar( X4 ), X11 ) ), X10 ); X9 = scrt1_cons_2a( c2231, CONS( X3, X10 ) ); X11 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L4076; scrt1__24__cdr_2derror( X11 ); L4076: X10 = PAIR_CDR( X11 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( X9, CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ) ); X7 = sc_cons( X8, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X7 ); L4051: X6 = PAIR_CDR( X4 ); X1 = PAIR_CAR( X1 ); X4 = X6; GOBACK( L4014 ); L4001: X5 = SYMBOL_VALUE( expand_2derror_v ); X5 = UNKNOWNCALL( X5, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X5 ) )( c2133, e2132, PROCEDURE_CLOSURE( X5 ) ) ); L4019: if ( FALSE( X4 ) ) goto L4079; X5 = SYMBOL_VALUE( expand_2derror_v ); X5 = UNKNOWNCALL( X5, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X5 ) )( c2133, e2132, PROCEDURE_CLOSURE( X5 ) ) ); L4079: X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_reverse( PAIR_CAR( X1 ) ); X7 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_cons_2a( c2091, CONS( scrt1_append_2dtwo( X6, X7 ), EMPTYLIST ) ), X5 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( X3, CONS( X2, X7 ) ); POPSTACKTRACE( scrt1_cons_2a( c2098, CONS( scrt1_cons_2a( X6, CONS( EMPTYLIST, EMPTYLIST ) ), X5 ) ) ); } DEFTSCP( macros_and_2dmacro_v ); DEFCSTRING( t4081, "AND-MACRO" ); EXTERNTSCPP( macros_boolean_2dconstant, XAL1( TSCP ) ); EXTERNTSCP( macros_boolean_2dconstant_v ); TSCP macros_and_2dmacro( e2286 ) TSCP e2286; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4081 ); if ( EQ( TSCPTAG( e2286 ), PAIRTAG ) ) goto L4084; scrt1__24__cdr_2derror( e2286 ); L4084: if ( FALSE( PAIR_CDR( e2286 ) ) ) goto L4086; X3 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4090; scrt1__24__car_2derror( X3 ); L4090: X2 = PAIR_CAR( X3 ); X1 = macros_boolean_2dconstant( X2 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4093; if ( FALSE( PAIR_CAR( X1 ) ) ) goto L4096; X2 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4100; scrt1__24__cdr_2derror( X2 ); L4100: if ( FALSE( PAIR_CDR( X2 ) ) ) goto L4102; X4 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4106; scrt1__24__cdr_2derror( X4 ); L4106: X3 = PAIR_CDR( X4 ); X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2327, CONS( scrt1_append_2dtwo( X3, X4 ), EMPTYLIST ) ) ); L4102: POPSTACKTRACE( PAIR_CAR( X1 ) ); L4096: POPSTACKTRACE( PAIR_CAR( X1 ) ); L4093: X3 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4114; scrt1__24__cdr_2derror( X3 ); L4114: X2 = PAIR_CDR( X3 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4110; X2 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4118; scrt1__24__car_2derror( X2 ); L4118: POPSTACKTRACE( PAIR_CAR( X2 ) ); L4110: X5 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4122; scrt1__24__cdr_2derror( X5 ); L4122: X4 = PAIR_CDR( X5 ); X5 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2327, CONS( scrt1_append_2dtwo( X4, X5 ), EMPTYLIST ) ); X2 = macros_boolean_2dconstant( X3 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4125; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( c2314, X4 ); X4 = CONS( PAIR_CAR( X2 ), X4 ); X3 = CONS( scrt1_cons_2a( c2081, CONS( c2314, X4 ) ), X3 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4130; scrt1__24__car_2derror( X6 ); L4130: X4 = scrt1_cons_2a( c2314, CONS( PAIR_CAR( X6 ), X5 ) ); POPSTACKTRACE( scrt1_cons_2a( c2098, CONS( scrt1_cons_2a( X4, CONS( EMPTYLIST, EMPTYLIST ) ), X3 ) ) ); L4125: X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( c2314, X4 ); X4 = CONS( scrt1_cons_2a( c2325, CONS( EMPTYLIST, EMPTYLIST ) ), X4 ); X3 = CONS( scrt1_cons_2a( c2081, CONS( c2314, X4 ) ), X3 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4134; scrt1__24__car_2derror( X6 ); L4134: X4 = scrt1_cons_2a( c2314, CONS( PAIR_CAR( X6 ), X5 ) ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X9 = PAIR_CDR( e2286 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4138; scrt1__24__cdr_2derror( X9 ); L4138: X8 = PAIR_CDR( X9 ); X9 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X7 = CONS( scrt1_cons_2a( c2327, CONS( scrt1_append_2dtwo( X8, X9 ), EMPTYLIST ) ), X7 ); POPSTACKTRACE( scrt1_cons_2a( c2098, CONS( scrt1_cons_2a( X4, CONS( scrt1_cons_2a( c2325, CONS( scrt1_cons_2a( c2326, CONS( EMPTYLIST, X7 ) ), X6 ) ), X5 ) ), X3 ) ) ); L4086: POPSTACKTRACE( TRUEVALUE ); } DEFTSCP( macros_or_2dmacro_v ); DEFCSTRING( t4140, "OR-MACRO" ); TSCP macros_or_2dmacro( e2417 ) TSCP e2417; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4140 ); if ( EQ( TSCPTAG( e2417 ), PAIRTAG ) ) goto L4143; scrt1__24__cdr_2derror( e2417 ); L4143: if ( FALSE( PAIR_CDR( e2417 ) ) ) goto L4145; X3 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4149; scrt1__24__car_2derror( X3 ); L4149: X2 = PAIR_CAR( X3 ); X1 = macros_boolean_2dconstant( X2 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4152; if ( FALSE( PAIR_CAR( X1 ) ) ) goto L4155; POPSTACKTRACE( PAIR_CAR( X1 ) ); L4155: X2 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4160; scrt1__24__cdr_2derror( X2 ); L4160: if ( FALSE( PAIR_CDR( X2 ) ) ) goto L4162; X4 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4166; scrt1__24__cdr_2derror( X4 ); L4166: X3 = PAIR_CDR( X4 ); X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2104, CONS( scrt1_append_2dtwo( X3, X4 ), EMPTYLIST ) ) ); L4162: POPSTACKTRACE( PAIR_CAR( X1 ) ); L4152: X3 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4173; scrt1__24__cdr_2derror( X3 ); L4173: X2 = PAIR_CDR( X3 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L4169; X2 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4177; scrt1__24__car_2derror( X2 ); L4177: POPSTACKTRACE( PAIR_CAR( X2 ) ); L4169: X5 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4181; scrt1__24__cdr_2derror( X5 ); L4181: X4 = PAIR_CDR( X5 ); X5 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( c2104, CONS( scrt1_append_2dtwo( X4, X5 ), EMPTYLIST ) ); X2 = macros_boolean_2dconstant( X3 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4184; X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( PAIR_CAR( X2 ), X4 ); X4 = CONS( c2314, X4 ); X3 = CONS( scrt1_cons_2a( c2081, CONS( c2314, X4 ) ), X3 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4189; scrt1__24__car_2derror( X6 ); L4189: X4 = scrt1_cons_2a( c2314, CONS( PAIR_CAR( X6 ), X5 ) ); POPSTACKTRACE( scrt1_cons_2a( c2098, CONS( scrt1_cons_2a( X4, CONS( EMPTYLIST, EMPTYLIST ) ), X3 ) ) ); L4184: X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( scrt1_cons_2a( c2325, CONS( EMPTYLIST, EMPTYLIST ) ), X4 ); X4 = CONS( c2314, X4 ); X3 = CONS( scrt1_cons_2a( c2081, CONS( c2314, X4 ) ), X3 ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4193; scrt1__24__car_2derror( X6 ); L4193: X4 = scrt1_cons_2a( c2314, CONS( PAIR_CAR( X6 ), X5 ) ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X9 = PAIR_CDR( e2417 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4197; scrt1__24__cdr_2derror( X9 ); L4197: X8 = PAIR_CDR( X9 ); X9 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X7 = CONS( scrt1_cons_2a( c2104, CONS( scrt1_append_2dtwo( X8, X9 ), EMPTYLIST ) ), X7 ); POPSTACKTRACE( scrt1_cons_2a( c2098, CONS( scrt1_cons_2a( X4, CONS( scrt1_cons_2a( c2325, CONS( scrt1_cons_2a( c2326, CONS( EMPTYLIST, X7 ) ), X6 ) ), X5 ) ), X3 ) ) ); L4145: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( macros_not_2dmacro_v ); DEFCSTRING( t4199, "NOT-MACRO" ); TSCP macros_not_2dmacro( e2543 ) TSCP e2543; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4199 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( e2543, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L4201; if ( EQ( TSCPTAG( e2543 ), PAIRTAG ) ) goto L4204; scrt1__24__cdr_2derror( e2543 ); L4204: X3 = PAIR_CDR( e2543 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4207; scrt1__24__car_2derror( X3 ); L4207: X2 = PAIR_CAR( X3 ); X1 = macros_boolean_2dconstant( X2 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4210; if ( TRUE( PAIR_CAR( X1 ) ) ) goto L4213; POPSTACKTRACE( TRUEVALUE ); L4213: POPSTACKTRACE( FALSEVALUE ); L4210: X2 = CONS( EMPTYLIST, EMPTYLIST ); X2 = CONS( TRUEVALUE, X2 ); X2 = CONS( FALSEVALUE, X2 ); X3 = PAIR_CDR( e2543 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4217; scrt1__24__car_2derror( X3 ); L4217: POPSTACKTRACE( scrt1_cons_2a( c2081, CONS( PAIR_CAR( X3 ), X2 ) ) ); L4201: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2544, e2543, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( macros_boolean_2dconstant_v ); DEFCSTRING( t4219, "BOOLEAN-CONSTANT" ); EXTERNTSCPP( scrt1_boolean_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt1_boolean_3f_v ); TSCP macros_boolean_2dconstant( e2575 ) TSCP e2575; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4219 ); L4220: if ( NEQ( TSCPTAG( e2575 ), FIXNUMTAG ) ) goto L4221; X1 = TRUEVALUE; goto L4222; L4221: X1 = BOOLEAN( AND( EQ( TSCPTAG( e2575 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2575 ), DOUBLEFLOATTAG ) ) ); L4222: if ( TRUE( X1 ) ) goto L4227; X2 = scrt1_boolean_3f( e2575 ); if ( TRUE( X2 ) ) goto L4227; if ( AND( EQ( TSCPTAG( e2575 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2575 ), STRINGTAG ) ) ) goto L4227; if ( NEQ( TSCPTAG( e2575 ), PAIRTAG ) ) goto L4251; X3 = PAIR_CAR( e2575 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2210 ) ) ) goto L4251; X3 = PAIR_CDR( e2575 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4246; scrt1__24__car_2derror( X3 ); L4246: if ( TRUE( PAIR_CAR( X3 ) ) ) goto L4227; L4251: if ( NOT( AND( EQ( TSCPTAG( e2575 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e2575 ), SYMBOLTAG ) ) ) ) goto L4252; X2 = SYMBOL_VALUE( get_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2575, c2655, PROCEDURE_CLOSURE( X2 ) ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4255; e2575 = PAIR_CAR( X1 ); GOBACK( L4220 ); L4255: POPSTACKTRACE( FALSEVALUE ); L4252: if ( NEQ( TSCPTAG( e2575 ), PAIRTAG ) ) goto L4258; X1 = PAIR_CAR( e2575 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2544 ) ) ) goto L4262; e2575 = macros_not_2dmacro( e2575 ); GOBACK( L4220 ); L4262: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2327 ) ) ) goto L4264; e2575 = macros_and_2dmacro( e2575 ); GOBACK( L4220 ); L4264: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2104 ) ) ) goto L4266; e2575 = macros_or_2dmacro( e2575 ); GOBACK( L4220 ); L4266: POPSTACKTRACE( FALSEVALUE ); L4258: POPSTACKTRACE( FALSEVALUE ); L4227: X1 = sc_cons( e2575, EMPTYLIST ); POPSTACKTRACE( X1 ); } DEFTSCP( macros_begin_2dmacro_v ); DEFCSTRING( t4269, "BEGIN-MACRO" ); TSCP macros_begin_2dmacro( e2660 ) TSCP e2660; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4269 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( e2660, _TSCP( 8 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L4271; X1 = scrt1_length( e2660 ); if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 8 ) ) ), 3 ) ) goto L4275; if ( EQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( 8 ) ) ) ) goto L4279; goto L4280; L4275: if ( TRUE( scrt2__3d_2dtwo( X1, _TSCP( 8 ) ) ) ) goto L4279; goto L4280; L4271: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2086, e2660, PROCEDURE_CLOSURE( X1 ) ) ); L4279: if ( EQ( TSCPTAG( e2660 ), PAIRTAG ) ) goto L4284; scrt1__24__cdr_2derror( e2660 ); L4284: X1 = PAIR_CDR( e2660 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4287; scrt1__24__car_2derror( X1 ); L4287: POPSTACKTRACE( PAIR_CAR( X1 ) ); L4280: if ( EQ( TSCPTAG( e2660 ), PAIRTAG ) ) goto L4290; scrt1__24__cdr_2derror( e2660 ); L4290: X3 = PAIR_CDR( e2660 ); X4 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X2 = CONS( scrt1_append_2dtwo( X3, X4 ), EMPTYLIST ); X1 = scrt1_cons_2a( c2326, CONS( EMPTYLIST, X2 ) ); POPSTACKTRACE( scrt1_cons_2a( X1, CONS( EMPTYLIST, EMPTYLIST ) ) ); } DEFTSCP( macros_let_2dmacro_v ); DEFCSTRING( t4292, "LET-MACRO" ); EXTERNTSCPP( scrt1_cadar, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadar_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); TSCP macros_let_2dmacro( e2686 ) TSCP e2686; { TSCP X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4292 ); X9 = SYMBOL_VALUE( islist_v ); X9 = UNKNOWNCALL( X9, 2 ); X8 = VIA( PROCEDURE_CODE( X9 ) )( e2686, _TSCP( 12 ), PROCEDURE_CLOSURE( X9 ) ); if ( FALSE( X8 ) ) goto L4343; if ( EQ( TSCPTAG( e2686 ), PAIRTAG ) ) goto L4301; scrt1__24__cdr_2derror( e2686 ); L4301: X11 = PAIR_CDR( e2686 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L4304; scrt1__24__car_2derror( X11 ); L4304: X10 = PAIR_CAR( X11 ); X9 = SYMBOL_VALUE( islist_v ); X9 = UNKNOWNCALL( X9, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X9 ) )( X10, _TSCP( 0 ), PROCEDURE_CLOSURE( X9 ) ) ) ) goto L4343; X9 = PAIR_CDR( e2686 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4309; scrt1__24__car_2derror( X9 ); L4309: X7 = PAIR_CAR( X9 ); X6 = EMPTYLIST; X5 = EMPTYLIST; L4311: X5 = CONS( X5, EMPTYLIST ); X6 = CONS( X6, EMPTYLIST ); X9 = BOOLEAN( NEQ( TSCPTAG( X7 ), PAIRTAG ) ); if ( TRUE( X9 ) ) goto L4316; if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L4320; scrt1__24__car_2derror( X7 ); L4320: X12 = PAIR_CAR( X7 ); X11 = SYMBOL_VALUE( islist_v ); X11 = UNKNOWNCALL( X11, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X11 ) )( X12, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X11 ) ) ) ) goto L4317; X10 = FALSEVALUE; goto L4318; L4317: X10 = TRUEVALUE; L4318: if ( TRUE( X10 ) ) goto L4316; if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L4330; scrt1__24__car_2derror( X7 ); L4330: X12 = PAIR_CAR( X7 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L4333; scrt1__24__car_2derror( X12 ); L4333: X11 = PAIR_CAR( X12 ); if ( NOT( AND( EQ( TSCPTAG( X11 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X11 ), SYMBOLTAG ) ) ) ) goto L4316; if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L4337; scrt1__24__car_2derror( X7 ); L4337: X13 = PAIR_CAR( X7 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L4340; scrt1__24__car_2derror( X13 ); L4340: X12 = PAIR_CAR( X13 ); X11 = sc_cons( X12, PAIR_CAR( X6 ) ); SETGEN( PAIR_CAR( X6 ), X11 ); X12 = scrt1_cadar( X7 ); X11 = sc_cons( X12, PAIR_CAR( X5 ) ); SETGEN( PAIR_CAR( X5 ), X11 ); X11 = PAIR_CDR( X7 ); X5 = PAIR_CAR( X5 ); X6 = PAIR_CAR( X6 ); X7 = X11; GOBACK( L4311 ); L4343: X9 = SYMBOL_VALUE( islist_v ); X9 = UNKNOWNCALL( X9, 2 ); X8 = VIA( PROCEDURE_CODE( X9 ) )( e2686, _TSCP( 16 ), PROCEDURE_CLOSURE( X9 ) ); if ( FALSE( X8 ) ) goto L4395; if ( EQ( TSCPTAG( e2686 ), PAIRTAG ) ) goto L4351; scrt1__24__cdr_2derror( e2686 ); L4351: X10 = PAIR_CDR( e2686 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L4354; scrt1__24__car_2derror( X10 ); L4354: X9 = PAIR_CAR( X10 ); if ( NOT( AND( EQ( TSCPTAG( X9 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X9 ), SYMBOLTAG ) ) ) ) goto L4395; X4 = scrt1_caddr( e2686 ); X9 = _TSCP( 0 ); X1 = EMPTYLIST; X2 = EMPTYLIST; X3 = EMPTYLIST; L4357: X3 = CONS( X3, EMPTYLIST ); X2 = CONS( X2, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); X10 = BOOLEAN( NEQ( TSCPTAG( X4 ), PAIRTAG ) ); if ( TRUE( X10 ) ) goto L4362; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4366; scrt1__24__car_2derror( X4 ); L4366: X13 = PAIR_CAR( X4 ); X12 = SYMBOL_VALUE( islist_v ); X12 = UNKNOWNCALL( X12, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X12 ) )( X13, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X12 ) ) ) ) goto L4363; X11 = FALSEVALUE; goto L4364; L4363: X11 = TRUEVALUE; L4364: if ( TRUE( X11 ) ) goto L4362; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4376; scrt1__24__car_2derror( X4 ); L4376: X13 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L4379; scrt1__24__car_2derror( X13 ); L4379: X12 = PAIR_CAR( X13 ); if ( NOT( AND( EQ( TSCPTAG( X12 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X12 ), SYMBOLTAG ) ) ) ) goto L4362; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4383; scrt1__24__car_2derror( X4 ); L4383: X14 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L4386; scrt1__24__car_2derror( X14 ); L4386: X13 = PAIR_CAR( X14 ); X12 = sc_cons( X13, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X12 ); X14 = scrt6_format( c2763, CONS( X9, EMPTYLIST ) ); X13 = sc_d_2dsymbol_ab4b4447( X14 ); X12 = sc_cons( X13, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X12 ); X16 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L4389; scrt1__24__car_2derror( X16 ); L4389: X15 = PAIR_CAR( X16 ); X17 = scrt1_cadar( X4 ); X16 = sc_cons( X17, EMPTYLIST ); X14 = sc_cons( X15, X16 ); X13 = X14; X12 = sc_cons( X13, PAIR_CAR( X3 ) ); SETGEN( PAIR_CAR( X3 ), X12 ); X12 = PAIR_CDR( X4 ); if ( BITAND( BITOR( _S2CINT( X9 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L4393; X13 = _TSCP( IPLUS( _S2CINT( X9 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L4394; L4393: X13 = scrt2__2b_2dtwo( X9, _TSCP( 4 ) ); L4394: X3 = PAIR_CAR( X3 ); X2 = PAIR_CAR( X2 ); X1 = PAIR_CAR( X1 ); X9 = X13; X4 = X12; GOBACK( L4357 ); L4395: X8 = SYMBOL_VALUE( expand_2derror_v ); X8 = UNKNOWNCALL( X8, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X8 ) )( c2098, e2686, PROCEDURE_CLOSURE( X8 ) ) ); L4316: if ( FALSE( X7 ) ) goto L4396; X8 = SYMBOL_VALUE( expand_2derror_v ); X8 = UNKNOWNCALL( X8, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X8 ) )( c2098, e2686, PROCEDURE_CLOSURE( X8 ) ) ); L4396: X11 = PAIR_CDR( e2686 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L4400; scrt1__24__cdr_2derror( X11 ); L4400: X10 = PAIR_CDR( X11 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ); if ( NEQ( _S2CUINT( PAIR_CAR( X6 ) ), _S2CUINT( EMPTYLIST ) ) ) goto L4402; X10 = sc_d_2dsymbol_ab4b4447( c2853 ); goto L4403; L4402: X10 = scrt1_reverse( PAIR_CAR( X6 ) ); L4403: X8 = scrt1_cons_2a( c2326, CONS( X10, X9 ) ); X9 = scrt1_reverse( PAIR_CAR( X5 ) ); X10 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( X8, CONS( scrt1_append_2dtwo( X9, X10 ), EMPTYLIST ) ) ); L4362: if ( FALSE( X4 ) ) goto L4404; X8 = SYMBOL_VALUE( expand_2derror_v ); X8 = UNKNOWNCALL( X8, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X8 ) )( c2098, e2686, PROCEDURE_CLOSURE( X8 ) ) ); L4404: X8 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X11 = PAIR_CDR( e2686 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L4408; scrt1__24__car_2derror( X11 ); L4408: X10 = PAIR_CAR( X11 ); X11 = scrt1_reverse( PAIR_CAR( X1 ) ); X12 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_cons_2a( X10, CONS( scrt1_append_2dtwo( X11, X12 ), EMPTYLIST ) ), X9 ); X12 = PAIR_CDR( e2686 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L4412; scrt1__24__car_2derror( X12 ); L4412: X11 = PAIR_CAR( X12 ); X12 = CONS( EMPTYLIST, EMPTYLIST ); X14 = scrt1_cdddr( e2686 ); X15 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X13 = CONS( scrt1_append_2dtwo( X14, X15 ), EMPTYLIST ); X10 = scrt1_cons_2a( X11, CONS( scrt1_cons_2a( c2326, CONS( scrt1_reverse( PAIR_CAR( X2 ) ), X13 ) ), X12 ) ); X8 = CONS( scrt1_cons_2a( c2780, CONS( scrt1_cons_2a( X10, CONS( EMPTYLIST, EMPTYLIST ) ), X9 ) ), X8 ); POPSTACKTRACE( scrt1_cons_2a( c2098, CONS( scrt1_reverse( PAIR_CAR( X3 ) ), X8 ) ) ); } DEFTSCP( macros_let_2a_2dmacro_v ); DEFCSTRING( t4414, "LET*-MACRO" ); EXTERNTSCPP( macros_let_2a_2dresult, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( macros_let_2a_2dresult_v ); TSCP macros_let_2a_2dmacro( e2876 ) TSCP e2876; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4414 ); X5 = SYMBOL_VALUE( islist_v ); X5 = UNKNOWNCALL( X5, 2 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( e2876, _TSCP( 12 ), PROCEDURE_CLOSURE( X5 ) ); if ( FALSE( X4 ) ) goto L4465; if ( EQ( TSCPTAG( e2876 ), PAIRTAG ) ) goto L4423; scrt1__24__cdr_2derror( e2876 ); L4423: X7 = PAIR_CDR( e2876 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L4426; scrt1__24__car_2derror( X7 ); L4426: X6 = PAIR_CAR( X7 ); X5 = SYMBOL_VALUE( islist_v ); X5 = UNKNOWNCALL( X5, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X5 ) )( X6, _TSCP( 4 ), PROCEDURE_CLOSURE( X5 ) ) ) ) goto L4465; X5 = PAIR_CDR( e2876 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4431; scrt1__24__car_2derror( X5 ); L4431: X3 = PAIR_CAR( X5 ); X2 = EMPTYLIST; X1 = EMPTYLIST; L4433: X1 = CONS( X1, EMPTYLIST ); X2 = CONS( X2, EMPTYLIST ); X5 = BOOLEAN( NEQ( TSCPTAG( X3 ), PAIRTAG ) ); if ( TRUE( X5 ) ) goto L4438; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4442; scrt1__24__car_2derror( X3 ); L4442: X8 = PAIR_CAR( X3 ); X7 = SYMBOL_VALUE( islist_v ); X7 = UNKNOWNCALL( X7, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X7 ) )( X8, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X7 ) ) ) ) goto L4439; X6 = FALSEVALUE; goto L4440; L4439: X6 = TRUEVALUE; L4440: if ( TRUE( X6 ) ) goto L4438; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4452; scrt1__24__car_2derror( X3 ); L4452: X8 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L4455; scrt1__24__car_2derror( X8 ); L4455: X7 = PAIR_CAR( X8 ); if ( NOT( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), SYMBOLTAG ) ) ) ) goto L4438; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4459; scrt1__24__car_2derror( X3 ); L4459: X9 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4462; scrt1__24__car_2derror( X9 ); L4462: X8 = PAIR_CAR( X9 ); X7 = sc_cons( X8, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X7 ); X8 = scrt1_cadar( X3 ); X7 = sc_cons( X8, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X7 ); X7 = PAIR_CDR( X3 ); X1 = PAIR_CAR( X1 ); X2 = PAIR_CAR( X2 ); X3 = X7; GOBACK( L4433 ); L4465: X5 = SYMBOL_VALUE( islist_v ); X5 = UNKNOWNCALL( X5, 2 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( e2876, _TSCP( 12 ), PROCEDURE_CLOSURE( X5 ) ); if ( FALSE( X4 ) ) goto L4482; if ( EQ( TSCPTAG( e2876 ), PAIRTAG ) ) goto L4473; scrt1__24__cdr_2derror( e2876 ); L4473: X6 = PAIR_CDR( e2876 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4476; scrt1__24__car_2derror( X6 ); L4476: X5 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L4482; X8 = PAIR_CDR( e2876 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L4480; scrt1__24__cdr_2derror( X8 ); L4480: X7 = PAIR_CDR( X8 ); X8 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_append_2dtwo( X7, X8 ), EMPTYLIST ); X5 = scrt1_cons_2a( c2326, CONS( EMPTYLIST, X6 ) ); POPSTACKTRACE( scrt1_cons_2a( X5, CONS( EMPTYLIST, EMPTYLIST ) ) ); L4482: X4 = SYMBOL_VALUE( expand_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X4 ) )( c2910, e2876, PROCEDURE_CLOSURE( X4 ) ) ); L4438: if ( FALSE( X3 ) ) goto L4483; X4 = SYMBOL_VALUE( expand_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X4 ) )( c2910, e2876, PROCEDURE_CLOSURE( X4 ) ) ); L4483: X6 = PAIR_CDR( e2876 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4487; scrt1__24__cdr_2derror( X6 ); L4487: X5 = PAIR_CDR( X6 ); X4 = macros_let_2a_2dresult( PAIR_CAR( X2 ), PAIR_CAR( X1 ), X5 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4490; scrt1__24__car_2derror( X4 ); L4490: POPSTACKTRACE( PAIR_CAR( X4 ) ); } DEFTSCP( macros_let_2a_2dresult_v ); DEFCSTRING( t4492, "LET*-RESULT" ); TSCP macros_let_2a_2dresult( v2994, i2995, b2996 ) TSCP v2994, i2995, b2996; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4492 ); L4493: if ( EQ( _S2CUINT( v2994 ), _S2CUINT( EMPTYLIST ) ) ) goto L4494; if ( EQ( TSCPTAG( v2994 ), PAIRTAG ) ) goto L4497; scrt1__24__cdr_2derror( v2994 ); L4497: X1 = PAIR_CDR( v2994 ); if ( EQ( TSCPTAG( i2995 ), PAIRTAG ) ) goto L4500; scrt1__24__cdr_2derror( i2995 ); L4500: X2 = PAIR_CDR( i2995 ); X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_append_2dtwo( b2996, X6 ), EMPTYLIST ); X6 = PAIR_CAR( v2994 ); X4 = scrt1_cons_2a( c2326, CONS( scrt1_cons_2a( X6, CONS( EMPTYLIST, EMPTYLIST ) ), X5 ) ); X5 = CONS( EMPTYLIST, EMPTYLIST ); X3 = scrt1_cons_2a( X4, CONS( PAIR_CAR( i2995 ), X5 ) ); b2996 = scrt1_cons_2a( X3, CONS( EMPTYLIST, EMPTYLIST ) ); i2995 = X2; v2994 = X1; GOBACK( L4493 ); L4494: POPSTACKTRACE( b2996 ); } DEFTSCP( macros_letrec_2dmacro_v ); DEFCSTRING( t4504, "LETREC-MACRO" ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); TSCP macros_letrec_2dmacro( e3020 ) TSCP e3020; { TSCP X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4504 ); X6 = SYMBOL_VALUE( islist_v ); X6 = UNKNOWNCALL( X6, 2 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( e3020, _TSCP( 12 ), PROCEDURE_CLOSURE( X6 ) ); if ( FALSE( X5 ) ) goto L4585; if ( EQ( TSCPTAG( e3020 ), PAIRTAG ) ) goto L4513; scrt1__24__cdr_2derror( e3020 ); L4513: X8 = PAIR_CDR( e3020 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L4516; scrt1__24__car_2derror( X8 ); L4516: X7 = PAIR_CAR( X8 ); X6 = SYMBOL_VALUE( islist_v ); X6 = UNKNOWNCALL( X6, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X6 ) )( X7, _TSCP( 4 ), PROCEDURE_CLOSURE( X6 ) ) ) ) goto L4585; X6 = PAIR_CDR( e3020 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4521; scrt1__24__car_2derror( X6 ); L4521: X4 = PAIR_CAR( X6 ); X3 = EMPTYLIST; X1 = EMPTYLIST; X2 = EMPTYLIST; L4523: X2 = CONS( X2, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); X3 = CONS( X3, EMPTYLIST ); X6 = BOOLEAN( NEQ( TSCPTAG( X4 ), PAIRTAG ) ); if ( TRUE( X6 ) ) goto L4528; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4532; scrt1__24__car_2derror( X4 ); L4532: X9 = PAIR_CAR( X4 ); X8 = SYMBOL_VALUE( islist_v ); X8 = UNKNOWNCALL( X8, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X8 ) )( X9, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X8 ) ) ) ) goto L4529; X7 = FALSEVALUE; goto L4530; L4529: X7 = TRUEVALUE; L4530: if ( TRUE( X7 ) ) goto L4528; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4542; scrt1__24__car_2derror( X4 ); L4542: X9 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4545; scrt1__24__car_2derror( X9 ); L4545: X8 = PAIR_CAR( X9 ); if ( NOT( AND( EQ( TSCPTAG( X8 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X8 ), SYMBOLTAG ) ) ) ) goto L4528; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4549; scrt1__24__car_2derror( X4 ); L4549: X9 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4552; scrt1__24__car_2derror( X9 ); L4552: X8 = PAIR_CAR( X9 ); X9 = scrt1_cadar( X4 ); if ( NEQ( TSCPTAG( X9 ), FIXNUMTAG ) ) goto L4555; X10 = TRUEVALUE; goto L4556; L4555: X10 = BOOLEAN( AND( EQ( TSCPTAG( X9 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X9 ), DOUBLEFLOATTAG ) ) ); L4556: if ( TRUE( X10 ) ) goto L4561; if ( AND( EQ( TSCPTAG( X9 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X9 ), STRINGTAG ) ) ) goto L4561; if ( EQ( TSCPIMMEDIATETAG( X9 ), CHARACTERTAG ) ) goto L4561; X11 = scrt1_memq( X9, c3130 ); if ( TRUE( X11 ) ) goto L4561; if ( NEQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4581; X12 = PAIR_CAR( X9 ); if ( EQ( _S2CUINT( X12 ), _S2CUINT( c2210 ) ) ) goto L4561; L4581: X11 = sc_cons( _TSCP( 0 ), PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X11 ); X13 = CONS( EMPTYLIST, EMPTYLIST ); X13 = CONS( X9, X13 ); X12 = scrt1_cons_2a( c3146, CONS( X8, X13 ) ); X11 = sc_cons( X12, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X11 ); goto L4582; L4561: X11 = sc_cons( X9, PAIR_CAR( X1 ) ); SETGEN( PAIR_CAR( X1 ), X11 ); L4582: X10 = sc_cons( X8, PAIR_CAR( X3 ) ); SETGEN( PAIR_CAR( X3 ), X10 ); X8 = PAIR_CDR( X4 ); X2 = PAIR_CAR( X2 ); X1 = PAIR_CAR( X1 ); X3 = PAIR_CAR( X3 ); X4 = X8; GOBACK( L4523 ); L4585: X6 = SYMBOL_VALUE( islist_v ); X6 = UNKNOWNCALL( X6, 2 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( e3020, _TSCP( 12 ), PROCEDURE_CLOSURE( X6 ) ); if ( FALSE( X5 ) ) goto L4602; if ( EQ( TSCPTAG( e3020 ), PAIRTAG ) ) goto L4593; scrt1__24__cdr_2derror( e3020 ); L4593: X7 = PAIR_CDR( e3020 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L4596; scrt1__24__car_2derror( X7 ); L4596: X6 = PAIR_CAR( X7 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L4602; X9 = PAIR_CDR( e3020 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L4600; scrt1__24__cdr_2derror( X9 ); L4600: X8 = PAIR_CDR( X9 ); X9 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X7 = CONS( scrt1_append_2dtwo( X8, X9 ), EMPTYLIST ); X6 = scrt1_cons_2a( c2326, CONS( EMPTYLIST, X7 ) ); POPSTACKTRACE( scrt1_cons_2a( X6, CONS( EMPTYLIST, EMPTYLIST ) ) ); L4602: X5 = SYMBOL_VALUE( expand_2derror_v ); X5 = UNKNOWNCALL( X5, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X5 ) )( c2780, e3020, PROCEDURE_CLOSURE( X5 ) ) ); L4528: if ( FALSE( X4 ) ) goto L4603; X5 = SYMBOL_VALUE( expand_2derror_v ); X5 = UNKNOWNCALL( X5, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X5 ) )( c2780, e3020, PROCEDURE_CLOSURE( X5 ) ) ); L4603: X7 = scrt1_reverse( PAIR_CAR( X2 ) ); X11 = PAIR_CDR( e3020 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L4607; scrt1__24__cdr_2derror( X11 ); L4607: X10 = PAIR_CDR( X11 ); X11 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X9 = scrt1_cons_2a( c2086, CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ) ); X8 = scrt1_cons_2a( X9, CONS( EMPTYLIST, EMPTYLIST ) ); X6 = CONS( scrt1_append_2dtwo( X7, X8 ), EMPTYLIST ); X5 = scrt1_cons_2a( c2326, CONS( scrt1_reverse( PAIR_CAR( X3 ) ), X6 ) ); X6 = scrt1_reverse( PAIR_CAR( X1 ) ); X7 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( X5, CONS( scrt1_append_2dtwo( X6, X7 ), EMPTYLIST ) ) ); } DEFTSCP( macros_do_2dmacro_v ); DEFCSTRING( t4609, "DO-MACRO" ); EXTERNTSCPP( scrt1_caaddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caaddr_v ); EXTERNTSCPP( scrt1_cdaddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdaddr_v ); TSCP macros_do_2dmacro( e3183 ) TSCP e3183; { TSCP X18, X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4609 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e3183, _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L4665; if ( EQ( TSCPTAG( e3183 ), PAIRTAG ) ) goto L4616; scrt1__24__cdr_2derror( e3183 ); L4616: X5 = PAIR_CDR( e3183 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4619; scrt1__24__car_2derror( X5 ); L4619: X4 = PAIR_CAR( X5 ); X3 = SYMBOL_VALUE( islist_v ); X3 = UNKNOWNCALL( X3, 2 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( X4, _TSCP( 0 ), PROCEDURE_CLOSURE( X3 ) ); if ( FALSE( X2 ) ) goto L4665; X4 = scrt1_caddr( e3183 ); X3 = SYMBOL_VALUE( islist_v ); X3 = UNKNOWNCALL( X3, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X3 ) )( X4, _TSCP( 4 ), PROCEDURE_CLOSURE( X3 ) ) ) ) goto L4665; X4 = PAIR_CDR( e3183 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4629; scrt1__24__car_2derror( X4 ); L4629: X3 = PAIR_CAR( X4 ); X4 = EMPTYLIST; X5 = EMPTYLIST; X6 = EMPTYLIST; X7 = sc_d_2dsymbol_ab4b4447( c3275 ); X8 = scrt1_caaddr( e3183 ); X10 = scrt1_cdaddr( e3183 ); if ( FALSE( X10 ) ) goto L4632; X9 = X10; goto L4633; L4632: X9 = c3278; L4633: X10 = scrt1_cdddr( e3183 ); X6 = CONS( X6, EMPTYLIST ); X5 = CONS( X5, EMPTYLIST ); X4 = CONS( X4, EMPTYLIST ); X11 = scrt1_reverse( X3 ); X12 = X11; L4637: if ( EQ( _S2CUINT( X12 ), _S2CUINT( EMPTYLIST ) ) ) goto L4638; if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L4642; scrt1__24__car_2derror( X12 ); L4642: X13 = PAIR_CAR( X12 ); X14 = SYMBOL_VALUE( islist_v ); X14 = UNKNOWNCALL( X14, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X14 ) )( X13, _TSCP( 8 ), _TSCP( 12 ), PROCEDURE_CLOSURE( X14 ) ) ) ) goto L4645; if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L4648; scrt1__24__car_2derror( X13 ); L4648: X14 = PAIR_CAR( X13 ); X16 = PAIR_CDR( X13 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L4653; scrt1__24__car_2derror( X16 ); L4653: X15 = PAIR_CAR( X16 ); X17 = PAIR_CDR( X13 ); if ( EQ( TSCPTAG( X17 ), PAIRTAG ) ) goto L4658; scrt1__24__cdr_2derror( X17 ); L4658: if ( FALSE( PAIR_CDR( X17 ) ) ) goto L4660; X16 = scrt1_caddr( X13 ); goto L4661; L4660: X16 = X14; L4661: X17 = sc_cons( X14, PAIR_CAR( X4 ) ); SETGEN( PAIR_CAR( X4 ), X17 ); X17 = sc_cons( X16, PAIR_CAR( X6 ) ); SETGEN( PAIR_CAR( X6 ), X17 ); X17 = sc_cons( X15, PAIR_CAR( X5 ) ); SETGEN( PAIR_CAR( X5 ), X17 ); goto L4646; L4645: X14 = SYMBOL_VALUE( expand_2derror_v ); X14 = UNKNOWNCALL( X14, 2 ); VIA( PROCEDURE_CODE( X14 ) )( c3202, X13, PROCEDURE_CLOSURE( X14 ) ); L4646: X12 = PAIR_CDR( X12 ); GOBACK( L4637 ); L4638: X11 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X11 = CONS( scrt1_cons_2a( X7, CONS( scrt1_append_2dtwo( PAIR_CAR( X5 ), X12 ), EMPTYLIST ) ), X11 ); X13 = CONS( EMPTYLIST, EMPTYLIST ); X14 = CONS( EMPTYLIST, EMPTYLIST ); X15 = CONS( EMPTYLIST, EMPTYLIST ); X18 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X17 = scrt1_cons_2a( X7, CONS( scrt1_append_2dtwo( PAIR_CAR( X6 ), X18 ), EMPTYLIST ) ); X16 = scrt1_cons_2a( X17, CONS( EMPTYLIST, EMPTYLIST ) ); X15 = CONS( scrt1_cons_2a( c2086, CONS( scrt1_append_2dtwo( X10, X16 ), EMPTYLIST ) ), X15 ); X16 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X15 = CONS( scrt1_cons_2a( c2086, CONS( scrt1_append_2dtwo( X9, X16 ), EMPTYLIST ) ), X15 ); X14 = CONS( scrt1_cons_2a( c2081, CONS( X8, X15 ) ), X14 ); X12 = scrt1_cons_2a( X7, CONS( scrt1_cons_2a( c2326, CONS( PAIR_CAR( X4 ), X14 ) ), X13 ) ); POPSTACKTRACE( scrt1_cons_2a( c2780, CONS( scrt1_cons_2a( X12, CONS( EMPTYLIST, EMPTYLIST ) ), X11 ) ) ); L4665: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c3202, e3183, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( macros_quote_2dmacro_v ); DEFCSTRING( t4666, "QUOTE-MACRO" ); TSCP macros_quote_2dmacro( f3281, e3282 ) TSCP f3281, e3282; { PUSHSTACKTRACE( t4666 ); POPSTACKTRACE( f3281 ); } DEFTSCP( macros_define_2dmacro_v ); DEFCSTRING( t4668, "DEFINE-MACRO" ); EXTERNTSCPP( scrt1_caadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caadr_v ); EXTERNTSCPP( macros_bda_2dvars_8ad3f36b, XAL1( TSCP ) ); EXTERNTSCP( macros_bda_2dvars_8ad3f36b_v ); EXTERNTSCPP( scrt1_cdadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdadr_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP macros_define_2dmacro( f3285, e3286 ) TSCP f3285, e3286; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4668 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( f3285, _TSCP( 12 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L4670; if ( EQ( TSCPTAG( f3285 ), PAIRTAG ) ) goto L4676; scrt1__24__cdr_2derror( f3285 ); L4676: X2 = PAIR_CDR( f3285 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4679; scrt1__24__car_2derror( X2 ); L4679: X1 = PAIR_CAR( X2 ); if ( NOT( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), SYMBOLTAG ) ) ) ) goto L4673; X1 = PAIR_CDR( f3285 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4683; scrt1__24__car_2derror( X1 ); L4683: SETGENTL( SYMBOL_VALUE( current_2ddefine_2dname_v ), PAIR_CAR( X1 ) ); goto L4693; L4673: if ( EQ( TSCPTAG( f3285 ), PAIRTAG ) ) goto L4688; scrt1__24__cdr_2derror( f3285 ); L4688: X2 = PAIR_CDR( f3285 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4691; scrt1__24__car_2derror( X2 ); L4691: X1 = PAIR_CAR( X2 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4693; X1 = scrt1_caadr( f3285 ); if ( NOT( AND( EQ( TSCPTAG( X1 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X1 ), SYMBOLTAG ) ) ) ) goto L4693; SETGENTL( SYMBOL_VALUE( current_2ddefine_2dname_v ), scrt1_caadr( f3285 ) ); X1 = scrt1_cdadr( f3285 ); macros_bda_2dvars_8ad3f36b( X1 ); L4693: if ( EQ( TSCPTAG( f3285 ), PAIRTAG ) ) goto L4697; scrt1__24__car_2derror( f3285 ); L4697: X1 = PAIR_CAR( f3285 ); X4 = PAIR_CDR( f3285 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4701; scrt1__24__cdr_2derror( X4 ); L4701: X3 = PAIR_CDR( X4 ); X4 = X3; X5 = EMPTYLIST; X6 = EMPTYLIST; L4705: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L4706; X7 = X5; goto L4713; L4706: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4709; scrt1__24__car_2derror( X4 ); L4709: X11 = PAIR_CAR( X4 ); X10 = e3286; X10 = UNKNOWNCALL( X10, 2 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( X11, e3286, PROCEDURE_CLOSURE( X10 ) ); X8 = sc_cons( X9, EMPTYLIST ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L4712; X9 = PAIR_CDR( X4 ); X6 = X8; X5 = X8; X4 = X9; GOBACK( L4705 ); L4712: X9 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4717; scdebug_error( c3379, c3380, CONS( X6, EMPTYLIST ) ); L4717: X6 = SETGEN( PAIR_CDR( X6 ), X8 ); X4 = X9; GOBACK( L4705 ); L4713: X2 = CONS( X7, EMPTYLIST ); X3 = PAIR_CDR( f3285 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4721; scrt1__24__car_2derror( X3 ); L4721: POPSTACKTRACE( scrt1_cons_2a( X1, CONS( PAIR_CAR( X3 ), X2 ) ) ); L4670: POPSTACKTRACE( f3285 ); } DEFTSCP( macros_lambda_2dmacro_v ); DEFCSTRING( t4723, "LAMBDA-MACRO" ); TSCP macros_lambda_2dmacro( f3403, e3404 ) TSCP f3403, e3404; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4723 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( f3403, _TSCP( 12 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L4725; if ( EQ( TSCPTAG( f3403 ), PAIRTAG ) ) goto L4729; scrt1__24__cdr_2derror( f3403 ); L4729: X2 = PAIR_CDR( f3403 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4732; scrt1__24__car_2derror( X2 ); L4732: X1 = PAIR_CAR( X2 ); macros_bda_2dvars_8ad3f36b( X1 ); X1 = PAIR_CAR( f3403 ); X4 = PAIR_CDR( f3403 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4737; scrt1__24__cdr_2derror( X4 ); L4737: X3 = PAIR_CDR( X4 ); X4 = X3; X5 = EMPTYLIST; X6 = EMPTYLIST; L4741: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L4742; X7 = X5; goto L4749; L4742: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4745; scrt1__24__car_2derror( X4 ); L4745: X11 = PAIR_CAR( X4 ); X10 = e3404; X10 = UNKNOWNCALL( X10, 2 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( X11, e3404, PROCEDURE_CLOSURE( X10 ) ); X8 = sc_cons( X9, EMPTYLIST ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L4748; X9 = PAIR_CDR( X4 ); X6 = X8; X5 = X8; X4 = X9; GOBACK( L4741 ); L4748: X9 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4753; scdebug_error( c3379, c3380, CONS( X6, EMPTYLIST ) ); L4753: X6 = SETGEN( PAIR_CDR( X6 ), X8 ); X4 = X9; GOBACK( L4741 ); L4749: X2 = CONS( X7, EMPTYLIST ); X3 = PAIR_CDR( f3403 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4757; scrt1__24__car_2derror( X3 ); L4757: POPSTACKTRACE( scrt1_cons_2a( X1, CONS( PAIR_CAR( X3 ), X2 ) ) ); L4725: POPSTACKTRACE( f3403 ); } DEFTSCP( macros_bda_2dvars_8ad3f36b_v ); DEFCSTRING( t4759, "DUPLICATE-LAMBDA-VARS" ); TSCP macros_bda_2dvars_8ad3f36b( v3485 ) TSCP v3485; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4759 ); X1 = v3485; X2 = EMPTYLIST; L4762: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L4763; if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4765; X3 = PAIR_CAR( X1 ); goto L4766; L4765: X3 = X1; L4766: if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) goto L4769; X4 = SYMBOL_VALUE( report_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); VIA( PROCEDURE_CODE( X4 ) )( c3504, X3, PROCEDURE_CLOSURE( X4 ) ); L4769: if ( FALSE( scrt1_memq( X3, X2 ) ) ) goto L4771; X4 = SYMBOL_VALUE( report_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); VIA( PROCEDURE_CODE( X4 ) )( c3505, X3, PROCEDURE_CLOSURE( X4 ) ); L4771: if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L4773; X4 = PAIR_CDR( X1 ); X2 = sc_cons( X3, X2 ); X1 = X4; GOBACK( L4762 ); L4773: POPSTACKTRACE( FALSEVALUE ); L4763: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( macros_define_2dmacro_2dmacro_v ); DEFCSTRING( t4776, "DEFINE-MACRO-MACRO" ); TSCP macros_define_2dmacro_2dmacro( f3520, e3521 ) TSCP f3520, e3521; { TSCP X1; PUSHSTACKTRACE( t4776 ); X1 = SYMBOL_VALUE( do_2ddefine_2dmacro_v ); X1 = UNKNOWNCALL( X1, 1 ); VIA( PROCEDURE_CODE( X1 ) )( f3520, PROCEDURE_CLOSURE( X1 ) ); POPSTACKTRACE( f3520 ); } DEFTSCP( macros_nt_2dmacro_17bbc940_v ); DEFCSTRING( t4778, "DEFINE-CONSTANT-MACRO" ); TSCP macros_nt_2dmacro_17bbc940( f3525, e3526 ) TSCP f3525, e3526; { TSCP X1; PUSHSTACKTRACE( t4778 ); X1 = SYMBOL_VALUE( do_2ddefine_2dconstant_v ); X1 = UNKNOWNCALL( X1, 1 ); VIA( PROCEDURE_CODE( X1 ) )( f3525, PROCEDURE_CLOSURE( X1 ) ); POPSTACKTRACE( f3525 ); } DEFTSCP( macros_eval_2dwhen_2dmacro_v ); DEFCSTRING( t4780, "EVAL-WHEN-MACRO" ); TSCP macros_l3588( f3589, e3590, c4817 ) TSCP f3589, e3590, c4817; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "macros_l3588 [inside EVAL-WHEN-MACRO]" ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_caddr( f3589 ), X3 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c2210, CONS( c3602, X4 ) ), X3 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( f3589 ), PAIRTAG ) ) goto L4820; scrt1__24__cdr_2derror( f3589 ); L4820: X5 = PAIR_CDR( f3589 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4823; scrt1__24__car_2derror( X5 ); L4823: X2 = scrt1_cons_2a( c3591, CONS( scrt1_cons_2a( c2210, CONS( PAIR_CAR( X5 ), X4 ) ), X3 ) ); X1 = e3590; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e3590, PROCEDURE_CLOSURE( X1 ) ) ); } TSCP macros_l3604( f3605, e3606, c4825 ) TSCP f3605, e3606, c4825; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "macros_l3604 [inside EVAL-WHEN-MACRO]" ); X3 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c3617, CONS( scrt1_caddr( f3605 ), X4 ) ), X3 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X3 = CONS( scrt1_cons_2a( c2210, CONS( c3602, X4 ) ), X3 ); X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( f3605 ), PAIRTAG ) ) goto L4828; scrt1__24__cdr_2derror( f3605 ); L4828: X5 = PAIR_CDR( f3605 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L4831; scrt1__24__car_2derror( X5 ); L4831: X2 = scrt1_cons_2a( c3591, CONS( scrt1_cons_2a( c2210, CONS( PAIR_CAR( X5 ), X4 ) ), X3 ) ); X1 = e3606; X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e3606, PROCEDURE_CLOSURE( X1 ) ) ); } TSCP macros_eval_2dwhen_2dmacro( f3530, e3531 ) TSCP f3530, e3531; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t4780 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( f3530, _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L4809; if ( EQ( TSCPTAG( f3530 ), PAIRTAG ) ) goto L4789; scrt1__24__cdr_2derror( f3530 ); L4789: X4 = PAIR_CDR( f3530 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4792; scrt1__24__car_2derror( X4 ); L4792: X3 = PAIR_CAR( X4 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X2 ) )( X3, _TSCP( 4 ), PROCEDURE_CLOSURE( X2 ) ) ) ) goto L4809; X4 = PAIR_CDR( f3530 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4796; scrt1__24__car_2derror( X4 ); L4796: X3 = PAIR_CAR( X4 ); X2 = scrt1_memq( c3550, X3 ); if ( FALSE( X2 ) ) goto L4808; X4 = PAIR_CDR( f3530 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4806; scrt1__24__car_2derror( X4 ); L4806: X3 = PAIR_CAR( X4 ); if ( TRUE( scrt1_memq( c3562, X3 ) ) ) goto L4808; POPSTACKTRACE( f3530 ); L4809: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c3546, f3530, PROCEDURE_CLOSURE( X1 ) ) ); L4808: X2 = PAIR_CDR( f3530 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4814; scrt1__24__car_2derror( X2 ); L4814: X1 = PAIR_CAR( X2 ); if ( FALSE( scrt1_memq( c3562, X1 ) ) ) goto L4810; X2 = SYMBOL_VALUE( get_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c3603, c2655, PROCEDURE_CLOSURE( X2 ) ); X3 = SYMBOL_VALUE( get_v ); X3 = UNKNOWNCALL( X3, 2 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( c3587, c2655, PROCEDURE_CLOSURE( X3 ) ); X4 = MAKEPROCEDURE( 2, 0, macros_l3588, EMPTYLIST ); X3 = SYMBOL_VALUE( put_v ); X3 = UNKNOWNCALL( X3, 3 ); VIA( PROCEDURE_CODE( X3 ) )( c3587, c2655, X4, PROCEDURE_CLOSURE( X3 ) ); X4 = MAKEPROCEDURE( 2, 0, macros_l3604, EMPTYLIST ); X3 = SYMBOL_VALUE( put_v ); X3 = UNKNOWNCALL( X3, 3 ); VIA( PROCEDURE_CODE( X3 ) )( c3603, c2655, X4, PROCEDURE_CLOSURE( X3 ) ); X6 = PAIR_CDR( f3530 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L4835; scrt1__24__cdr_2derror( X6 ); L4835: X5 = PAIR_CDR( X6 ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_cons_2a( c2210, CONS( X1, X10 ) ), X9 ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_cons_2a( c2210, CONS( c2655, X10 ) ), X9 ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( scrt1_cons_2a( c3628, CONS( scrt1_cons_2a( c2210, CONS( c3603, X10 ) ), X9 ) ), X8 ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_cons_2a( c2210, CONS( X2, X10 ) ), X9 ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_cons_2a( c2210, CONS( c2655, X10 ) ), X9 ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( scrt1_cons_2a( c3628, CONS( scrt1_cons_2a( c2210, CONS( c3587, X10 ) ), X9 ) ), X8 ); X7 = scrt1_cons_2a( c3546, CONS( scrt1_cons_2a( c3550, CONS( EMPTYLIST, EMPTYLIST ) ), X8 ) ); X10 = PAIR_CDR( f3530 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L4841; scrt1__24__car_2derror( X10 ); L4841: X9 = PAIR_CAR( X10 ); if ( FALSE( scrt1_memq( c3550, X9 ) ) ) goto L4837; X12 = PAIR_CDR( f3530 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L4845; scrt1__24__cdr_2derror( X12 ); L4845: X11 = PAIR_CDR( X12 ); X12 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X10 = CONS( scrt1_append_2dtwo( X11, X12 ), EMPTYLIST ); X9 = scrt1_cons_2a( c3546, CONS( scrt1_cons_2a( c3550, CONS( EMPTYLIST, EMPTYLIST ) ), X10 ) ); X8 = scrt1_cons_2a( X9, CONS( EMPTYLIST, EMPTYLIST ) ); goto L4838; L4837: X8 = EMPTYLIST; L4838: X9 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( X7, CONS( scrt1_append_2dtwo( X8, X9 ), EMPTYLIST ) ); X4 = scrt1_cons_2a( c2086, CONS( scrt1_append_2dtwo( X5, X6 ), EMPTYLIST ) ); X3 = e3531; X3 = UNKNOWNCALL( X3, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X3 ) )( X4, e3531, PROCEDURE_CLOSURE( X3 ) ) ); L4810: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( macros_when_2dmacro_v ); DEFCSTRING( t4847, "WHEN-MACRO" ); TSCP macros_when_2dmacro( e3651 ) TSCP e3651; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4847 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( e3651, _TSCP( 12 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L4849; X1 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( e3651 ), PAIRTAG ) ) goto L4852; scrt1__24__cdr_2derror( e3651 ); L4852: X3 = PAIR_CDR( e3651 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4855; scrt1__24__cdr_2derror( X3 ); L4855: X2 = PAIR_CDR( X3 ); X3 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X1 = CONS( scrt1_cons_2a( c2086, CONS( scrt1_append_2dtwo( X2, X3 ), EMPTYLIST ) ), X1 ); X2 = PAIR_CDR( e3651 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L4859; scrt1__24__car_2derror( X2 ); L4859: POPSTACKTRACE( scrt1_cons_2a( c2081, CONS( PAIR_CAR( X2 ), X1 ) ) ); L4849: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c3652, e3651, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( macros_unless_2dmacro_v ); DEFCSTRING( t4861, "UNLESS-MACRO" ); TSCP macros_unless_2dmacro( e3675 ) TSCP e3675; { TSCP X3, X2, X1; PUSHSTACKTRACE( t4861 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( e3675, _TSCP( 12 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L4863; X1 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( e3675 ), PAIRTAG ) ) goto L4866; scrt1__24__cdr_2derror( e3675 ); L4866: X3 = PAIR_CDR( e3675 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4869; scrt1__24__cdr_2derror( X3 ); L4869: X2 = PAIR_CDR( X3 ); X3 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X1 = CONS( scrt1_cons_2a( c2086, CONS( scrt1_append_2dtwo( X2, X3 ), EMPTYLIST ) ), X1 ); X2 = CONS( EMPTYLIST, EMPTYLIST ); X3 = PAIR_CDR( e3675 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4873; scrt1__24__car_2derror( X3 ); L4873: POPSTACKTRACE( scrt1_cons_2a( c2081, CONS( scrt1_cons_2a( c2544, CONS( PAIR_CAR( X3 ), X2 ) ), X1 ) ) ); L4863: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c3676, e3675, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( macros_lap_2dmacro_v ); DEFCSTRING( t4875, "LAP-MACRO" ); EXTERNTSCPP( macros_t_2dexpand_dcf6ab5b, XAL2( TSCP, TSCP ) ); EXTERNTSCP( macros_t_2dexpand_dcf6ab5b_v ); TSCP macros_lap_2dmacro( f3699, e3700 ) TSCP f3699, e3700; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t4875 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( f3699, _TSCP( 12 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L4877; if ( EQ( TSCPTAG( f3699 ), PAIRTAG ) ) goto L4880; scrt1__24__car_2derror( f3699 ); L4880: X1 = PAIR_CAR( f3699 ); X4 = PAIR_CDR( f3699 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L4884; scrt1__24__cdr_2derror( X4 ); L4884: X3 = PAIR_CDR( X4 ); X2 = CONS( macros_t_2dexpand_dcf6ab5b( X3, macros_t_2dexpand_dcf6ab5b_v ), EMPTYLIST ); X3 = PAIR_CDR( f3699 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L4888; scrt1__24__car_2derror( X3 ); L4888: POPSTACKTRACE( scrt1_cons_2a( X1, CONS( PAIR_CAR( X3 ), X2 ) ) ); L4877: if ( EQ( TSCPTAG( f3699 ), PAIRTAG ) ) goto L4891; scrt1__24__car_2derror( f3699 ); L4891: X2 = PAIR_CAR( f3699 ); X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, f3699, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( macros_t_2dexpand_dcf6ab5b_v ); DEFCSTRING( t4893, "LAP-CONSTANT-EXPAND" ); TSCP macros_l3737( x3738, e3739, c4899 ) TSCP x3738, e3739, c4899; { PUSHSTACKTRACE( "macros_l3737 [inside LAP-CONSTANT-EXPAND]" ); POPSTACKTRACE( x3738 ); } TSCP macros_t_2dexpand_dcf6ab5b( x3731, e3732 ) TSCP x3731, e3732; { TSCP X1; PUSHSTACKTRACE( t4893 ); if ( NEQ( TSCPTAG( x3731 ), PAIRTAG ) ) goto L4895; X1 = SYMBOL_VALUE( _xpander_2a_ecf97896_v ); goto L4898; L4895: if ( NOT( AND( EQ( TSCPTAG( x3731 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x3731 ), SYMBOLTAG ) ) ) ) goto L4897; X1 = SYMBOL_VALUE( _xpander_2a_9e90dc74_v ); goto L4898; L4897: X1 = MAKEPROCEDURE( 2, 0, macros_l3737, EMPTYLIST ); L4898: X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( x3731, e3732, PROCEDURE_CLOSURE( X1 ) ) ); } void scdebug__init(); void scrt6__init(); void scrt2__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scdebug__init(); scrt6__init(); scrt2__init(); scrt1__init(); MAXDISPLAY( 1 ); } void macros__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(macros SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3929, ADR( macros_old_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_old_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t3933, ADR( macros_quasiquote_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_quasiquote_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t3937, ADR( macros_cond_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_cond_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t3999, ADR( macros_case_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_case_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4081, ADR( macros_and_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_and_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4140, ADR( macros_or_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_or_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4199, ADR( macros_not_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_not_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4219, ADR( macros_boolean_2dconstant_v ), MAKEPROCEDURE( 1, 0, macros_boolean_2dconstant, EMPTYLIST ) ); INITIALIZEVAR( t4269, ADR( macros_begin_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_begin_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4292, ADR( macros_let_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_let_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4414, ADR( macros_let_2a_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_let_2a_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4492, ADR( macros_let_2a_2dresult_v ), MAKEPROCEDURE( 3, 0, macros_let_2a_2dresult, EMPTYLIST ) ); INITIALIZEVAR( t4504, ADR( macros_letrec_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_letrec_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4609, ADR( macros_do_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_do_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4666, ADR( macros_quote_2dmacro_v ), MAKEPROCEDURE( 2, 0, macros_quote_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4668, ADR( macros_define_2dmacro_v ), MAKEPROCEDURE( 2, 0, macros_define_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4723, ADR( macros_lambda_2dmacro_v ), MAKEPROCEDURE( 2, 0, macros_lambda_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4759, ADR( macros_bda_2dvars_8ad3f36b_v ), MAKEPROCEDURE( 1, 0, macros_bda_2dvars_8ad3f36b, EMPTYLIST ) ); INITIALIZEVAR( t4776, ADR( macros_define_2dmacro_2dmacro_v ), MAKEPROCEDURE( 2, 0, macros_define_2dmacro_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4778, ADR( macros_nt_2dmacro_17bbc940_v ), MAKEPROCEDURE( 2, 0, macros_nt_2dmacro_17bbc940, EMPTYLIST ) ); INITIALIZEVAR( t4780, ADR( macros_eval_2dwhen_2dmacro_v ), MAKEPROCEDURE( 2, 0, macros_eval_2dwhen_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4847, ADR( macros_when_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_when_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4861, ADR( macros_unless_2dmacro_v ), MAKEPROCEDURE( 1, 0, macros_unless_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4875, ADR( macros_lap_2dmacro_v ), MAKEPROCEDURE( 2, 0, macros_lap_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t4893, ADR( macros_t_2dexpand_dcf6ab5b_v ), MAKEPROCEDURE( 2, 0, macros_t_2dexpand_dcf6ab5b, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/macros.sc000066400000000000000000000371051203736146400163550ustar00rootroot00000000000000;;; This file contains the "hard-wired" macros that are recognized by the ;;; compiler. For the most part, they are "old-fashioned" macros and thus are ;;; invoked by the following function. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module macros) (define (OLD-MACRO expand) (lambda (exp exp-func) (exp-func (expand exp) exp-func))) ;;; (quasiquote x) ==> ? ;;; ;;; Quasiquote expansion is done using the function built into the Scheme ;;; interpreter. The result is then macro expanded. (define (QUASIQUOTE-MACRO exp) (if (islist exp 2 2) (quasiquotation 1 exp) (expand-error 'quasiquote exp))) ;;; Derived expression types are expanded in this module using the rules ;;; given in section 7.3 of Revised**3. ;;; Conditional forms are expanded into if sequences. (define (COND-MACRO exp) (let* ((clauses (cdr exp)) (clause1 (and clauses (car clauses))) (clause2+ (and clause1 (cdr clauses)))) (cond ((null? clause1) #f) ((or (not (pair? clause1)) (equal? clause1 '(else))) (expand-error 'cond-clause exp)) ((null? (cdr clause1)) `(or ,(car clause1) (cond ,@clause2+))) ((and (eq? (cadr clause1) '=>) (= (length clause1) 3)) (let ((test-result (string->uninterned-symbol "TEST"))) `(let ((,test-result ,(car clause1))) (if ,test-result (,(caddr clause1) ,test-result) (cond ,@clause2+))))) ((eq? (car clause1) 'else) `(begin ,@(cdr clause1))) (else `(if ,(car clause1) (begin ,@(cdr clause1)) (cond ,@clause2+)))))) (define (CASE-MACRO exp) (cond ((islist exp 3) (do ((keyval (cadr exp)) (key (make-alpha 'k)) (cases (cddr exp) (cdr cases)) (ccs '())) ((or (not (pair? cases)) (not (islist (car cases) 2))) (cond (cases (expand-error 'case exp)) (else `(let ((,key ,keyval)) (cond ,@(reverse ccs)))))) (cond ((eq? (caar cases) 'else) (set! ccs (cons (car cases) ccs))) ((and (= (length (caar cases)) 1) (not (float? (caaar cases)))) (set! ccs (cons `((eq? ,key (quote ,(caaar cases))) ,@(cdar cases)) ccs))) ((= (length (caar cases)) 1) (set! ccs (cons `((eqv? ,key (quote ,(caaar cases))) ,@(cdar cases)) ccs))) (else (set! ccs (cons `((memv ,key (quote ,(caar cases))) ,@(cdar cases)) ccs)))))) (else (expand-error 'case exp)))) ;;; Boolean expressions are expanded here. Boolean expressions involving ;;; constants are simplified here to save time during transformations. (define (AND-MACRO exp) (if (cdr exp) (let ((x (boolean-constant (cadr exp)))) (cond ((pair? x) (if (car x) (if (cddr exp) `(and ,@(cddr exp)) (car x)) (car x))) ((null? (cddr exp)) (cadr exp)) (else (let ((y (boolean-constant `(and ,@(cddr exp))))) (if (pair? y) `(let ((x ,(cadr exp))) (if x ,(car y) x)) `(let ((x ,(cadr exp)) (thunk (lambda () (and ,@(cddr exp))))) (if x (thunk) x))))))) #t)) (define (OR-MACRO exp) (if (cdr exp) (let ((x (boolean-constant (cadr exp)))) (cond ((pair? x) (if (car x) (car x) (if (cddr exp) `(or ,@(cddr exp)) (car x)))) ((null? (cddr exp)) (cadr exp)) (else (let ((y (boolean-constant `(or ,@(cddr exp))))) (if (pair? y) `(let ((x ,(cadr exp))) (if x x ,(car y))) `(let ((x ,(cadr exp)) (thunk (lambda () (or ,@(cddr exp))))) (if x x (thunk)))))))) #f)) (define (NOT-MACRO exp) (if (islist exp 2 2) (let ((x (boolean-constant (cadr exp)))) (if (pair? x) (if (car x) #f #t) `(if ,(cadr exp) #f #t))) (expand-error 'not exp))) ;;; Boolean constant expressions are evaluated by the following function. It ;;; returns () when a boolean constant is found, or #f when ;;; one is not found. (define (BOOLEAN-CONSTANT exp) (cond ((or (number? exp) (boolean? exp) (string? exp) (and (pair? exp) (eq? (car exp) 'quote) (cadr exp))) (list exp)) ((symbol? exp) (let ((x (get exp 'macro))) (if (pair? x) (boolean-constant (car x)) #f))) ((pair? exp) (case (car exp) ((not) (boolean-constant (not-macro exp))) ((and) (boolean-constant (and-macro exp))) ((or) (boolean-constant (or-macro exp))) (else #f))) (else #f))) ;;; (begin expression ...) ==> ((lambda () expression ...)) ;;; ;;; BEGIN becomes a let expression with no bindings. Note the special case ;;; where a begin with only one expression simply becomes that expression. (define (BEGIN-MACRO exp) (cond ((not (islist exp 2)) (expand-error 'begin exp)) ((= (length exp) 2) (cadr exp)) (else `((lambda () ,@(cdr exp)))))) ;;; (let ((var init)...) body) ==> ((lambda (var...) body) init...) ;;; ;;; (let () body) ==> ((lambda X body)) ;;; ;;; (let var ((v init) ...) body) ==> ;;; (let ((gv init) ....) ;;; (letrec ((var (lambda (v ...) body))) ;;; (var init ...))) ;;; ;;; LET is expanded into a lambda expression. While this may make the ;;; resulting expanded code more difficult to read, later analysis is eased ;;; because there are fewer forms. Variable order is retained to make the ;;; resulting tree easier to compare against the original tree. ;;; ;;; A LET with no variable bindings is expanded into a lambda expression that ;;; takes a variable number of arguments. This is to differentiate it from ;;; a BEGIN as when a BEGIN appears at the top level, it is spliced into the ;;; input stream. ;;; ;;; A "named let" is expanded into the appropriate letrec expression. That in ;;; turn is expanded into the appropriate lambda expression when the letrec ;;; is expanded. (define (LET-MACRO exp) (cond ((and (islist exp 3) (islist (cadr exp) 0)) (do ((var-inits (cadr exp) (cdr var-inits)) (vars '()) (inits '())) ((or (not (pair? var-inits)) (not (islist (car var-inits) 2 2)) (not (symbol? (caar var-inits)))) (if var-inits (expand-error 'let exp) `((lambda ,(if (null? vars) (string->uninterned-symbol "x") (reverse vars)) ,@(cddr exp)) ,@(reverse inits)))) (set! vars (cons (caar var-inits) vars)) (set! inits (cons (cadar var-inits) inits)))) ((and (islist exp 4) (symbol? (cadr exp))) (do ((var-inits (caddr exp) (cdr var-inits)) (gvx 0 (+ gvx 1)) (gvs '()) (vars '()) (inits '())) ((or (not (pair? var-inits)) (not (islist (car var-inits) 2 2)) (not (symbol? (caar var-inits)))) (if var-inits (expand-error 'let exp) `(let ,(reverse inits) (letrec ((,(cadr exp) (lambda ,(reverse vars) ,@(cdddr exp)))) (,(cadr exp) ,@(reverse gvs)))))) (set! vars (cons (caar var-inits) vars)) (set! gvs (cons (string->uninterned-symbol (format "$_~s" gvx)) gvs)) (set! inits (cons (list (car gvs) (cadar var-inits)) inits)))) (else (expand-error 'let exp)))) ;;; (let* ((var init)...) body) ==> ((lambda (var) ;;; ((lambda (var) body) init)) ;;; init) ;;; ;;; LET* is expanded into a set of nested lambda expressions. While this may ;;; make the resulting code more difficult to read, later analysis is eased ;;; because there fewer types of forms to analyze. (define (LET*-MACRO exp) (cond ((and (islist exp 3) (islist (cadr exp) 1)) (do ((var-inits (cadr exp) (cdr var-inits)) (vars '()) (inits '())) ((or (not (pair? var-inits)) (not (islist (car var-inits) 2 2)) (not (symbol? (caar var-inits)))) (if var-inits (expand-error 'let* exp) (car (let*-result vars inits (cddr exp))))) (set! vars (cons (caar var-inits) vars)) (set! inits (cons (cadar var-inits) inits)))) ((and (islist exp 3) (null? (cadr exp))) `((lambda () ,@(cddr exp)))) (else (expand-error 'let* exp)))) (define (LET*-RESULT vars inits body) (cond ((null? vars) body) (else (let*-result (cdr vars) (cdr inits) `(((lambda (,(car vars)) ,@body) ,(car inits))))))) ;;; (letrec ((var init)...) body) ==> ((lambda (var...) ;;; (set! var init) ...) ;;; (begin body ...)) ;;; undefined ...) ;;; ;;; LETREC is expanded into a lambda expression which first binds the vars to ;;; some undefined value and then evalutes the initialization expressions ;;; within the lambda expression. Note that the order of evaluation is ;;; undefined. (define (LETREC-MACRO exp) (cond ((and (islist exp 3) (islist (cadr exp) 1)) (do ((var-inits (cadr exp) (cdr var-inits)) (vars '()) (inits '()) (sets '())) ((or (not (pair? var-inits)) (not (islist (car var-inits) 2 2)) (not (symbol? (caar var-inits)))) (if var-inits (expand-error 'letrec exp) `((lambda ,(reverse vars) ,@(reverse sets) (begin ,@(cddr exp))) ,@(reverse inits)))) (let ((var (caar var-inits)) (init (cadar var-inits))) (if (or (number? init) (string? init) (char? init) (memq init '(#t #f)) (and (pair? init) (eq? (car init) 'quote))) (set! inits (cons init inits)) (begin (set! inits (cons 0 inits)) (set! sets (cons `(set! ,var ,init) sets)))) (set! vars (cons var vars))))) ((and (islist exp 3) (null? (cadr exp))) `((lambda () ,@(cddr exp)))) (else (expand-error 'letrec exp)))) ;;; (do ((v1 i1 s1) ...) (test sequence) body ...) ==> (letrec ...) ;;; ;;; Expands a DO form into the corresponding letrec form. (define (DO-MACRO exp) (cond ((and (islist exp 3) (islist (cadr exp) 0) (islist (caddr exp) 1)) (let ((let-bindings (cadr exp)) (vars '()) (inits '()) (steps '()) (loop (string->uninterned-symbol "DOLOOP")) (test (caaddr exp)) (sequence (or (cdaddr exp) '(#f))) (body (cdddr exp))) (for-each (lambda (var-init-step) (if (islist var-init-step 2 3) (let* ((var (car var-init-step)) (init (cadr var-init-step)) (step (if (cddr var-init-step) (caddr var-init-step) var))) (set! vars (cons var vars)) (set! steps (cons step steps)) (set! inits (cons init inits))) (expand-error 'do var-init-step))) (reverse let-bindings)) `(letrec ((,loop (lambda ,vars (if ,test (begin ,@sequence) (begin ,@body (,loop ,@steps)))))) (,loop ,@inits)))) (else (expand-error 'do exp)))) ;;; The forms QUOTE, INCLUDE, DEFINE-EXTERNAL and MODULE should not be ;;; expanded. This is done by having them use the following macro. (define (QUOTE-MACRO form expander) form) ;;; The form DEFINE is expanded by the following. Poorly formed ;;; expressions will be ignored for now, and picked up later when the ;;; form is evaluated. Lambda variable lists are checked for duplicates. (define (DEFINE-MACRO form expander) (if (islist form 3) (begin (cond ((symbol? (cadr form)) (set! current-define-name (cadr form))) ((and (pair? (cadr form)) (symbol? (caadr form))) (set! current-define-name (caadr form)) (duplicate-lambda-vars (cdadr form)))) (cons* (car form) (cadr form) (map (lambda (x) (expander x expander)) (cddr form)))) form)) ;;; The form LAMBDA is expanded by the following. Poorly formed ;;; expressions will be ignored for now, and picked up later when the ;;; form is evaluated. Variable lists are checked for duplicates. (define (LAMBDA-MACRO form expander) (if (islist form 3) (begin (duplicate-lambda-vars (cadr form)) (cons* (car form) (cadr form) (map (lambda (x) (expander x expander)) (cddr form)))) form)) ;;; The following function checks lambda expression argument lists for ;;; duplicate or illegal variable names. (define (DUPLICATE-LAMBDA-VARS vl) (let loop ((vl vl) (seen '())) (if (not (null? vl)) (let ((var (if (pair? vl) (car vl) vl))) (if (not (symbol? var)) (report-error "Argument must be a symbol:" var)) (if (memq var seen) (report-error "Duplicately defined symbol:" var)) (if (pair? vl) (loop (cdr vl) (cons var seen))))))) ;;; The form DEFINE-MACRO is evaluated at macro expansion time as later macro ;;; expansion may wish to use it. (define (DEFINE-MACRO-MACRO form expander) (do-define-macro form) form) ;;; The form DEFINE-CONSTANT is evaluated at macro expansion time as later ;;; macro expansion may wish to use it. (define (DEFINE-CONSTANT-MACRO form expander) (do-define-constant form) form) ;;; The form EVAL-WHEN is used to provide conditional evaluation in ;;; various environments. ;;; ;;; (EVAL-WHEN situation form ...) ==> (begin form ...) ;;; ==> #f ;;; ;;; where situation is a list of any of COMPILE, EVAL, or LOAD. (define (EVAL-WHEN-MACRO form expander) (if (and (islist form 3) (islist (cadr form) 1)) (cond ((and (memq 'compile (cadr form)) (not (memq 'load (cadr form)))) form) ((memq 'load (cadr form)) (let ((save-define-macro (get 'define-macro 'macro)) (save-define-constant (get 'define-constant 'macro))) (put 'define-macro 'macro (lambda (form expander) (expander `(putprop ',(cadr form) '*expander* ,(caddr form)) expander))) (put 'define-constant 'macro (lambda (form expander) (expander `(putprop ',(cadr form) '*expander* (list ,(caddr form))) expander))) (expander `(begin ,@(cddr form) (eval-when (compile) (put 'define-macro 'macro ',save-define-macro) (put 'define-constant 'macro ',save-define-constant)) ,@(if (memq 'compile (cadr form)) `((eval-when (compile) ,@(cddr form))) '())) expander)))) (expand-error 'EVAL-WHEN form))) ;;; (WHEN test exp ...) ==> (if test (begin exp ...)) (define (WHEN-MACRO exp) (if (islist exp 3) `(if ,(cadr exp) (begin ,@(cddr exp))) (expand-error 'WHEN exp))) ;;; (UNLESS test exp ...) ==> (if (not test) (begin exp ...)) (define (UNLESS-MACRO exp) (if (islist exp 3) `(if (not ,(cadr exp)) (begin ,@(cddr exp))) (expand-error 'UNLESS exp))) ;;; LAP and LAP? expressions have their constants expanded by these functions. (define (LAP-MACRO form expander) (if (islist form 3) (cons* (car form) (cadr form) (lap-constant-expand (cddr form) lap-constant-expand)) (expand-error (car form) form))) (define (LAP-CONSTANT-EXPAND x e) ((cond ((pair? x) *sc-application-expander*) ((symbol? x) *sc-identifier-expander*) (else (lambda (x e) x))) x e)) scheme2c-2012.10.14/scsc/main.c000066400000000000000000001166111203736146400156320ustar00rootroot00000000000000 /* SCHEME->C */ #include int main(); DEFSTATICTSCP( sc_2dlog_2ddefault_v ); DEFSTATICTSCP( initialize_2dcompile_v ); DEFSTATICTSCP( do_2ddefine_2dconstant_v ); DEFSTATICTSCP( sc_2dinclude_2ddirs_v ); DEFSTATICTSCP( sc_2dinput_v ); DEFSTATICTSCP( sc_2dsource_2dname_v ); DEFSTATICTSCP( sc_2dicode_v ); DEFSTATICTSCP( sc_2derror_v ); DEFSTATICTSCP( sc_2dlog_v ); DEFSTATICTSCP( sc_2dstack_2dtrace_v ); DEFSTATICTSCP( sc_2dinterpreter_v ); DEFSTATICTSCP( docompile_v ); DEFSTATICTSCP( sc_2derror_2dcnt_v ); DEFSTATICTSCP( module_2dname_v ); DEFSTATICTSCP( close_2dsc_2dfiles_v ); DEFCSTRING( t2600, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c2549 ); DEFSTATICTSCP( c2548 ); DEFCSTRING( t2601, ".S2C" ); DEFSTATICTSCP( c2531 ); DEFCSTRING( t2602, ".c" ); DEFSTATICTSCP( c2530 ); DEFCSTRING( t2603, "~a:~%" ); DEFSTATICTSCP( c2481 ); DEFCSTRING( t2604, ".sc" ); DEFSTATICTSCP( c2479 ); DEFCSTRING( t2605, "cc" ); DEFSTATICTSCP( c2447 ); DEFCSTRING( t2606, "\\" ); DEFSTATICTSCP( c2446 ); DEFCSTRING( t2607, "Microsoft Windows 3.x" ); DEFSTATICTSCP( c2445 ); DEFCSTRING( t2608, "SC-TO-C.o" ); DEFSTATICTSCP( c2443 ); DEFCSTRING( t2609, "SC-TO-C.c" ); DEFSTATICTSCP( c2442 ); DEFCSTRING( t2610, "-lsigsegv" ); DEFSTATICTSCP( c2440 ); DEFCSTRING( t2611, "-lm" ); DEFSTATICTSCP( c2429 ); DEFCSTRING( t2612, "-pg" ); DEFSTATICTSCP( c2428 ); DEFCSTRING( t2613, "-c" ); DEFSTATICTSCP( c2427 ); DEFCSTRING( t2614, " -I" ); DEFSTATICTSCP( c2382 ); DEFCSTRING( t2615, "}~%" ); DEFSTATICTSCP( c2376 ); DEFCSTRING( t2616, " SCHEMEEXIT();~%" ); DEFSTATICTSCP( c2375 ); DEFCSTRING( t2617, " screp_read_2deval_2dprint( sc_clarguments( argc, argv ) );~%\ " ); DEFSTATICTSCP( c2374 ); DEFCSTRING( t2618, "screp" ); DEFSTATICTSCP( c2373 ); DEFCSTRING( t2619, " ~a__init();~%" ); DEFSTATICTSCP( c2372 ); DEFCSTRING( t2620, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2361 ); DEFSTATICTSCP( c2360 ); DEFCSTRING( t2621, " INITHEAP( 0, argc, argv, screp_read_2deval_2dprint );~%" ); DEFSTATICTSCP( c2325 ); DEFCSTRING( t2622, "{~%" ); DEFSTATICTSCP( c2324 ); DEFCSTRING( t2623, "int main(int argc, char **argv)~%" ); DEFSTATICTSCP( c2323 ); DEFCSTRING( t2624, "extern TSCP screp_read_2deval_2dprint();~%" ); DEFSTATICTSCP( c2322 ); DEFCSTRING( t2625, "#include \"~a/~a\"~%" ); DEFSTATICTSCP( c2321 ); DEFCSTRING( t2626, ")" ); DEFSTATICTSCP( c2305 ); DEFCSTRING( t2627, " " ); DEFSTATICTSCP( c2304 ); DEFCSTRING( t2628, "(define-constant " ); DEFSTATICTSCP( c2293 ); DEFCSTRING( t2629, "/" ); DEFSTATICTSCP( c2276 ); DEFCSTRING( t2630, "libs2c_p.a" ); DEFSTATICTSCP( c2221 ); DEFCSTRING( t2631, "libs2c.a" ); DEFSTATICTSCP( c2210 ); DEFCSTRING( t2632, "predef.sc" ); DEFSTATICTSCP( c2189 ); DEFSTATICTSCP( c2171 ); DEFSTATICTSCP( t2633 ); DEFCSTRING( t2635, "-peep" ); DEFSTATICTSCP( t2634 ); DEFSTATICTSCP( t2636 ); DEFCSTRING( t2638, "-lap" ); DEFSTATICTSCP( t2637 ); DEFSTATICTSCP( t2639 ); DEFCSTRING( t2641, "-tree" ); DEFSTATICTSCP( t2640 ); DEFSTATICTSCP( t2642 ); DEFCSTRING( t2644, "-lambda" ); DEFSTATICTSCP( t2643 ); DEFSTATICTSCP( t2645 ); DEFCSTRING( t2647, "-transform" ); DEFSTATICTSCP( t2646 ); DEFSTATICTSCP( t2648 ); DEFCSTRING( t2650, "-closed" ); DEFSTATICTSCP( t2649 ); DEFSTATICTSCP( t2651 ); DEFCSTRING( t2653, "-expand" ); DEFSTATICTSCP( t2652 ); DEFSTATICTSCP( t2654 ); DEFCSTRING( t2656, "-macro" ); DEFSTATICTSCP( t2655 ); DEFSTATICTSCP( t2657 ); DEFCSTRING( t2659, "-source" ); DEFSTATICTSCP( t2658 ); DEFCSTRING( t2660, "(define-constant *type-check* #f)" ); DEFSTATICTSCP( c2156 ); DEFCSTRING( t2661, "(define-constant *bounds-check* #f)" ); DEFSTATICTSCP( c2150 ); DEFCSTRING( t2662, "(define-constant *fixed-only* #t)" ); DEFSTATICTSCP( c2139 ); DEFCSTRING( t2663, "-cc" ); DEFSTATICTSCP( c2100 ); DEFCSTRING( t2664, "-C" ); DEFSTATICTSCP( c2096 ); DEFCSTRING( t2665, "-On" ); DEFSTATICTSCP( c2095 ); DEFCSTRING( t2666, "-Og" ); DEFSTATICTSCP( c2094 ); DEFCSTRING( t2667, "-Ob" ); DEFSTATICTSCP( c2093 ); DEFCSTRING( t2668, "-Ot" ); DEFSTATICTSCP( c2092 ); DEFCSTRING( t2669, "-log" ); DEFSTATICTSCP( c2089 ); DEFCSTRING( t2670, "-LIBDIR" ); DEFSTATICTSCP( c2083 ); DEFCSTRING( t2671, "-m" ); DEFSTATICTSCP( c2074 ); DEFCSTRING( t2672, "-I" ); DEFSTATICTSCP( c2065 ); DEFCSTRING( t2673, "-i" ); DEFSTATICTSCP( c2061 ); DEFCSTRING( t2674, "-f" ); DEFSTATICTSCP( c2041 ); DEFSTATICTSCP( c2015 ); DEFCSTRING( t2675, "../scrt/libs2c_p.a" ); DEFSTATICTSCP( c2012 ); DEFCSTRING( t2676, "../scrt/libs2c.a" ); DEFSTATICTSCP( c2010 ); DEFCSTRING( t2677, "../scrt" ); DEFSTATICTSCP( c2008 ); DEFCSTRING( t2678, "objects.h" ); DEFSTATICTSCP( c2006 ); DEFCSTRING( t2679, "../scrt/predef.sc" ); DEFSTATICTSCP( c2004 ); DEFCSTRING( t2680, "15mar93jfb" ); DEFSTATICTSCP( c2001 ); static void init_constants() { TSCP X1; sc_2dlog_2ddefault_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-LOG-DEFAULT\ " ) ); CONSTANTEXP( ADR( sc_2dlog_2ddefault_v ) ); initialize_2dcompile_v = STRINGTOSYMBOL( CSTRING_TSCP( "INITIALIZE-C\ OMPILE" ) ); CONSTANTEXP( ADR( initialize_2dcompile_v ) ); do_2ddefine_2dconstant_v = STRINGTOSYMBOL( CSTRING_TSCP( "DO-DEFINE-\ CONSTANT" ) ); CONSTANTEXP( ADR( do_2ddefine_2dconstant_v ) ); sc_2dinclude_2ddirs_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-INCLUDE-DI\ RS" ) ); CONSTANTEXP( ADR( sc_2dinclude_2ddirs_v ) ); sc_2dinput_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-INPUT" ) ); CONSTANTEXP( ADR( sc_2dinput_v ) ); sc_2dsource_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-SOURCE-NAME\ " ) ); CONSTANTEXP( ADR( sc_2dsource_2dname_v ) ); sc_2dicode_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-ICODE" ) ); CONSTANTEXP( ADR( sc_2dicode_v ) ); sc_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-ERROR" ) ); CONSTANTEXP( ADR( sc_2derror_v ) ); sc_2dlog_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-LOG" ) ); CONSTANTEXP( ADR( sc_2dlog_v ) ); sc_2dstack_2dtrace_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-STACK-TRACE\ " ) ); CONSTANTEXP( ADR( sc_2dstack_2dtrace_v ) ); sc_2dinterpreter_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-INTERPRETER" ) ); CONSTANTEXP( ADR( sc_2dinterpreter_v ) ); docompile_v = STRINGTOSYMBOL( CSTRING_TSCP( "DOCOMPILE" ) ); CONSTANTEXP( ADR( docompile_v ) ); sc_2derror_2dcnt_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-ERROR-CNT" ) ); CONSTANTEXP( ADR( sc_2derror_2dcnt_v ) ); module_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE-NAME" ) ); CONSTANTEXP( ADR( module_2dname_v ) ); close_2dsc_2dfiles_v = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSE-SC-FILES\ " ) ); CONSTANTEXP( ADR( close_2dsc_2dfiles_v ) ); c2549 = CSTRING_TSCP( t2600 ); CONSTANTEXP( ADR( c2549 ) ); c2548 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c2548 ) ); c2531 = CSTRING_TSCP( t2601 ); CONSTANTEXP( ADR( c2531 ) ); c2530 = CSTRING_TSCP( t2602 ); CONSTANTEXP( ADR( c2530 ) ); c2481 = CSTRING_TSCP( t2603 ); CONSTANTEXP( ADR( c2481 ) ); c2479 = CSTRING_TSCP( t2604 ); CONSTANTEXP( ADR( c2479 ) ); c2447 = CSTRING_TSCP( t2605 ); CONSTANTEXP( ADR( c2447 ) ); c2446 = CSTRING_TSCP( t2606 ); CONSTANTEXP( ADR( c2446 ) ); c2445 = CSTRING_TSCP( t2607 ); CONSTANTEXP( ADR( c2445 ) ); c2443 = CSTRING_TSCP( t2608 ); CONSTANTEXP( ADR( c2443 ) ); c2442 = CSTRING_TSCP( t2609 ); CONSTANTEXP( ADR( c2442 ) ); c2440 = CSTRING_TSCP( t2610 ); CONSTANTEXP( ADR( c2440 ) ); c2429 = CSTRING_TSCP( t2611 ); CONSTANTEXP( ADR( c2429 ) ); c2428 = CSTRING_TSCP( t2612 ); CONSTANTEXP( ADR( c2428 ) ); c2427 = CSTRING_TSCP( t2613 ); CONSTANTEXP( ADR( c2427 ) ); c2382 = CSTRING_TSCP( t2614 ); CONSTANTEXP( ADR( c2382 ) ); c2376 = CSTRING_TSCP( t2615 ); CONSTANTEXP( ADR( c2376 ) ); c2375 = CSTRING_TSCP( t2616 ); CONSTANTEXP( ADR( c2375 ) ); c2374 = CSTRING_TSCP( t2617 ); CONSTANTEXP( ADR( c2374 ) ); c2373 = CSTRING_TSCP( t2618 ); CONSTANTEXP( ADR( c2373 ) ); c2372 = CSTRING_TSCP( t2619 ); CONSTANTEXP( ADR( c2372 ) ); c2361 = CSTRING_TSCP( t2620 ); CONSTANTEXP( ADR( c2361 ) ); c2360 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2360 ) ); c2325 = CSTRING_TSCP( t2621 ); CONSTANTEXP( ADR( c2325 ) ); c2324 = CSTRING_TSCP( t2622 ); CONSTANTEXP( ADR( c2324 ) ); c2323 = CSTRING_TSCP( t2623 ); CONSTANTEXP( ADR( c2323 ) ); c2322 = CSTRING_TSCP( t2624 ); CONSTANTEXP( ADR( c2322 ) ); c2321 = CSTRING_TSCP( t2625 ); CONSTANTEXP( ADR( c2321 ) ); c2305 = CSTRING_TSCP( t2626 ); CONSTANTEXP( ADR( c2305 ) ); c2304 = CSTRING_TSCP( t2627 ); CONSTANTEXP( ADR( c2304 ) ); c2293 = CSTRING_TSCP( t2628 ); CONSTANTEXP( ADR( c2293 ) ); c2276 = CSTRING_TSCP( t2629 ); CONSTANTEXP( ADR( c2276 ) ); c2221 = CSTRING_TSCP( t2630 ); CONSTANTEXP( ADR( c2221 ) ); c2210 = CSTRING_TSCP( t2631 ); CONSTANTEXP( ADR( c2210 ) ); c2189 = CSTRING_TSCP( t2632 ); CONSTANTEXP( ADR( c2189 ) ); c2171 = EMPTYLIST; t2633 = STRINGTOSYMBOL( CSTRING_TSCP( "PEEP" ) ); X1 = t2633; t2634 = CSTRING_TSCP( t2635 ); X1 = CONS( t2634, X1 ); c2171 = CONS( X1, c2171 ); t2636 = STRINGTOSYMBOL( CSTRING_TSCP( "LAP" ) ); X1 = t2636; t2637 = CSTRING_TSCP( t2638 ); X1 = CONS( t2637, X1 ); c2171 = CONS( X1, c2171 ); t2639 = STRINGTOSYMBOL( CSTRING_TSCP( "TREE" ) ); X1 = t2639; t2640 = CSTRING_TSCP( t2641 ); X1 = CONS( t2640, X1 ); c2171 = CONS( X1, c2171 ); t2642 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); X1 = t2642; t2643 = CSTRING_TSCP( t2644 ); X1 = CONS( t2643, X1 ); c2171 = CONS( X1, c2171 ); t2645 = STRINGTOSYMBOL( CSTRING_TSCP( "TRANSFORM" ) ); X1 = t2645; t2646 = CSTRING_TSCP( t2647 ); X1 = CONS( t2646, X1 ); c2171 = CONS( X1, c2171 ); t2648 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED" ) ); X1 = t2648; t2649 = CSTRING_TSCP( t2650 ); X1 = CONS( t2649, X1 ); c2171 = CONS( X1, c2171 ); t2651 = STRINGTOSYMBOL( CSTRING_TSCP( "EXPAND" ) ); X1 = t2651; t2652 = CSTRING_TSCP( t2653 ); X1 = CONS( t2652, X1 ); c2171 = CONS( X1, c2171 ); t2654 = STRINGTOSYMBOL( CSTRING_TSCP( "MACRO" ) ); X1 = t2654; t2655 = CSTRING_TSCP( t2656 ); X1 = CONS( t2655, X1 ); c2171 = CONS( X1, c2171 ); t2657 = STRINGTOSYMBOL( CSTRING_TSCP( "SOURCE" ) ); X1 = t2657; t2658 = CSTRING_TSCP( t2659 ); X1 = CONS( t2658, X1 ); c2171 = CONS( X1, c2171 ); CONSTANTEXP( ADR( c2171 ) ); c2156 = CSTRING_TSCP( t2660 ); CONSTANTEXP( ADR( c2156 ) ); c2150 = CSTRING_TSCP( t2661 ); CONSTANTEXP( ADR( c2150 ) ); c2139 = CSTRING_TSCP( t2662 ); CONSTANTEXP( ADR( c2139 ) ); c2100 = CSTRING_TSCP( t2663 ); CONSTANTEXP( ADR( c2100 ) ); c2096 = CSTRING_TSCP( t2664 ); CONSTANTEXP( ADR( c2096 ) ); c2095 = CSTRING_TSCP( t2665 ); CONSTANTEXP( ADR( c2095 ) ); c2094 = CSTRING_TSCP( t2666 ); CONSTANTEXP( ADR( c2094 ) ); c2093 = CSTRING_TSCP( t2667 ); CONSTANTEXP( ADR( c2093 ) ); c2092 = CSTRING_TSCP( t2668 ); CONSTANTEXP( ADR( c2092 ) ); c2089 = CSTRING_TSCP( t2669 ); CONSTANTEXP( ADR( c2089 ) ); c2083 = CSTRING_TSCP( t2670 ); CONSTANTEXP( ADR( c2083 ) ); c2074 = CSTRING_TSCP( t2671 ); CONSTANTEXP( ADR( c2074 ) ); c2065 = CSTRING_TSCP( t2672 ); CONSTANTEXP( ADR( c2065 ) ); c2061 = CSTRING_TSCP( t2673 ); CONSTANTEXP( ADR( c2061 ) ); c2041 = CSTRING_TSCP( t2674 ); CONSTANTEXP( ADR( c2041 ) ); c2015 = EMPTYLIST; c2015 = CONS( EMPTYSTRING, c2015 ); CONSTANTEXP( ADR( c2015 ) ); c2012 = CSTRING_TSCP( t2675 ); CONSTANTEXP( ADR( c2012 ) ); c2010 = CSTRING_TSCP( t2676 ); CONSTANTEXP( ADR( c2010 ) ); c2008 = CSTRING_TSCP( t2677 ); CONSTANTEXP( ADR( c2008 ) ); c2006 = CSTRING_TSCP( t2678 ); CONSTANTEXP( ADR( c2006 ) ); c2004 = CSTRING_TSCP( t2679 ); CONSTANTEXP( ADR( c2004 ) ); c2001 = CSTRING_TSCP( t2680 ); CONSTANTEXP( ADR( c2001 ) ); } DEFTSCP( main_scc_2dversion_v ); DEFCSTRING( t2681, "SCC-VERSION" ); DEFTSCP( main_force_2dld_2dof_2drep_v ); DEFCSTRING( t2682, "FORCE-LD-OF-REP" ); EXTERNTSCPP( screp_read_2deval_2dprint, XAL1( TSCP ) ); EXTERNTSCP( screp_read_2deval_2dprint_v ); DEFTSCP( main_predef_2ddefault_v ); DEFCSTRING( t2683, "PREDEF-DEFAULT" ); DEFTSCP( main_c_2dinclude_2dfile_v ); DEFCSTRING( t2684, "C-INCLUDE-FILE" ); DEFTSCP( main_c_2dinclude_2ddir_v ); DEFCSTRING( t2685, "C-INCLUDE-DIR" ); DEFTSCP( main_sc_2dlibrary_v ); DEFCSTRING( t2686, "SC-LIBRARY" ); DEFTSCP( main_sc_2dlibrary__p_v ); DEFCSTRING( t2687, "SC-LIBRARY_P" ); DEFTSCP( main_module_2dnames_v ); DEFCSTRING( t2688, "MODULE-NAMES" ); DEFTSCP( main_include_2ddirs_v ); DEFCSTRING( t2689, "INCLUDE-DIRS" ); DEFTSCP( main_scc_v ); DEFCSTRING( t2690, "SCC" ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCPP( scrt1_list_2dref, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_list_2dref_v ); EXTERNTSCP( sc_implementation_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_assoc, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assoc_v ); EXTERNTSCPP( main_do_2dc_2dflag, XAL5( TSCP, TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( main_do_2dc_2dflag_v ); EXTERNTSCP( screp_exit_v ); EXTERNTSCP( screp_reset_v ); EXTERNTSCPP( scrt4_catch_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt4_catch_2derror_v ); EXTERNTSCPP( scrt6_remove_2dfile, XAL1( TSCP ) ); EXTERNTSCP( scrt6_remove_2dfile_v ); TSCP main_l2318( c2858 ) TSCP c2858; { TSCP X3, X2, X1; PUSHSTACKTRACE( "main_l2318 [inside SCC]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c2858, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c2858, 1 ); scrt6_remove_2dfile( DISPLAY( 1 ) ); X3 = scrt6_remove_2dfile( DISPLAY( 0 ) ); DISPLAY( 1 ) = X1; DISPLAY( 0 ) = X2; POPSTACKTRACE( X3 ); } TSCP main_l2317( c2856 ) TSCP c2856; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "main_l2317 [inside SCC]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c2856, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c2856, 1 ); X3 = DISPLAY( 2 ); DISPLAY( 2 ) = CLOSURE_VAR( c2856, 2 ); X5 = MAKEPROCEDURE( 0, 0, main_l2318, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 1 ), DISPLAY( 0 ) ) ); scrt4_catch_2derror( X5 ); X5 = DISPLAY( 2 ); X5 = UNKNOWNCALL( X5, 0 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); DISPLAY( 1 ) = X1; DISPLAY( 0 ) = X2; DISPLAY( 2 ) = X3; POPSTACKTRACE( X4 ); } EXTERNTSCPP( scrt5_open_2doutput_2dfile, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2doutput_2dfile_v ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt5_close_2doutput_2dport, XAL1( TSCP ) ); EXTERNTSCP( scrt5_close_2doutput_2dport_v ); EXTERNTSCPP( scrt4_system, XAL1( TSCP ) ); EXTERNTSCP( scrt4_system_v ); EXTERNTSCPP( sc_apply_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_apply_2dtwo_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt1_member, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_member_v ); EXTERNTSCP( sc_emptystring ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); TSCP main_l2441( c2909 ) TSCP c2909; { TSCP X3, X2, X1; PUSHSTACKTRACE( "main_l2441 [inside SCC]" ); X1 = DISPLAY( 1 ); DISPLAY( 1 ) = CLOSURE_VAR( c2909, 0 ); X2 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c2909, 1 ); scrt6_remove_2dfile( DISPLAY( 1 ) ); X3 = scrt6_remove_2dfile( DISPLAY( 0 ) ); DISPLAY( 1 ) = X1; DISPLAY( 0 ) = X2; POPSTACKTRACE( X3 ); } TSCP main_scc( c2018 ) TSCP c2018; { TSCP X21, X20, X19, X18, X17, X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SD1 = DISPLAY( 1 ); TSCP SD2 = DISPLAY( 2 ); TSCP SDVAL; PUSHSTACKTRACE( t2690 ); X1 = c2447; X2 = EMPTYLIST; X6 = sc_implementation_v; X6 = UNKNOWNCALL( X6, 0 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( PROCEDURE_CLOSURE( X6 ) ); X4 = scrt1_list_2dref( X5, _TSCP( 20 ) ); if ( FALSE( scrt1_equal_3f( X4, c2445 ) ) ) goto L2692; X3 = c2446; goto L2693; L2692: X3 = c2276; L2693: DISPLAY( 0 ) = c2443; DISPLAY( 1 ) = c2442; X4 = EMPTYLIST; X5 = FALSEVALUE; X6 = TRUEVALUE; X7 = FALSEVALUE; X8 = EMPTYLIST; X8 = CONS( X8, EMPTYLIST ); X7 = CONS( X7, EMPTYLIST ); X6 = CONS( X6, EMPTYLIST ); X5 = CONS( X5, EMPTYLIST ); X4 = CONS( X4, EMPTYLIST ); X2 = CONS( X2, EMPTYLIST ); X1 = CONS( X1, EMPTYLIST ); if ( EQ( TSCPTAG( c2018 ), PAIRTAG ) ) goto L2696; scrt1__24__cdr_2derror( c2018 ); L2696: X9 = PAIR_CDR( c2018 ); X10 = X9; L2700: if ( FALSE( X10 ) ) goto L2729; if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L2704; scrt1__24__car_2derror( X10 ); L2704: X11 = PAIR_CAR( X10 ); X12 = scrt1_equal_3f( X11, c2041 ); if ( FALSE( X12 ) ) goto L2728; X13 = PAIR_CDR( X10 ); if ( FALSE( X13 ) ) goto L2728; X14 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L2718; scrt1__24__cdr_2derror( X14 ); L2718: if ( FALSE( PAIR_CDR( X14 ) ) ) goto L2728; X17 = CONS( c2305, EMPTYLIST ); X17 = CONS( scrt1_caddr( X10 ), X17 ); X17 = CONS( c2304, X17 ); X18 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X18 ), PAIRTAG ) ) goto L2725; scrt1__24__car_2derror( X18 ); L2725: X17 = CONS( PAIR_CAR( X18 ), X17 ); X16 = scrt3_string_2dappend( CONS( c2293, X17 ) ); X15 = sc_cons( X16, PAIR_CAR( X8 ) ); SETGEN( PAIR_CAR( X8 ), X15 ); X10 = scrt1_cdddr( X10 ); GOBACK( L2700 ); L2728: if ( FALSE( scrt1_equal_3f( X11, c2061 ) ) ) goto L2730; X12 = TRUEVALUE; SETGEN( PAIR_CAR( X7 ), X12 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2730: X12 = scrt1_equal_3f( X11, c2065 ); if ( FALSE( X12 ) ) goto L2751; if ( FALSE( PAIR_CDR( X10 ) ) ) goto L2751; X16 = CONS( c2276, EMPTYLIST ); X17 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X17 ), PAIRTAG ) ) goto L2744; scrt1__24__car_2derror( X17 ); L2744: X15 = scrt3_string_2dappend( CONS( PAIR_CAR( X17 ), X16 ) ); X14 = sc_cons( X15, EMPTYLIST ); X13 = X14; main_include_2ddirs_v = scrt1_append_2dtwo( main_include_2ddirs_v, X13 ); X13 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2749; scrt1__24__cdr_2derror( X13 ); L2749: X10 = PAIR_CDR( X13 ); GOBACK( L2700 ); L2751: X12 = scrt1_equal_3f( X11, c2074 ); if ( FALSE( X12 ) ) goto L2768; if ( FALSE( PAIR_CDR( X10 ) ) ) goto L2768; X14 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L2762; scrt1__24__car_2derror( X14 ); L2762: X13 = PAIR_CAR( X14 ); main_module_2dnames_v = sc_cons( X13, main_module_2dnames_v ); X13 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2766; scrt1__24__cdr_2derror( X13 ); L2766: X10 = PAIR_CDR( X13 ); GOBACK( L2700 ); L2768: X12 = scrt1_equal_3f( X11, c2083 ); if ( FALSE( X12 ) ) goto L2801; if ( FALSE( PAIR_CDR( X10 ) ) ) goto L2801; X13 = CONS( c2189, EMPTYLIST ); X13 = CONS( X3, X13 ); X14 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L2779; scrt1__24__car_2derror( X14 ); L2779: main_predef_2ddefault_v = scrt3_string_2dappend( CONS( PAIR_CAR( X14 ), X13 ) ); X13 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2783; scrt1__24__car_2derror( X13 ); L2783: main_c_2dinclude_2ddir_v = PAIR_CAR( X13 ); X13 = CONS( c2210, EMPTYLIST ); X13 = CONS( X3, X13 ); X14 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L2787; scrt1__24__car_2derror( X14 ); L2787: main_sc_2dlibrary_v = scrt3_string_2dappend( CONS( PAIR_CAR( X14 ), X13 ) ); X13 = CONS( c2221, EMPTYLIST ); X13 = CONS( X3, X13 ); X14 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L2791; scrt1__24__car_2derror( X14 ); L2791: main_sc_2dlibrary__p_v = scrt3_string_2dappend( CONS( PAIR_CAR( X14 ), X13 ) ); X13 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2795; scrt1__24__car_2derror( X13 ); L2795: main_c_2dinclude_2ddir_v = PAIR_CAR( X13 ); X13 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2799; scrt1__24__cdr_2derror( X13 ); L2799: X10 = PAIR_CDR( X13 ); GOBACK( L2700 ); L2801: if ( FALSE( scrt1_equal_3f( X11, c2089 ) ) ) goto L2802; X12 = SYMBOL_VALUE( sc_2dlog_2ddefault_v ); SETGEN( PAIR_CAR( X2 ), X12 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2802: X12 = scrt1_assoc( X11, c2171 ); if ( FALSE( X12 ) ) goto L2807; if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L2811; scrt1__24__cdr_2derror( X12 ); L2811: X14 = PAIR_CDR( X12 ); X13 = sc_cons( X14, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X13 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2807: if ( FALSE( scrt1_equal_3f( X11, c2092 ) ) ) goto L2814; X13 = sc_cons( c2156, PAIR_CAR( X8 ) ); SETGEN( PAIR_CAR( X8 ), X13 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2814: if ( FALSE( scrt1_equal_3f( X11, c2093 ) ) ) goto L2818; X13 = sc_cons( c2150, PAIR_CAR( X8 ) ); SETGEN( PAIR_CAR( X8 ), X13 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2818: if ( FALSE( scrt1_equal_3f( X11, c2094 ) ) ) goto L2822; X13 = FALSEVALUE; SETGEN( PAIR_CAR( X6 ), X13 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2822: if ( FALSE( scrt1_equal_3f( X11, c2095 ) ) ) goto L2826; X13 = sc_cons( c2139, PAIR_CAR( X8 ) ); SETGEN( PAIR_CAR( X8 ), X13 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2826: if ( FALSE( scrt1_equal_3f( X11, c2096 ) ) ) goto L2830; X13 = TRUEVALUE; SETGEN( PAIR_CAR( X5 ), X13 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2830: X13 = scrt1_equal_3f( X11, c2100 ); if ( FALSE( X13 ) ) goto L2850; if ( FALSE( PAIR_CDR( X10 ) ) ) goto L2850; X15 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X15 ), PAIRTAG ) ) goto L2844; scrt1__24__car_2derror( X15 ); L2844: X14 = PAIR_CAR( X15 ); SETGEN( PAIR_CAR( X1 ), X14 ); X14 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L2848; scrt1__24__cdr_2derror( X14 ); L2848: X10 = PAIR_CDR( X14 ); GOBACK( L2700 ); L2850: X13 = main_do_2dc_2dflag( X11, PAIR_CAR( X8 ), PAIR_CAR( X2 ), PAIR_CAR( X6 ), PAIR_CAR( X7 ) ); X12 = sc_cons( X13, PAIR_CAR( X4 ) ); SETGEN( PAIR_CAR( X4 ), X12 ); X10 = PAIR_CDR( X10 ); GOBACK( L2700 ); L2729: if ( FALSE( PAIR_CAR( X5 ) ) ) goto L2853; X9 = screp_exit_v; X9 = UNKNOWNCALL( X9, 0 ); VIA( PROCEDURE_CODE( X9 ) )( PROCEDURE_CLOSURE( X9 ) ); L2853: DISPLAY( 2 ) = screp_reset_v; screp_reset_v = MAKEPROCEDURE( 0, 0, main_l2317, MAKECLOSURE( EMPTYLIST, 3, DISPLAY( 1 ), DISPLAY( 0 ), DISPLAY( 2 ) ) ); if ( FALSE( PAIR_CAR( X7 ) ) ) goto L2860; X9 = scrt5_open_2doutput_2dfile( DISPLAY( 1 ) ); X10 = CONS( main_c_2dinclude_2dfile_v, EMPTYLIST ); X10 = CONS( main_c_2dinclude_2ddir_v, X10 ); scrt6_format( X9, CONS( c2321, X10 ) ); scrt6_format( X9, CONS( c2322, EMPTYLIST ) ); scrt6_format( X9, CONS( c2323, EMPTYLIST ) ); scrt6_format( X9, CONS( c2324, EMPTYLIST ) ); scrt6_format( X9, CONS( c2325, EMPTYLIST ) ); X11 = scrt1_reverse( main_module_2dnames_v ); X10 = sc_cons( c2373, X11 ); X11 = X10; X12 = EMPTYLIST; X13 = EMPTYLIST; L2865: if ( EQ( _S2CUINT( X11 ), _S2CUINT( EMPTYLIST ) ) ) goto L2873; if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L2869; scrt1__24__car_2derror( X11 ); L2869: X16 = CONS( PAIR_CAR( X11 ), EMPTYLIST ); X15 = scrt6_format( X9, CONS( c2372, X16 ) ); X14 = sc_cons( X15, EMPTYLIST ); if ( NEQ( _S2CUINT( X12 ), _S2CUINT( EMPTYLIST ) ) ) goto L2872; X15 = PAIR_CDR( X11 ); X13 = X14; X12 = X14; X11 = X15; GOBACK( L2865 ); L2872: X15 = PAIR_CDR( X11 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L2877; scdebug_error( c2360, c2361, CONS( X13, EMPTYLIST ) ); L2877: X13 = SETGEN( PAIR_CDR( X13 ), X14 ); X11 = X15; GOBACK( L2865 ); L2873: scrt6_format( X9, CONS( c2374, EMPTYLIST ) ); scrt6_format( X9, CONS( c2375, EMPTYLIST ) ); scrt6_format( X9, CONS( c2376, EMPTYLIST ) ); scrt5_close_2doutput_2dport( X9 ); X12 = sc_cons( DISPLAY( 1 ), EMPTYLIST ); X11 = X12; X10 = scrt1_append_2dtwo( PAIR_CAR( X4 ), X11 ); SETGEN( PAIR_CAR( X4 ), X10 ); L2860: if ( FALSE( scrt1_member( c2427, PAIR_CAR( X4 ) ) ) ) goto L2882; X14 = scrt1_reverse( PAIR_CAR( X4 ) ); goto L2883; L2882: X15 = scrt1_reverse( PAIR_CAR( X4 ) ); if ( FALSE( scrt1_member( c2428, PAIR_CAR( X4 ) ) ) ) goto L2884; X17 = scrt1_cons_2a( main_sc_2dlibrary__p_v, CONS( EMPTYLIST, EMPTYLIST ) ); goto L2885; L2884: X17 = scrt1_cons_2a( main_sc_2dlibrary_v, CONS( EMPTYLIST, EMPTYLIST ) ); L2885: X19 = CONS( EMPTYLIST, EMPTYLIST ); X20 = C_FIXED( STACK_OVERFLOW ); if ( BITAND( BITOR( _S2CINT( X20 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2887; if ( NEQ( _S2CUINT( X20 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L2889; X21 = c2440; goto L2892; L2889: X21 = sc_emptystring; goto L2892; L2887: if ( FALSE( scrt2__3d_2dtwo( X20, _TSCP( 4 ) ) ) ) goto L2891; X21 = c2440; goto L2892; L2891: X21 = sc_emptystring; L2892: X18 = scrt1_cons_2a( c2429, CONS( X21, X19 ) ); X16 = scrt1_append_2dtwo( X17, X18 ); X14 = scrt1_append_2dtwo( X15, X16 ); L2883: X15 = X14; X16 = EMPTYLIST; X17 = EMPTYLIST; L2895: if ( NEQ( _S2CUINT( X15 ), _S2CUINT( EMPTYLIST ) ) ) goto L2896; X13 = X16; goto L2903; L2896: if ( EQ( TSCPTAG( X15 ), PAIRTAG ) ) goto L2899; scrt1__24__car_2derror( X15 ); L2899: X20 = CONS( PAIR_CAR( X15 ), EMPTYLIST ); X19 = scrt3_string_2dappend( CONS( c2304, X20 ) ); X18 = sc_cons( X19, EMPTYLIST ); if ( NEQ( _S2CUINT( X16 ), _S2CUINT( EMPTYLIST ) ) ) goto L2902; X19 = PAIR_CDR( X15 ); X17 = X18; X16 = X18; X15 = X19; GOBACK( L2895 ); L2902: X19 = PAIR_CDR( X15 ); if ( EQ( TSCPTAG( X17 ), PAIRTAG ) ) goto L2907; scdebug_error( c2360, c2361, CONS( X17, EMPTYLIST ) ); L2907: X17 = SETGEN( PAIR_CDR( X17 ), X18 ); X15 = X19; GOBACK( L2895 ); L2903: X14 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X12 = CONS( scrt1_append_2dtwo( X13, X14 ), EMPTYLIST ); X12 = CONS( main_c_2dinclude_2ddir_v, X12 ); X11 = scrt1_cons_2a( PAIR_CAR( X1 ), CONS( c2382, X12 ) ); X10 = sc_apply_2dtwo( scrt3_string_2dappend_v, X11 ); X9 = scrt4_system( X10 ); if ( EQ( _S2CUINT( _TSCP( 0 ) ), _S2CUINT( X9 ) ) ) goto L2880; X9 = screp_reset_v; X9 = UNKNOWNCALL( X9, 0 ); VIA( PROCEDURE_CODE( X9 ) )( PROCEDURE_CLOSURE( X9 ) ); L2880: X9 = MAKEPROCEDURE( 0, 0, main_l2441, MAKECLOSURE( EMPTYLIST, 2, DISPLAY( 1 ), DISPLAY( 0 ) ) ); SDVAL = scrt4_catch_2derror( X9 ); DISPLAY( 0 ) = SD0; DISPLAY( 1 ) = SD1; DISPLAY( 2 ) = SD2; POPSTACKTRACE( SDVAL ); } DEFTSCP( main_do_2dc_2dflag_v ); DEFCSTRING( t2911, "DO-C-FLAG" ); EXTERNTSCPP( scrt3_substring, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt3_substring_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( scrt2_max_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_max_2dtwo_v ); EXTERNTSCPP( scrt2__3e_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3e_2dtwo_v ); EXTERNTSCPP( scrt3_string_3d_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt3_string_3d_3f_v ); EXTERNTSCPP( scrt6_read, XAL1( TSCP ) ); EXTERNTSCP( scrt6_read_v ); EXTERNTSCPP( scrt5_open_2dinput_2dstring, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2dinput_2dstring_v ); EXTERNTSCPP( scrt5_open_2dinput_2dfile, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2dinput_2dfile_v ); EXTERNTSCP( scrt5_stderr_2dport_v ); EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); EXTERNTSCPP( scrt6_rename_2dfile, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_rename_2dfile_v ); TSCP main_do_2dc_2dflag( a2449, f2450, l2451, s2452, i2453 ) TSCP a2449, f2450, l2451, s2452, i2453; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2911 ); if ( AND( EQ( TSCPTAG( a2449 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( a2449 ), STRINGTAG ) ) ) goto L2914; scdebug_error( c2548, c2549, CONS( a2449, EMPTYLIST ) ); L2914: X3 = C_FIXED( STRING_LENGTH( a2449 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 12 ) ) ), 3 ) ) goto L2917; X6 = _TSCP( IDIFFERENCE( _S2CINT( X3 ), _S2CINT( _TSCP( 12 ) ) ) ); goto L2918; L2917: X6 = scrt2__2d_2dtwo( X3, _TSCP( 12 ) ); L2918: if ( BITAND( BITOR( _S2CINT( _TSCP( 0 ) ), _S2CINT( X6 ) ), 3 ) ) goto L2920; if ( LTE( _S2CINT( _TSCP( 0 ) ), _S2CINT( X6 ) ) ) goto L2922; X5 = _TSCP( 0 ); goto L2921; L2922: X5 = X6; goto L2921; L2920: X5 = scrt2_max_2dtwo( _TSCP( 0 ), X6 ); L2921: X4 = scrt3_substring( a2449, _TSCP( 0 ), X5 ); X5 = CONS( c2531, EMPTYLIST ); X1 = scrt3_string_2dappend( CONS( X4, X5 ) ); X5 = CONS( c2530, EMPTYLIST ); X2 = scrt3_string_2dappend( CONS( X4, X5 ) ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 12 ) ) ), 3 ) ) goto L2928; if ( GT( _S2CINT( X3 ), _S2CINT( _TSCP( 12 ) ) ) ) goto L2932; POPSTACKTRACE( a2449 ); L2928: if ( TRUE( scrt2__3e_2dtwo( X3, _TSCP( 12 ) ) ) ) goto L2932; POPSTACKTRACE( a2449 ); L2932: if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 12 ) ) ), 3 ) ) goto L2937; X5 = _TSCP( IDIFFERENCE( _S2CINT( X3 ), _S2CINT( _TSCP( 12 ) ) ) ); goto L2938; L2937: X5 = scrt2__2d_2dtwo( X3, _TSCP( 12 ) ); L2938: X4 = scrt3_substring( a2449, X5, X3 ); if ( FALSE( scrt3_string_3d_3f( X4, c2479 ) ) ) goto L2935; X4 = CONS( a2449, EMPTYLIST ); scrt6_format( TRUEVALUE, CONS( c2481, X4 ) ); X4 = SYMBOL_VALUE( initialize_2dcompile_v ); X4 = UNKNOWNCALL( X4, 0 ); VIA( PROCEDURE_CODE( X4 ) )( PROCEDURE_CLOSURE( X4 ) ); X4 = f2450; L2941: if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L2942; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L2946; scrt1__24__car_2derror( X4 ); L2946: X5 = PAIR_CAR( X4 ); X7 = scrt6_read( CONS( scrt5_open_2dinput_2dstring( X5 ), EMPTYLIST ) ); X6 = SYMBOL_VALUE( do_2ddefine_2dconstant_v ); X6 = UNKNOWNCALL( X6, 1 ); VIA( PROCEDURE_CODE( X6 ) )( X7, PROCEDURE_CLOSURE( X6 ) ); X4 = PAIR_CDR( X4 ); GOBACK( L2941 ); L2942: SETGENTL( SYMBOL_VALUE( sc_2dinclude_2ddirs_v ), main_include_2ddirs_v ); X5 = scrt5_open_2dinput_2dfile( a2449 ); X4 = sc_cons( X5, EMPTYLIST ); SETGENTL( SYMBOL_VALUE( sc_2dinput_v ), X4 ); SETGENTL( SYMBOL_VALUE( sc_2dsource_2dname_v ), a2449 ); SETGENTL( SYMBOL_VALUE( sc_2dicode_v ), scrt5_open_2doutput_2dfile( X1 ) ); SETGENTL( SYMBOL_VALUE( sc_2derror_v ), scrt5_stderr_2dport_v ); SETGENTL( SYMBOL_VALUE( sc_2dlog_v ), l2451 ); SETGENTL( SYMBOL_VALUE( sc_2dstack_2dtrace_v ), s2452 ); SETGENTL( SYMBOL_VALUE( sc_2dinterpreter_v ), i2453 ); X4 = SYMBOL_VALUE( docompile_v ); X4 = UNKNOWNCALL( X4, 0 ); VIA( PROCEDURE_CODE( X4 ) )( PROCEDURE_CLOSURE( X4 ) ); X4 = SYMBOL_VALUE( sc_2derror_2dcnt_v ); if ( NEQ( TSCPTAG( X4 ), FIXNUMTAG ) ) goto L2953; if ( NEQ( _S2CUINT( X4 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L2957; goto L2960; L2953: if ( TRUE( scrt2_zero_3f( X4 ) ) ) goto L2960; L2957: X5 = screp_reset_v; X5 = UNKNOWNCALL( X5, 0 ); VIA( PROCEDURE_CODE( X5 ) )( PROCEDURE_CLOSURE( X5 ) ); L2960: X4 = SYMBOL_VALUE( module_2dname_v ); main_module_2dnames_v = sc_cons( X4, main_module_2dnames_v ); X4 = SYMBOL_VALUE( close_2dsc_2dfiles_v ); X4 = UNKNOWNCALL( X4, 0 ); VIA( PROCEDURE_CODE( X4 ) )( PROCEDURE_CLOSURE( X4 ) ); scrt6_rename_2dfile( X1, X2 ); POPSTACKTRACE( X2 ); L2935: POPSTACKTRACE( a2449 ); } void main__init(){} void scrt2__init(); void scdebug__init(); void scrt5__init(); void scrt6__init(); void scrt4__init(); void scrt3__init(); void scrt1__init(); void screp__init(); void callcode__init(); void closeana__init(); void compile__init(); void expform__init(); void gencode__init(); void lambdacode__init(); void lambdaexp__init(); void lap__init(); void macros__init(); void misccode__init(); void miscexp__init(); void plist__init(); void readtext__init(); void transform__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt2__init(); scdebug__init(); scrt5__init(); scrt6__init(); scrt4__init(); scrt3__init(); scrt1__init(); screp__init(); callcode__init(); closeana__init(); compile__init(); expform__init(); gencode__init(); lambdacode__init(); lambdaexp__init(); lap__init(); macros__init(); misccode__init(); miscexp__init(); plist__init(); readtext__init(); transform__init(); MAXDISPLAY( 3 ); } int main( int argc, char **argv ) { static int init = 0; if (init) return 1; init = 1; INITHEAP( 0, argc, argv, main_scc ); init_constants(); init_modules( "(main SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2681, ADR( main_scc_2dversion_v ), c2001 ); INITIALIZEVAR( t2682, ADR( main_force_2dld_2dof_2drep_v ), screp_read_2deval_2dprint_v ); INITIALIZEVAR( t2683, ADR( main_predef_2ddefault_v ), c2004 ); INITIALIZEVAR( t2684, ADR( main_c_2dinclude_2dfile_v ), c2006 ); INITIALIZEVAR( t2685, ADR( main_c_2dinclude_2ddir_v ), c2008 ); INITIALIZEVAR( t2686, ADR( main_sc_2dlibrary_v ), c2010 ); INITIALIZEVAR( t2687, ADR( main_sc_2dlibrary__p_v ), c2012 ); INITIALIZEVAR( t2688, ADR( main_module_2dnames_v ), EMPTYLIST ); INITIALIZEVAR( t2689, ADR( main_include_2ddirs_v ), c2015 ); INITIALIZEVAR( t2690, ADR( main_scc_v ), MAKEPROCEDURE( 1, 0, main_scc, EMPTYLIST ) ); INITIALIZEVAR( t2911, ADR( main_do_2dc_2dflag_v ), MAKEPROCEDURE( 5, 0, main_do_2dc_2dflag, EMPTYLIST ) ); main_scc( CLARGUMENTS( argc, argv ) ); SCHEMEEXIT(); return 0; } scheme2c-2012.10.14/scsc/main.sc000066400000000000000000000234541203736146400160170ustar00rootroot00000000000000;;; This file is the "main" program for the Scheme->C Scheme compiler. It ;;; defines the implementation dependent information, a configuration ;;; function, and the "main" function which interpretes the command line ;;; arguments and drives the compiler. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module MAIN (main scc) (with callcode closeana compile expform gencode lambdacode lambdaexp lap macros misccode miscexp plist readtext transform)) (define SCC-VERSION "15mar93jfb") ; Compiler version string. (define FORCE-LD-OF-REP read-eval-print) ; Assure that read-eval-print is available ; for compiler debugging. ;;; The following top-level variables define the implementation dependent ;;; information: (define PREDEF-DEFAULT "../scrt/predef.sc") ; File holding the declarations for predefined ; functions. (define C-INCLUDE-FILE "objects.h") ; #include file for the predefined functions. (define C-INCLUDE-DIR "../scrt") ; directory containing #include file for ; predefined functions. (define SC-LIBRARY "../scrt/libs2c.a") ; Scheme->C library file. (define SC-LIBRARY_P "../scrt/libs2c_p.a") ; Scheme->C profiled library file. ;;; When the compiler is invoked directly from the shell, the following ;;; function is invoked to control compilation. It will interprete the flags, ;;; invoke the compiler and then exit. Any compilation errors or Scheme errors ;;; will cause the process to abnormally terminate. ;;; ;;; The command format is: ;;; ;;; scc [ flags ] files... ;;; ;;; where the flags are: ;;; ;;; -cc C compiler ;;; ;;; -C compile the named Scheme programs and leave the ;;; resulting C code in .c files. ;;; ;;; -f flag value set a compile time constant. Equivilant to ;;; (define-constant flag value). ;;; ;;; -i produce a Scheme interpreter as the output file. ;;; ;;; -I directory directory prefix to use for searching for #include ;;; files. ;;; ;;; -m module specifies a module name which must be initialized ;;; by the interpreter (see -I) as the source was ;;; previously compiled. ;;; ;;; -Ob optimize C code by omitting bounds checks. ;;; ;;; -Og optimize C code by omitting stack trace-back code. ;;; ;;; -On optimize C code by assuming that all numbers are ;;; fixed point. ;;; ;;; -Ot optimize C code by omitting type checks. ;;; ;;; -pg compile for gprof profiling. ;;; ;;; -LIBDIR directory ;;; directory containing "predef.sc", "objects.h", ;;; "libs2c.a" and optionally "libs2c_p.a". ;;; ;;; -log log the default compiler events ;;; ;;; -source specific events to log. ;;; -macro ;;; -expand ;;; -closed ;;; -transform ;;; -lambda ;;; -tree ;;; -lap ;;; -peep ;;; ;;; All other flags will be passed to the C compiler unchanged. Following ;;; the flags come source and object files which are to be compiled: ;;; ;;; name.sc Scheme source file which is to be compiled to ;;; to name.c. ;;; ;;; All other files are passed to the C compiler unchanged. (define MODULE-NAMES '()) (define INCLUDE-DIRS '("")) (define (SCC clargs) (let ((flags '()) (interpreter #f) (strace #t) (c-only #f) (c-flags '()) (sc-to-c.c "SC-TO-C.c") (sc-to-c.o "SC-TO-C.o") (directory-separator (if (equal? (list-ref (implementation-information) 5) "Microsoft Windows 3.x") "\\" "/")) (log '()) (cc "cc")) ;;; 1. Pick up the command line arguments. (let loop ((args (cdr clargs))) (if args (let ((arg (car args))) (cond ((and (equal? arg "-f") (cdr args) (cddr args)) (set! flags (cons (string-append "(define-constant " (cadr args) " " (caddr args) ")") flags)) (loop (cdddr args))) ((equal? arg "-i") (set! interpreter #t) (loop (cdr args))) ((and (equal? arg "-I") (cdr args)) (set! include-dirs (append include-dirs (list (string-append (cadr args) "/")))) (loop (cddr args))) ((and (equal? arg "-m") (cdr args)) (set! module-names (cons (cadr args) module-names)) (loop (cddr args))) ((and (equal? arg "-LIBDIR") (cdr args)) (set! predef-default (string-append (cadr args) directory-separator "predef.sc")) (set! c-include-dir (cadr args)) (set! sc-library (string-append (cadr args) directory-separator "libs2c.a")) (set! sc-library_p (string-append (cadr args) directory-separator "libs2c_p.a")) (set! c-include-dir (cadr args)) (loop (cddr args))) ((equal? arg "-log") (set! log sc-log-default) (loop (cdr args))) ((assoc arg '(("-source" . source) ("-macro" . macro) ("-expand" . expand) ("-closed" . closed) ("-transform" . transform) ("-lambda" . lambda) ("-tree" . tree) ("-lap" . lap) ("-peep" . peep))) => (lambda (flag) (set! log (cons (cdr flag) log)) (loop (cdr args)))) ((equal? arg "-Ot") (set! flags (cons "(define-constant *type-check* #f)" flags)) (loop (cdr args))) ((equal? arg "-Ob") (set! flags (cons "(define-constant *bounds-check* #f)" flags)) (loop (cdr args))) ((equal? arg "-Og") (set! strace #f) (loop (cdr args))) ((equal? arg "-On") (set! flags (cons "(define-constant *fixed-only* #t)" flags)) (loop (cdr args))) ((equal? arg "-C") (set! c-only #t) (loop (cdr args))) ((and (equal? arg "-cc") (cdr args)) (set! cc (cadr args)) (loop (cddr args))) (else (set! c-flags (cons (do-c-flag arg flags log strace interpreter) c-flags)) (loop (cdr args))))))) ;;; 2. If -C option was specified, then we're done here. (if c-only (exit)) ;;; 3. If the -i option was specified, build the main program. (set! reset (let ((prev-reset reset)) (lambda () (catch-error (lambda () (remove-file sc-to-c.c) (remove-file sc-to-c.o))) (prev-reset)))) (if interpreter (let ((fh (open-output-file sc-to-c.c))) (format fh "#include \"~a/~a\"~%" c-include-dir c-include-file) (format fh "extern TSCP screp_read_2deval_2dprint();~%") (format fh "int main(int argc, char **argv)~%") (format fh "{~%") (format fh " INITHEAP( 0, argc, argv, screp_read_2deval_2dprint );~%") (map (lambda (m) (format fh " ~a__init();~%" m)) (cons "screp" (reverse module-names))) (format fh " screp_read_2deval_2dprint( sc_clarguments( argc, argv ) );~%") (format fh " SCHEMEEXIT();~%") (format fh "}~%") (close-output-port fh) (set! c-flags (append c-flags (list sc-to-c.c))))) ;;; 4. Flags processed and all .sc -> .c compiles done. Invoke the ;;; C compiler to do the rest. (unless (eq? 0 (system (apply string-append `(,cc " -I" ,c-include-dir ,@(map (lambda (x) (string-append " " x)) (if (member "-c" c-flags) (reverse c-flags) (append (reverse c-flags) (if (member "-pg" c-flags) `(,sc-library_p) `(,sc-library)) `("-lm" ,(if (= ((lap () (C_FIXED "STACK_OVERFLOW"))) 1) "-lsigsegv" ""))))))))) (reset)) (catch-error (lambda () (remove-file sc-to-c.c) (remove-file sc-to-c.o))))) ;;; Command line arguments which are not recognized as Scheme->C ;;; flags are processed by the following function which will ;;; return the argument to pass to the C compiler. (define (DO-C-FLAG arg flags log strace interpreter) (let* ((len (string-length arg)) (root (substring arg 0 (max 0 (- len 3)))) (root.S2C (string-append root ".S2C")) (root.c (string-append root ".c"))) (cond ((and (> len 3) (string=? (substring arg (- len 3) len) ".sc")) ;;; Compile an .sc file to a .c file. (format #t "~a:~%" arg) (initialize-compile) (for-each (lambda (flag) (do-define-constant (read (open-input-string flag)))) flags) (set! sc-include-dirs include-dirs) (set! sc-input (list (open-input-file arg))) (set! sc-source-name arg) (set! sc-icode (open-output-file root.S2C)) (set! sc-error stderr-port) (set! sc-log log) (set! sc-stack-trace strace) (set! sc-interpreter interpreter) (docompile) (if (not (zero? sc-error-cnt)) (reset)) (set! module-names (cons module-name module-names)) (close-sc-files) (rename-file root.S2C root.c) root.c) ;;; Pass argument to C. (else arg)))) scheme2c-2012.10.14/scsc/makefile000066400000000000000000000065571203736146400162510ustar00rootroot00000000000000# # Build the SCHEME->C compiler. # # Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. # All Rights Reserved # Permission is hereby granted, free of charge, to any person obtaining a # copy of this software and associated documentation files (the "Software"), # to deal in the Software without restriction, including without limitation # the rights to use, copy, modify, merge, publish, distribute, sublicense, # and/or sell copies of the Software, and to permit persons to whom the # Software is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER # DEALINGS IN THE SOFTWARE. # all: prefix=/usr/local LIBDIR=${prefix}/lib BINDIR=${prefix}/bin ## previously value was LIBSUBDIR = schemetoc LIBSUBDIR = scheme2c INSTALL = install INSTALL_DATA = ${INSTALL} -m 644 INSTALL_PROGRAM = ${INSTALL} INSTALL_SCRIPT = ${INSTALL} .SUFFIXES: .SUFFIXES: .o .c .sc .s SCC = s2cc SCCFLAGS = SRCDIR = ../../scsc RTDIR = ../scrt RT = ${RTDIR}/libs2c.a # Defaults for configuring s2cc and Xs2cc commands. SCL = 80 SCMH = 40 scsc = main.sc closeana.sc lambdaexp.sc plist.sc transform.sc expform.sc \ readtext.sc miscexp.sc macros.sc compile.sc lap.sc gencode.sc \ callcode.sc lambdacode.sc misccode.sc scc = main.c closeana.c lambdaexp.c plist.c transform.c expform.c \ readtext.c miscexp.c macros.c compile.c lap.c gencode.c \ callcode.c lambdacode.c misccode.c sco = main.o closeana.o lambdaexp.o plist.o transform.o expform.o \ readtext.o miscexp.o macros.o compile.o lap.o gencode.o \ callcode.o lambdacode.o misccode.o scsch = expform.sch gencode.sch lambdaexp.sch lap.sch miscexp.sch plist.sch .SUFFIXES: .SUFFIXES: .o .sc .c .sc.c: ${SCC} -C $*.sc .c.o: ${CC} -c ${CFLAGS} -I${RTDIR} $*.c sc-to-c: ${scc} Xs2ccomp: ${scc} ${sco} ${RT} ${CC} -o Xs2ccomp ${CFLAGS} ${sco} ${RT} -lm ${LDFLAGS} s2ccomp: Xs2ccomp cp -pR Xs2ccomp s2ccomp port: $(MAKE) "CC=${CC}" "CFLAGS=${CFLAGS}" "SCC=echo" Xs2ccomp s2ccomp s2cc: echo '#! /bin/sh' > $@ echo ${LIBDIR}/${LIBSUBDIR}/s2ccomp -scl ${SCL} -scmh ${SCMH} \ -cc ${CC} -LIBDIR ${LIBDIR}/${LIBSUBDIR} '$$*' >> $@ chmod +x $@ Xs2cc: echo '#! /bin/sh' > $@ echo $$(pwd)/s2ccomp -scl ${SCL} -scmh ${SCMH} \ -cc ${CC} -LIBDIR $$(pwd)/${RTDIR} '$$*' >> $@ chmod +x $@ all: s2cc s2ccomp install: s2cc # s2ccomp ${INSTALL} -d ${DESTDIR}${BINDIR} ${INSTALL_SCRIPT} s2cc ${DESTDIR}${BINDIR}/ ln -sf s2cc ${DESTDIR}${BINDIR}/scc ${INSTALL} -d ${DESTDIR}${LIBDIR}/${LIBSUBDIR} ${INSTALL_PROGRAM} s2ccomp ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ clean: rm -f ${sco} *.BAK *.CKP scltext.* *.S2C clean-sc-to-c: rm -f ${scc} noprogs: rm -f s2ccomp Xs2ccomp srclinks: s2cc Xs2cc for x in ${scsc} ${scc} ${scsch}; \ do ln -s ${SRCDIR}/$$x $$x;\ done .PHONY: all clean port install sc-to-c srclinks noprogs clean-sc-to-c scheme2c-2012.10.14/scsc/misccode.c000066400000000000000000001643051203736146400164770ustar00rootroot00000000000000 /* SCHEME->C */ #include void misccode__init(); DEFSTATICTSCP( report_2derror_v ); DEFSTATICTSCP( current_2ddefine_2dname_v ); DEFSTATICTSCP( top_2dlevel_2dsymbols_v ); DEFSTATICTSCP( module_2dname_2dupcase_v ); DEFSTATICTSCP( current_2ddefine_2dstring_v ); DEFSTATICTSCP( c3036 ); DEFSTATICTSCP( c3029 ); DEFSTATICTSCP( c3022 ); DEFCSTRING( t3123, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2980 ); DEFSTATICTSCP( c2979 ); DEFSTATICTSCP( c2807 ); DEFSTATICTSCP( c2716 ); DEFSTATICTSCP( c2702 ); DEFSTATICTSCP( c2701 ); DEFSTATICTSCP( c2696 ); DEFSTATICTSCP( c2664 ); DEFSTATICTSCP( c2662 ); DEFSTATICTSCP( c2661 ); DEFSTATICTSCP( c2660 ); DEFSTATICTSCP( t3124 ); DEFSTATICTSCP( c2575 ); DEFSTATICTSCP( c2507 ); DEFSTATICTSCP( c2487 ); DEFSTATICTSCP( c2428 ); DEFSTATICTSCP( c2388 ); DEFSTATICTSCP( t3125 ); DEFSTATICTSCP( t3126 ); DEFSTATICTSCP( c2387 ); DEFSTATICTSCP( t3127 ); DEFSTATICTSCP( t3128 ); DEFSTATICTSCP( c2386 ); DEFSTATICTSCP( t3129 ); DEFSTATICTSCP( c2385 ); DEFSTATICTSCP( t3130 ); DEFSTATICTSCP( c2384 ); DEFSTATICTSCP( t3131 ); DEFSTATICTSCP( t3132 ); DEFSTATICTSCP( c2383 ); DEFSTATICTSCP( t3133 ); DEFSTATICTSCP( c2382 ); DEFSTATICTSCP( t3134 ); DEFSTATICTSCP( c2381 ); DEFSTATICTSCP( t3135 ); DEFSTATICTSCP( c2380 ); DEFSTATICTSCP( t3136 ); DEFSTATICTSCP( t3137 ); DEFSTATICTSCP( c2379 ); DEFSTATICTSCP( c2372 ); DEFSTATICTSCP( c2368 ); DEFSTATICTSCP( c2364 ); DEFSTATICTSCP( c2360 ); DEFSTATICTSCP( c2356 ); DEFSTATICTSCP( c2349 ); DEFSTATICTSCP( c2317 ); DEFSTATICTSCP( c2306 ); DEFSTATICTSCP( c2283 ); DEFSTATICTSCP( c2280 ); DEFSTATICTSCP( c2224 ); DEFCSTRING( t3138, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c2201 ); DEFSTATICTSCP( c2200 ); DEFSTATICTSCP( c2195 ); DEFSTATICTSCP( c2194 ); DEFSTATICTSCP( c2193 ); DEFSTATICTSCP( c2192 ); DEFSTATICTSCP( c2188 ); DEFSTATICTSCP( c2186 ); DEFSTATICTSCP( c2185 ); DEFCSTRING( t3139, "_" ); DEFSTATICTSCP( c2184 ); DEFSTATICTSCP( c2172 ); DEFSTATICTSCP( c2155 ); DEFSTATICTSCP( c2151 ); DEFSTATICTSCP( c2150 ); DEFSTATICTSCP( c2141 ); DEFSTATICTSCP( c2140 ); DEFSTATICTSCP( c2137 ); DEFSTATICTSCP( c2136 ); DEFSTATICTSCP( c2135 ); DEFSTATICTSCP( c2134 ); DEFSTATICTSCP( c2133 ); DEFSTATICTSCP( c2132 ); DEFSTATICTSCP( c2131 ); DEFSTATICTSCP( c2130 ); DEFSTATICTSCP( c2129 ); DEFCSTRING( t3140, "Cannot load value of" ); DEFSTATICTSCP( c2126 ); DEFSTATICTSCP( c2124 ); DEFSTATICTSCP( c2120 ); DEFSTATICTSCP( c2116 ); DEFSTATICTSCP( c2112 ); DEFSTATICTSCP( t3141 ); DEFSTATICTSCP( c2111 ); DEFSTATICTSCP( c2110 ); DEFSTATICTSCP( c2109 ); DEFSTATICTSCP( c2103 ); DEFSTATICTSCP( c2102 ); static void init_constants() { TSCP X1; report_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-ERROR" ) ); CONSTANTEXP( ADR( report_2derror_v ) ); current_2ddefine_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-D\ EFINE-NAME" ) ); CONSTANTEXP( ADR( current_2ddefine_2dname_v ) ); top_2dlevel_2dsymbols_v = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL-S\ YMBOLS" ) ); CONSTANTEXP( ADR( top_2dlevel_2dsymbols_v ) ); module_2dname_2dupcase_v = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE-NAM\ E-UPCASE" ) ); CONSTANTEXP( ADR( module_2dname_2dupcase_v ) ); current_2ddefine_2dstring_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT\ -DEFINE-STRING" ) ); CONSTANTEXP( ADR( current_2ddefine_2dstring_v ) ); c3036 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c3036 ) ); c3029 = STRINGTOSYMBOL( CSTRING_TSCP( "CONSTANT" ) ); CONSTANTEXP( ADR( c3029 ) ); c3022 = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL" ) ); CONSTANTEXP( ADR( c3022 ) ); c2980 = CSTRING_TSCP( t3123 ); CONSTANTEXP( ADR( c2980 ) ); c2979 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2979 ) ); c2807 = STRINGTOSYMBOL( CSTRING_TSCP( "CONDITION-INFO" ) ); CONSTANTEXP( ADR( c2807 ) ); c2716 = EMPTYLIST; c2716 = CONS( EMPTYLIST, c2716 ); CONSTANTEXP( ADR( c2716 ) ); c2702 = STRINGTOSYMBOL( CSTRING_TSCP( "GOTO" ) ); CONSTANTEXP( ADR( c2702 ) ); c2701 = STRINGTOSYMBOL( CSTRING_TSCP( "RETURN" ) ); CONSTANTEXP( ADR( c2701 ) ); c2696 = STRINGTOSYMBOL( CSTRING_TSCP( "LABEL" ) ); CONSTANTEXP( ADR( c2696 ) ); c2664 = STRINGTOSYMBOL( CSTRING_TSCP( "TRUE" ) ); CONSTANTEXP( ADR( c2664 ) ); c2662 = STRINGTOSYMBOL( CSTRING_TSCP( "FALSE" ) ); CONSTANTEXP( ADR( c2662 ) ); c2661 = STRINGTOSYMBOL( CSTRING_TSCP( "IF" ) ); CONSTANTEXP( ADR( c2661 ) ); c2660 = EMPTYLIST; t3124 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-VALUE" ) ); c2660 = CONS( t3124, c2660 ); c2660 = CONS( c2701, c2660 ); CONSTANTEXP( ADR( c2660 ) ); c2575 = STRINGTOSYMBOL( CSTRING_TSCP( "$IF" ) ); CONSTANTEXP( ADR( c2575 ) ); c2507 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAP" ) ); CONSTANTEXP( ADR( c2507 ) ); c2487 = STRINGTOSYMBOL( CSTRING_TSCP( "$CALL" ) ); CONSTANTEXP( ADR( c2487 ) ); c2428 = STRINGTOSYMBOL( CSTRING_TSCP( "SETGENTL" ) ); CONSTANTEXP( ADR( c2428 ) ); c2388 = EMPTYLIST; t3125 = STRINGTOSYMBOL( CSTRING_TSCP( "TOS" ) ); c2388 = CONS( t3125, c2388 ); t3126 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_CHAR" ) ); c2388 = CONS( t3126, c2388 ); CONSTANTEXP( ADR( c2388 ) ); c2387 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3125, X1 ); t3127 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_S2CINT" ) ); X1 = CONS( t3127, X1 ); c2387 = CONS( X1, c2387 ); t3128 = STRINGTOSYMBOL( CSTRING_TSCP( "INT" ) ); c2387 = CONS( t3128, c2387 ); CONSTANTEXP( ADR( c2387 ) ); c2386 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3125, X1 ); X1 = CONS( t3127, X1 ); c2386 = CONS( X1, c2386 ); t3129 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTINT" ) ); c2386 = CONS( t3129, c2386 ); CONSTANTEXP( ADR( c2386 ) ); c2385 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3125, X1 ); X1 = CONS( t3127, X1 ); c2385 = CONS( X1, c2385 ); t3130 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGINT" ) ); c2385 = CONS( t3130, c2385 ); CONSTANTEXP( ADR( c2385 ) ); c2384 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3125, X1 ); t3131 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_S2CUINT" ) ); X1 = CONS( t3131, X1 ); c2384 = CONS( X1, c2384 ); t3132 = STRINGTOSYMBOL( CSTRING_TSCP( "UNSIGNED" ) ); c2384 = CONS( t3132, c2384 ); CONSTANTEXP( ADR( c2384 ) ); c2383 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3125, X1 ); X1 = CONS( t3131, X1 ); c2383 = CONS( X1, c2383 ); t3133 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTUNSIGNED" ) ); c2383 = CONS( t3133, c2383 ); CONSTANTEXP( ADR( c2383 ) ); c2382 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3125, X1 ); X1 = CONS( t3131, X1 ); c2382 = CONS( X1, c2382 ); t3134 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGUNSIGNED" ) ); c2382 = CONS( t3134, c2382 ); CONSTANTEXP( ADR( c2382 ) ); c2381 = EMPTYLIST; c2381 = CONS( t3125, c2381 ); t3135 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_POINTER" ) ); c2381 = CONS( t3135, c2381 ); CONSTANTEXP( ADR( c2381 ) ); c2380 = EMPTYLIST; X1 = EMPTYLIST; X1 = CONS( t3125, X1 ); t3136 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP_DOUBLE" ) ); X1 = CONS( t3136, X1 ); c2380 = CONS( X1, c2380 ); t3137 = STRINGTOSYMBOL( CSTRING_TSCP( "CFLOAT" ) ); c2380 = CONS( t3137, c2380 ); CONSTANTEXP( ADR( c2380 ) ); c2379 = EMPTYLIST; c2379 = CONS( t3125, c2379 ); c2379 = CONS( t3136, c2379 ); CONSTANTEXP( ADR( c2379 ) ); c2372 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGUNSIGNED" ) ); CONSTANTEXP( ADR( c2372 ) ); c2368 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTUNSIGNED" ) ); CONSTANTEXP( ADR( c2368 ) ); c2364 = STRINGTOSYMBOL( CSTRING_TSCP( "UNSIGNED" ) ); CONSTANTEXP( ADR( c2364 ) ); c2360 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGINT" ) ); CONSTANTEXP( ADR( c2360 ) ); c2356 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTINT" ) ); CONSTANTEXP( ADR( c2356 ) ); c2349 = STRINGTOSYMBOL( CSTRING_TSCP( "INT" ) ); CONSTANTEXP( ADR( c2349 ) ); c2317 = STRINGTOSYMBOL( CSTRING_TSCP( "SETGEN" ) ); CONSTANTEXP( ADR( c2317 ) ); c2306 = STRINGTOSYMBOL( CSTRING_TSCP( "$SET" ) ); CONSTANTEXP( ADR( c2306 ) ); c2283 = STRINGTOSYMBOL( CSTRING_TSCP( "CLOSED-PROCEDURE" ) ); CONSTANTEXP( ADR( c2283 ) ); c2280 = STRINGTOSYMBOL( CSTRING_TSCP( "GENERATE" ) ); CONSTANTEXP( ADR( c2280 ) ); c2224 = STRINGTOSYMBOL( CSTRING_TSCP( "$DEFINE" ) ); CONSTANTEXP( ADR( c2224 ) ); c2201 = CSTRING_TSCP( t3138 ); CONSTANTEXP( ADR( c2201 ) ); c2200 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c2200 ) ); c2195 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); CONSTANTEXP( ADR( c2195 ) ); c2194 = STRINGTOSYMBOL( CSTRING_TSCP( "ADR" ) ); CONSTANTEXP( ADR( c2194 ) ); c2193 = STRINGTOSYMBOL( CSTRING_TSCP( "INITIALIZEVAR" ) ); CONSTANTEXP( ADR( c2193 ) ); c2192 = STRINGTOSYMBOL( CSTRING_TSCP( "EXTERNAL" ) ); CONSTANTEXP( ADR( c2192 ) ); c2188 = STRINGTOSYMBOL( CSTRING_TSCP( "TOS" ) ); CONSTANTEXP( ADR( c2188 ) ); c2186 = STRINGTOSYMBOL( CSTRING_TSCP( "CSTRING" ) ); CONSTANTEXP( ADR( c2186 ) ); c2185 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFCSTRING" ) ); CONSTANTEXP( ADR( c2185 ) ); c2184 = CSTRING_TSCP( t3139 ); CONSTANTEXP( ADR( c2184 ) ); c2172 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFTSCP" ) ); CONSTANTEXP( ADR( c2172 ) ); c2155 = STRINGTOSYMBOL( CSTRING_TSCP( "TYPE" ) ); CONSTANTEXP( ADR( c2155 ) ); c2151 = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL" ) ); CONSTANTEXP( ADR( c2151 ) ); c2150 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2150 ) ); c2141 = STRINGTOSYMBOL( CSTRING_TSCP( "POINTER" ) ); CONSTANTEXP( ADR( c2141 ) ); c2140 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2140 ) ); c2137 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR_TSCP" ) ); CONSTANTEXP( ADR( c2137 ) ); c2136 = STRINGTOSYMBOL( CSTRING_TSCP( "_S2CINT" ) ); CONSTANTEXP( ADR( c2136 ) ); c2135 = STRINGTOSYMBOL( CSTRING_TSCP( "S2CINT_TSCP" ) ); CONSTANTEXP( ADR( c2135 ) ); c2134 = STRINGTOSYMBOL( CSTRING_TSCP( "_S2CUINT" ) ); CONSTANTEXP( ADR( c2134 ) ); c2133 = STRINGTOSYMBOL( CSTRING_TSCP( "S2CUINT_TSCP" ) ); CONSTANTEXP( ADR( c2133 ) ); c2132 = STRINGTOSYMBOL( CSTRING_TSCP( "POINTER_TSCP" ) ); CONSTANTEXP( ADR( c2132 ) ); c2131 = STRINGTOSYMBOL( CSTRING_TSCP( "CDOUBLE" ) ); CONSTANTEXP( ADR( c2131 ) ); c2130 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUBLE_TSCP" ) ); CONSTANTEXP( ADR( c2130 ) ); c2129 = STRINGTOSYMBOL( CSTRING_TSCP( "PRINTNAME" ) ); CONSTANTEXP( ADR( c2129 ) ); c2126 = CSTRING_TSCP( t3140 ); CONSTANTEXP( ADR( c2126 ) ); c2124 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUBLE" ) ); CONSTANTEXP( ADR( c2124 ) ); c2120 = STRINGTOSYMBOL( CSTRING_TSCP( "FLOAT" ) ); CONSTANTEXP( ADR( c2120 ) ); c2116 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP" ) ); CONSTANTEXP( ADR( c2116 ) ); c2112 = EMPTYLIST; t3141 = STRINGTOSYMBOL( CSTRING_TSCP( "ARRAY" ) ); c2112 = CONS( t3141, c2112 ); c2112 = CONS( c2141, c2112 ); CONSTANTEXP( ADR( c2112 ) ); c2111 = EMPTYLIST; c2111 = CONS( c2372, c2111 ); c2111 = CONS( c2368, c2111 ); c2111 = CONS( c2364, c2111 ); CONSTANTEXP( ADR( c2111 ) ); c2110 = EMPTYLIST; c2110 = CONS( c2360, c2110 ); c2110 = CONS( c2356, c2110 ); c2110 = CONS( c2349, c2110 ); CONSTANTEXP( ADR( c2110 ) ); c2109 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR" ) ); CONSTANTEXP( ADR( c2109 ) ); c2103 = STRINGTOSYMBOL( CSTRING_TSCP( "SET" ) ); CONSTANTEXP( ADR( c2103 ) ); c2102 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-VALUE" ) ); CONSTANTEXP( ADR( c2102 ) ); } DEFTSCP( misccode_symbol_2dgenc_v ); DEFCSTRING( t3142, "SYMBOL-GENC" ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); EXTERNTSCPP( gencode_lookup, XAL2( TSCP, TSCP ) ); EXTERNTSCP( gencode_lookup_v ); EXTERNTSCPP( lap_emit_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_emit_2dlap_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt1_memv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memv_v ); EXTERNTSCPP( expform_vname, XAL1( TSCP ) ); EXTERNTSCP( expform_vname_v ); TSCP misccode_symbol_2dgenc( l2093, e2094, b2095 ) TSCP l2093, e2094, b2095; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3142 ); X2 = plist_get( e2094, c2150 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2151 ) ) ) goto L3144; X1 = plist_get( e2094, c2155 ); goto L3145; L3144: X1 = FALSEVALUE; L3145: X2 = gencode_lookup( e2094, b2095 ); if ( EQ( _S2CUINT( l2093 ), _S2CUINT( c2102 ) ) ) goto L3147; if ( FALSE( X1 ) ) goto L3149; X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( FALSE( plist_get( e2094, c2140 ) ) ) goto L3151; X5 = c2141; goto L3152; L3151: X5 = X1; L3152: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2109 ) ) ) goto L3154; X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2137, CONS( X2, X7 ) ); goto L3167; L3154: if ( FALSE( scrt1_memv( X5, c2110 ) ) ) goto L3156; X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2135, CONS( scrt1_cons_2a( c2136, CONS( X2, X8 ) ), X7 ) ); goto L3167; L3156: if ( FALSE( scrt1_memv( X5, c2111 ) ) ) goto L3158; X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2133, CONS( scrt1_cons_2a( c2134, CONS( X2, X8 ) ), X7 ) ); goto L3167; L3158: if ( FALSE( scrt1_memv( X5, c2112 ) ) ) goto L3160; X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2132, CONS( X2, X7 ) ); goto L3167; L3160: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2116 ) ) ) goto L3162; X6 = X2; goto L3167; L3162: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2120 ) ) ) goto L3164; X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2130, CONS( scrt1_cons_2a( c2131, CONS( X2, X8 ) ), X7 ) ); goto L3167; L3164: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2124 ) ) ) goto L3166; X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = scrt1_cons_2a( c2130, CONS( X2, X7 ) ); goto L3167; L3166: X8 = plist_get( e2094, c2129 ); X7 = SYMBOL_VALUE( report_2derror_v ); X7 = UNKNOWNCALL( X7, 2 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( c2126, X8, PROCEDURE_CLOSURE( X7 ) ); L3167: X4 = CONS( X6, X4 ); X3 = scrt1_cons_2a( c2103, CONS( expform_vname( l2093 ), X4 ) ); POPSTACKTRACE( lap_emit_2dlap( X3 ) ); L3149: X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( X2, X4 ); X3 = scrt1_cons_2a( c2103, CONS( expform_vname( l2093 ), X4 ) ); POPSTACKTRACE( lap_emit_2dlap( X3 ) ); L3147: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( misccode__24define_2dgenc_v ); DEFCSTRING( t3168, "$DEFINE-GENC" ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( gencode_make_2dc_2dglobal, XAL0( ) ); EXTERNTSCP( gencode_make_2dc_2dglobal_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( lap_emit_2dglobal_2dlap, XAL1( TSCP ) ); EXTERNTSCP( lap_emit_2dglobal_2dlap_v ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( gencode_exp_2dgenc, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( gencode_exp_2dgenc_v ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); TSCP misccode__24define_2dgenc( l2158, e2159, b2160 ) TSCP l2158, e2159, b2160; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3168 ); if ( NEQ( TSCPTAG( e2159 ), PAIRTAG ) ) goto L3170; X3 = PAIR_CAR( e2159 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2224 ) ) ); goto L3171; L3170: X2 = FALSEVALUE; L3171: if ( FALSE( X2 ) ) goto L3174; if ( EQ( TSCPTAG( e2159 ), PAIRTAG ) ) goto L3177; scrt1__24__cdr_2derror( e2159 ); L3177: X3 = PAIR_CDR( e2159 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3180; scrt1__24__car_2derror( X3 ); L3180: X1 = PAIR_CAR( X3 ); goto L3175; L3174: X1 = X2; L3175: if ( NEQ( TSCPTAG( e2159 ), PAIRTAG ) ) goto L3183; X4 = PAIR_CAR( e2159 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2224 ) ) ); goto L3184; L3183: X3 = FALSEVALUE; L3184: if ( FALSE( X3 ) ) goto L3187; X2 = scrt1_caddr( e2159 ); goto L3188; L3187: X2 = X3; L3188: X3 = gencode_make_2dc_2dglobal( ); X5 = plist_get( X1, c2129 ); if ( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), SYMBOLTAG ) ) ) goto L3192; scdebug_error( c2200, c2201, CONS( X5, EMPTYLIST ) ); L3192: X4 = SYMBOL_NAME( X5 ); X4 = CONS( X4, EMPTYLIST ); SETGENTL( SYMBOL_VALUE( current_2ddefine_2dname_v ), plist_get( X1, c2129 ) ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X5 = scrt1_cons_2a( c2172, CONS( expform_vname( X1 ), X6 ) ); lap_emit_2dglobal_2dlap( X5 ); X5 = SYMBOL_VALUE( top_2dlevel_2dsymbols_v ); if ( EQ( _S2CUINT( X5 ), _S2CUINT( TRUEVALUE ) ) ) goto L3197; X5 = plist_get( X1, c2129 ); X6 = SYMBOL_VALUE( top_2dlevel_2dsymbols_v ); if ( TRUE( scrt1_memq( X5, X6 ) ) ) goto L3197; X6 = CONS( PAIR_CAR( X4 ), EMPTYLIST ); X6 = CONS( c2184, X6 ); X5 = scrt3_string_2dappend( CONS( SYMBOL_VALUE( module_2dname_2dupcase_v ), X6 ) ); SETGEN( PAIR_CAR( X4 ), X5 ); L3197: X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_cons_2a( c2186, CONS( PAIR_CAR( X4 ), X7 ) ), X6 ); X5 = scrt1_cons_2a( c2185, CONS( expform_vname( X3 ), X6 ) ); lap_emit_2dglobal_2dlap( X5 ); SETGENTL( SYMBOL_VALUE( current_2ddefine_2dstring_v ), X3 ); gencode_exp_2dgenc( c2188, X2, b2160 ); plist_put( X1, c2192, TRUEVALUE ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( c2188, X6 ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( scrt1_cons_2a( c2194, CONS( expform_vname( X1 ), X7 ) ), X6 ); X5 = scrt1_cons_2a( c2193, CONS( expform_vname( X3 ), X6 ) ); lap_emit_2dlap( X5 ); POPSTACKTRACE( SETGENTL( SYMBOL_VALUE( current_2ddefine_2dname_v ), c2195 ) ); } DEFTSCP( misccode__24set_2dgenc_v ); DEFCSTRING( t3199, "$SET-GENC" ); EXTERNTSCPP( gencode_var_2din_2dstack, XAL1( TSCP ) ); EXTERNTSCP( gencode_var_2din_2dstack_v ); EXTERNTSCPP( gencode_op_2dlevel_343ff0cb, XAL1( TSCP ) ); EXTERNTSCP( gencode_op_2dlevel_343ff0cb_v ); EXTERNTSCPP( lap_use_2dlap_2dtemp, XAL0( ) ); EXTERNTSCP( lap_use_2dlap_2dtemp_v ); EXTERNTSCPP( lap_drop_2dlap_2dtemp, XAL1( TSCP ) ); EXTERNTSCP( lap_drop_2dlap_2dtemp_v ); TSCP misccode__24set_2dgenc( l2260, e2261, b2262 ) TSCP l2260, e2261, b2262; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3199 ); if ( NEQ( TSCPTAG( e2261 ), PAIRTAG ) ) goto L3201; X5 = PAIR_CAR( e2261 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2306 ) ) ); goto L3202; L3201: X4 = FALSEVALUE; L3202: if ( FALSE( X4 ) ) goto L3205; if ( EQ( TSCPTAG( e2261 ), PAIRTAG ) ) goto L3208; scrt1__24__cdr_2derror( e2261 ); L3208: X5 = PAIR_CDR( e2261 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3211; scrt1__24__car_2derror( X5 ); L3211: X2 = PAIR_CAR( X5 ); goto L3206; L3205: X2 = X4; L3206: if ( FALSE( gencode_var_2din_2dstack( X2 ) ) ) goto L3214; X1 = c2317; goto L3217; L3214: if ( FALSE( gencode_op_2dlevel_343ff0cb( X2 ) ) ) goto L3216; X1 = c2428; goto L3217; L3216: X1 = c2103; L3217: X4 = plist_get( X2, c2150 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2151 ) ) ) goto L3219; X3 = plist_get( X2, c2155 ); goto L3220; L3219: X3 = FALSEVALUE; L3220: X4 = plist_get( X2, c2140 ); if ( FALSE( X4 ) ) goto L3234; X6 = plist_get( X2, c2140 ); X5 = plist_get( X6, c2280 ); if ( EQ( _S2CUINT( X5 ), _S2CUINT( c2283 ) ) ) goto L3234; if ( NEQ( TSCPTAG( e2261 ), PAIRTAG ) ) goto L3228; X7 = PAIR_CAR( e2261 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2306 ) ) ); goto L3229; L3228: X6 = FALSEVALUE; L3229: if ( FALSE( X6 ) ) goto L3232; X5 = scrt1_caddr( e2261 ); goto L3233; L3232: X5 = X6; L3233: POPSTACKTRACE( gencode_exp_2dgenc( c2102, X5, b2262 ) ); L3234: if ( FALSE( X3 ) ) goto L3235; if ( NEQ( _S2CUINT( l2260 ), _S2CUINT( c2102 ) ) ) goto L3237; X4 = c2188; goto L3238; L3237: X4 = lap_use_2dlap_2dtemp( ); L3238: if ( NEQ( TSCPTAG( e2261 ), PAIRTAG ) ) goto L3240; X7 = PAIR_CAR( e2261 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2306 ) ) ); goto L3241; L3240: X6 = FALSEVALUE; L3241: if ( FALSE( X6 ) ) goto L3244; X5 = scrt1_caddr( e2261 ); goto L3245; L3244: X5 = X6; L3245: gencode_exp_2dgenc( X4, X5, b2262 ); X6 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( expform_vname( X4 ), X6 ); X5 = scrt1_cons_2a( c2103, CONS( c2188, X6 ) ); lap_emit_2dlap( X5 ); X6 = CONS( EMPTYLIST, EMPTYLIST ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2109 ) ) ) goto L3246; X7 = c2388; goto L3267; L3246: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2349 ) ) ) goto L3248; X7 = c2387; goto L3267; L3248: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2116 ) ) ) goto L3250; X7 = c2188; goto L3267; L3250: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2356 ) ) ) goto L3252; X7 = c2386; goto L3267; L3252: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2360 ) ) ) goto L3254; X7 = c2385; goto L3267; L3254: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2364 ) ) ) goto L3256; X7 = c2384; goto L3267; L3256: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2368 ) ) ) goto L3258; X7 = c2383; goto L3267; L3258: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2372 ) ) ) goto L3260; X7 = c2382; goto L3267; L3260: if ( FALSE( scrt1_memv( X3, c2112 ) ) ) goto L3262; X7 = c2381; goto L3267; L3262: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2120 ) ) ) goto L3264; X7 = c2380; goto L3267; L3264: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2124 ) ) ) goto L3266; X7 = c2379; goto L3267; L3266: X7 = FALSEVALUE; L3267: X6 = CONS( X7, X6 ); X5 = scrt1_cons_2a( c2103, CONS( gencode_lookup( X2, b2262 ), X6 ) ); lap_emit_2dlap( X5 ); if ( EQ( _S2CUINT( X4 ), _S2CUINT( c2188 ) ) ) goto L3268; X6 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( expform_vname( X4 ), X6 ); X5 = scrt1_cons_2a( c2103, CONS( expform_vname( l2260 ), X6 ) ); lap_emit_2dlap( X5 ); POPSTACKTRACE( lap_drop_2dlap_2dtemp( X4 ) ); L3268: POPSTACKTRACE( FALSEVALUE ); L3235: if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2317 ) ) ) goto L3271; X4 = lap_use_2dlap_2dtemp( ); goto L3272; L3271: X4 = c2188; L3272: if ( NEQ( TSCPTAG( e2261 ), PAIRTAG ) ) goto L3274; X7 = PAIR_CAR( e2261 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2306 ) ) ); goto L3275; L3274: X6 = FALSEVALUE; L3275: if ( FALSE( X6 ) ) goto L3278; X5 = scrt1_caddr( e2261 ); goto L3279; L3278: X5 = X6; L3279: gencode_exp_2dgenc( X4, X5, b2262 ); if ( NEQ( _S2CUINT( l2260 ), _S2CUINT( c2102 ) ) ) goto L3280; X6 = CONS( EMPTYLIST, EMPTYLIST ); X6 = CONS( X4, X6 ); X5 = scrt1_cons_2a( X1, CONS( gencode_lookup( X2, b2262 ), X6 ) ); lap_emit_2dlap( X5 ); goto L3281; L3280: X6 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( EMPTYLIST, EMPTYLIST ); X7 = CONS( X4, X7 ); X6 = CONS( scrt1_cons_2a( X1, CONS( gencode_lookup( X2, b2262 ), X7 ) ), X6 ); X5 = scrt1_cons_2a( c2103, CONS( expform_vname( l2260 ), X6 ) ); lap_emit_2dlap( X5 ); L3281: if ( EQ( _S2CUINT( X4 ), _S2CUINT( c2188 ) ) ) goto L3282; POPSTACKTRACE( lap_drop_2dlap_2dtemp( X4 ) ); L3282: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( misccode__24if_2dgenc_v ); DEFCSTRING( t3284, "$IF-GENC" ); EXTERNTSCPP( scrt1_cadddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadddr_v ); EXTERNTSCPP( misccode_args_2dset_21_3f, XAL1( TSCP ) ); EXTERNTSCP( misccode_args_2dset_21_3f_v ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); EXTERNTSCPP( misccode_dbefore_3f_136acdb0, XAL1( TSCP ) ); EXTERNTSCP( misccode_dbefore_3f_136acdb0_v ); EXTERNTSCPP( misccode_dbefore_3f_d2e61671, XAL1( TSCP ) ); EXTERNTSCP( misccode_dbefore_3f_d2e61671_v ); EXTERNTSCPP( misccode_2doptimize_474b940d, XAL4( TSCP, TSCP, TSCP, TSCP ) ); EXTERNTSCP( misccode_2doptimize_474b940d_v ); TSCP misccode__24if_2dgenc( l2462, e2463, b2464 ) TSCP l2462, e2463, b2464; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3284 ); if ( NEQ( TSCPTAG( e2463 ), PAIRTAG ) ) goto L3286; X3 = PAIR_CAR( e2463 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2575 ) ) ); goto L3287; L3286: X2 = FALSEVALUE; L3287: if ( FALSE( X2 ) ) goto L3290; X1 = scrt1_cadddr( e2463 ); goto L3291; L3290: X1 = X2; L3291: if ( NEQ( TSCPTAG( e2463 ), PAIRTAG ) ) goto L3292; X4 = PAIR_CAR( e2463 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2575 ) ) ); goto L3293; L3292: X3 = FALSEVALUE; L3293: if ( FALSE( X3 ) ) goto L3296; X2 = scrt1_caddr( e2463 ); goto L3297; L3296: X2 = X3; L3297: if ( NEQ( TSCPTAG( e2463 ), PAIRTAG ) ) goto L3298; X5 = PAIR_CAR( e2463 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2575 ) ) ); goto L3299; L3298: X4 = FALSEVALUE; L3299: if ( FALSE( X4 ) ) goto L3302; if ( EQ( TSCPTAG( e2463 ), PAIRTAG ) ) goto L3305; scrt1__24__cdr_2derror( e2463 ); L3305: X5 = PAIR_CDR( e2463 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3308; scrt1__24__car_2derror( X5 ); L3308: X3 = PAIR_CAR( X5 ); goto L3303; L3302: X3 = X4; L3303: if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3311; X5 = PAIR_CAR( X3 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2487 ) ) ); goto L3312; L3311: X4 = FALSEVALUE; L3312: if ( FALSE( X4 ) ) goto L3345; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3318; X8 = PAIR_CAR( X3 ); X7 = BOOLEAN( EQ( _S2CUINT( X8 ), _S2CUINT( c2487 ) ) ); goto L3319; L3318: X7 = FALSEVALUE; L3319: if ( FALSE( X7 ) ) goto L3322; X6 = scrt1_caddr( X3 ); goto L3323; L3322: X6 = X7; L3323: if ( NEQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3325; X7 = PAIR_CAR( X6 ); X5 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2507 ) ) ); goto L3326; L3325: X5 = FALSEVALUE; L3326: if ( FALSE( X5 ) ) goto L3345; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3334; X8 = PAIR_CAR( X3 ); X7 = BOOLEAN( EQ( _S2CUINT( X8 ), _S2CUINT( c2487 ) ) ); goto L3335; L3334: X7 = FALSEVALUE; L3335: if ( FALSE( X7 ) ) goto L3338; X6 = scrt1_cdddr( X3 ); goto L3339; L3338: X6 = X7; L3339: if ( TRUE( misccode_args_2dset_21_3f( X6 ) ) ) goto L3345; if ( FALSE( misccode_dbefore_3f_136acdb0( X3 ) ) ) goto L3341; POPSTACKTRACE( gencode_exp_2dgenc( l2462, X2, b2464 ) ); L3341: if ( FALSE( misccode_dbefore_3f_d2e61671( X3 ) ) ) goto L3343; POPSTACKTRACE( gencode_exp_2dgenc( l2462, X1, b2464 ) ); L3343: POPSTACKTRACE( misccode_2doptimize_474b940d( l2462, e2463, b2464, X3 ) ); L3345: POPSTACKTRACE( misccode_2doptimize_474b940d( l2462, e2463, b2464, FALSEVALUE ) ); } DEFTSCP( misccode_2doptimize_474b940d_v ); DEFCSTRING( t3346, "$IF-GENC-NO-OPTIMIZE" ); EXTERNTSCPP( gencode_make_2dlabel, XAL0( ) ); EXTERNTSCP( gencode_make_2dlabel_v ); EXTERNTSCP( gencode_ion_2dinfo_f92fd619_v ); EXTERNTSCPP( misccode_add_2dcondition, XAL2( TSCP, TSCP ) ); EXTERNTSCP( misccode_add_2dcondition_v ); EXTERNTSCPP( misccode_dreturn_3f_ca61fd98, XAL1( TSCP ) ); EXTERNTSCP( misccode_dreturn_3f_ca61fd98_v ); EXTERNTSCPP( misccode_ion_2dinfo_fbff5bfd, XAL2( TSCP, TSCP ) ); EXTERNTSCP( misccode_ion_2dinfo_fbff5bfd_v ); EXTERNTSCPP( misccode_intersect2, XAL2( TSCP, TSCP ) ); EXTERNTSCP( misccode_intersect2_v ); TSCP misccode_2doptimize_474b940d( l2630, e2631, b2632, a2633 ) TSCP l2630, e2631, b2632, a2633; { TSCP X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3346 ); X1 = gencode_make_2dlabel( ); X2 = gencode_make_2dlabel( ); if ( NEQ( TSCPTAG( e2631 ), PAIRTAG ) ) goto L3350; X5 = PAIR_CAR( e2631 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2575 ) ) ); goto L3351; L3350: X4 = FALSEVALUE; L3351: if ( FALSE( X4 ) ) goto L3354; if ( EQ( TSCPTAG( e2631 ), PAIRTAG ) ) goto L3357; scrt1__24__cdr_2derror( e2631 ); L3357: X5 = PAIR_CDR( e2631 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3360; scrt1__24__car_2derror( X5 ); L3360: X3 = PAIR_CAR( X5 ); goto L3355; L3354: X3 = X4; L3355: if ( NEQ( TSCPTAG( e2631 ), PAIRTAG ) ) goto L3363; X6 = PAIR_CAR( e2631 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2575 ) ) ); goto L3364; L3363: X5 = FALSEVALUE; L3364: if ( FALSE( X5 ) ) goto L3367; X4 = scrt1_caddr( e2631 ); goto L3368; L3367: X4 = X5; L3368: X4 = CONS( X4, EMPTYLIST ); if ( NEQ( TSCPTAG( e2631 ), PAIRTAG ) ) goto L3370; X7 = PAIR_CAR( e2631 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2575 ) ) ); goto L3371; L3370: X6 = FALSEVALUE; L3371: if ( FALSE( X6 ) ) goto L3374; X5 = scrt1_cadddr( e2631 ); goto L3375; L3374: X5 = X6; L3375: X5 = CONS( X5, EMPTYLIST ); X6 = FALSEVALUE; X6 = CONS( X6, EMPTYLIST ); X7 = c2716; X7 = CONS( X7, EMPTYLIST ); X8 = c2716; X8 = CONS( X8, EMPTYLIST ); X9 = gencode_ion_2dinfo_f92fd619_v; if ( NEQ( _S2CUINT( l2630 ), _S2CUINT( c2188 ) ) ) goto L3381; X10 = lap_use_2dlap_2dtemp( ); goto L3382; L3381: X10 = l2630; L3382: gencode_exp_2dgenc( c2188, X3, b2632 ); X11 = BOOLEAN( AND( EQ( TSCPTAG( PAIR_CAR( X4 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( X4 ) ), SYMBOLTAG ) ) ); if ( FALSE( X11 ) ) goto L3397; if ( FALSE( scrt1_memq( l2630, c2660 ) ) ) goto L3397; X13 = CONS( EMPTYLIST, EMPTYLIST ); X13 = CONS( X1, X13 ); X14 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( c2661, CONS( scrt1_cons_2a( c2664, CONS( c2188, X14 ) ), X13 ) ); lap_emit_2dlap( X12 ); X12 = PAIR_CAR( X4 ); SETGEN( PAIR_CAR( X5 ), X12 ); if ( NEQ( TSCPTAG( e2631 ), PAIRTAG ) ) goto L3391; X14 = PAIR_CAR( e2631 ); X13 = BOOLEAN( EQ( _S2CUINT( X14 ), _S2CUINT( c2575 ) ) ); goto L3392; L3391: X13 = FALSEVALUE; L3392: if ( FALSE( X13 ) ) goto L3395; X12 = scrt1_cadddr( e2631 ); goto L3396; L3395: X12 = X13; L3396: SETGEN( PAIR_CAR( X4 ), X12 ); X12 = TRUEVALUE; SETGEN( PAIR_CAR( X6 ), X12 ); goto L3398; L3397: X13 = CONS( EMPTYLIST, EMPTYLIST ); X13 = CONS( X1, X13 ); X14 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( c2661, CONS( scrt1_cons_2a( c2662, CONS( c2188, X14 ) ), X13 ) ); lap_emit_2dlap( X12 ); L3398: if ( FALSE( a2633 ) ) goto L3399; if ( FALSE( PAIR_CAR( X6 ) ) ) goto L3401; X11 = FALSEVALUE; goto L3402; L3401: X11 = TRUEVALUE; L3402: misccode_add_2dcondition( a2633, X11 ); L3399: gencode_exp_2dgenc( X10, PAIR_CAR( X4 ), b2632 ); X11 = gencode_ion_2dinfo_f92fd619_v; SETGEN( PAIR_CAR( X7 ), X11 ); gencode_ion_2dinfo_f92fd619_v = X9; if ( FALSE( a2633 ) ) goto L3403; misccode_add_2dcondition( a2633, PAIR_CAR( X6 ) ); L3403: X11 = BOOLEAN( NEQ( _S2CUINT( l2630 ), _S2CUINT( c2102 ) ) ); if ( TRUE( X11 ) ) goto L3409; if ( NOT( AND( EQ( TSCPTAG( PAIR_CAR( X5 ) ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( PAIR_CAR( X5 ) ), SYMBOLTAG ) ) ) ) goto L3409; X13 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( c2696, CONS( X1, X13 ) ); lap_emit_2dlap( X12 ); goto L3416; L3409: if ( EQ( _S2CUINT( l2630 ), _S2CUINT( c2701 ) ) ) goto L3414; X13 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( c2702, CONS( X2, X13 ) ); lap_emit_2dlap( X12 ); L3414: X13 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( c2696, CONS( X1, X13 ) ); lap_emit_2dlap( X12 ); gencode_exp_2dgenc( X10, PAIR_CAR( X5 ), b2632 ); if ( EQ( _S2CUINT( l2630 ), _S2CUINT( c2701 ) ) ) goto L3416; X13 = CONS( EMPTYLIST, EMPTYLIST ); X12 = scrt1_cons_2a( c2696, CONS( X2, X13 ) ); lap_emit_2dlap( X12 ); L3416: if ( NEQ( _S2CUINT( l2630 ), _S2CUINT( c2188 ) ) ) goto L3418; X12 = CONS( EMPTYLIST, EMPTYLIST ); X12 = CONS( expform_vname( X10 ), X12 ); X11 = scrt1_cons_2a( c2103, CONS( c2188, X12 ) ); lap_emit_2dlap( X11 ); lap_drop_2dlap_2dtemp( X10 ); L3418: X11 = gencode_ion_2dinfo_f92fd619_v; SETGEN( PAIR_CAR( X8 ), X11 ); gencode_ion_2dinfo_f92fd619_v = X9; if ( FALSE( misccode_dreturn_3f_ca61fd98( PAIR_CAR( X4 ) ) ) ) goto L3421; POPSTACKTRACE( misccode_ion_2dinfo_fbff5bfd( PAIR_CAR( X8 ), EMPTYLIST ) ); L3421: if ( FALSE( misccode_dreturn_3f_ca61fd98( PAIR_CAR( X5 ) ) ) ) goto L3423; POPSTACKTRACE( misccode_ion_2dinfo_fbff5bfd( PAIR_CAR( X7 ), EMPTYLIST ) ); L3423: X11 = misccode_intersect2( PAIR_CAR( X7 ), PAIR_CAR( X8 ) ); POPSTACKTRACE( misccode_ion_2dinfo_fbff5bfd( X11, EMPTYLIST ) ); } DEFTSCP( misccode_rue_2dlist_71bcc9dd_v ); DEFCSTRING( t3425, "CONDITION-INFO-TRUE-LIST" ); TSCP misccode_rue_2dlist_71bcc9dd( x2792 ) TSCP x2792; { PUSHSTACKTRACE( t3425 ); if ( EQ( TSCPTAG( x2792 ), PAIRTAG ) ) goto L3428; scrt1__24__car_2derror( x2792 ); L3428: POPSTACKTRACE( PAIR_CAR( x2792 ) ); } DEFTSCP( misccode_lse_2dlist_1c8651d_v ); DEFCSTRING( t3430, "CONDITION-INFO-FALSE-LIST" ); TSCP misccode_lse_2dlist_1c8651d( x2799 ) TSCP x2799; { PUSHSTACKTRACE( t3430 ); if ( EQ( TSCPTAG( x2799 ), PAIRTAG ) ) goto L3433; scrt1__24__cdr_2derror( x2799 ); L3433: POPSTACKTRACE( PAIR_CDR( x2799 ) ); } DEFTSCP( misccode_ion_2dinfo_37ee0438_v ); DEFCSTRING( t3435, "STORE-CONDITION-INFO" ); TSCP misccode_ion_2dinfo_37ee0438( i2806 ) TSCP i2806; { PUSHSTACKTRACE( t3435 ); POPSTACKTRACE( plist_put( i2806, c2807, gencode_ion_2dinfo_f92fd619_v ) ); } DEFTSCP( misccode_ion_2dinfo_659a45e5_v ); DEFCSTRING( t3437, "RETRIEVE-CONDITION-INFO" ); EXTERNTSCP( gencode_ion_2dinfo_cc47b64b_v ); TSCP misccode_ion_2dinfo_659a45e5( i2810 ) TSCP i2810; { TSCP X1; PUSHSTACKTRACE( t3437 ); X1 = plist_get( i2810, c2807 ); if ( TRUE( X1 ) ) goto L3440; POPSTACKTRACE( gencode_ion_2dinfo_cc47b64b_v ); L3440: POPSTACKTRACE( X1 ); } DEFTSCP( misccode_ion_2dinfo_2b7559ad_v ); DEFCSTRING( t3442, "UPDATE-CONDITION-INFO" ); TSCP misccode_ion_2dinfo_2b7559ad( i2815 ) TSCP i2815; { TSCP X2, X1; PUSHSTACKTRACE( t3442 ); X1 = plist_get( i2815, c2807 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3445; POPSTACKTRACE( plist_put( i2815, c2807, gencode_ion_2dinfo_f92fd619_v ) ); L3445: X2 = misccode_intersect2( X1, gencode_ion_2dinfo_f92fd619_v ); POPSTACKTRACE( plist_put( i2815, c2807, X2 ) ); } DEFTSCP( misccode_ion_2dinfo_fbff5bfd_v ); DEFCSTRING( t3447, "COMBINE-WITH-GLOBAL-CONDITION-INFO" ); EXTERNTSCPP( misccode_combine2, XAL2( TSCP, TSCP ) ); EXTERNTSCP( misccode_combine2_v ); TSCP misccode_ion_2dinfo_fbff5bfd( i2824, i2825 ) TSCP i2824, i2825; { TSCP X2, X1; PUSHSTACKTRACE( t3447 ); L3448: if ( NEQ( _S2CUINT( i2825 ), _S2CUINT( EMPTYLIST ) ) ) goto L3449; POPSTACKTRACE( SET( gencode_ion_2dinfo_f92fd619_v, misccode_combine2( i2824, gencode_ion_2dinfo_f92fd619_v ) ) ); L3449: if ( EQ( TSCPTAG( i2825 ), PAIRTAG ) ) goto L3452; scrt1__24__car_2derror( i2825 ); L3452: X2 = PAIR_CAR( i2825 ); X1 = misccode_combine2( i2824, X2 ); i2825 = CONS( PAIR_CDR( i2825 ), EMPTYLIST ); i2824 = X1; GOBACK( L3448 ); } DEFTSCP( misccode_combine2_v ); DEFCSTRING( t3455, "COMBINE2" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( misccode_list_2dcombination, XAL2( TSCP, TSCP ) ); EXTERNTSCP( misccode_list_2dcombination_v ); TSCP misccode_combine2( i2841, i2842 ) TSCP i2841, i2842; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3455 ); X2 = misccode_rue_2dlist_71bcc9dd( i2841 ); X3 = misccode_rue_2dlist_71bcc9dd( i2842 ); X1 = misccode_list_2dcombination( X2, X3 ); X3 = misccode_lse_2dlist_1c8651d( i2841 ); X4 = misccode_lse_2dlist_1c8651d( i2842 ); X2 = misccode_list_2dcombination( X3, X4 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); } DEFTSCP( misccode_list_2dcombination_v ); DEFCSTRING( t3457, "LIST-COMBINATION" ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_remove, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_remove_v ); TSCP misccode_list_2dcombination( l2845, l2846 ) TSCP l2845, l2846; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3457 ); L3458: if ( EQ( _S2CUINT( l2846 ), _S2CUINT( EMPTYLIST ) ) ) goto L3459; if ( EQ( TSCPTAG( l2846 ), PAIRTAG ) ) goto L3462; scrt1__24__car_2derror( l2846 ); L3462: X3 = PAIR_CAR( l2846 ); X2 = scrt1_cons_2a( X3, CONS( EMPTYLIST, EMPTYLIST ) ); X4 = PAIR_CAR( l2846 ); X3 = scrt1_remove( X4, l2845 ); X1 = scrt1_append_2dtwo( X2, X3 ); l2846 = PAIR_CDR( l2846 ); l2845 = X1; GOBACK( L3458 ); L3459: POPSTACKTRACE( l2845 ); } DEFTSCP( misccode_ion_2dinfo_bd1601d7_v ); DEFCSTRING( t3466, "INTERSECT-WITH-GLOBAL-CONDITION-INFO" ); TSCP misccode_ion_2dinfo_bd1601d7( i2866, i2867 ) TSCP i2866, i2867; { TSCP X2, X1; PUSHSTACKTRACE( t3466 ); L3467: if ( NEQ( _S2CUINT( i2867 ), _S2CUINT( EMPTYLIST ) ) ) goto L3468; POPSTACKTRACE( SET( gencode_ion_2dinfo_f92fd619_v, misccode_intersect2( i2866, gencode_ion_2dinfo_f92fd619_v ) ) ); L3468: if ( EQ( TSCPTAG( i2867 ), PAIRTAG ) ) goto L3471; scrt1__24__car_2derror( i2867 ); L3471: X2 = PAIR_CAR( i2867 ); X1 = misccode_intersect2( i2866, X2 ); i2867 = CONS( PAIR_CDR( i2867 ), EMPTYLIST ); i2866 = X1; GOBACK( L3467 ); } DEFTSCP( misccode_intersect2_v ); DEFCSTRING( t3474, "INTERSECT2" ); EXTERNTSCPP( misccode_list_2dintersection, XAL2( TSCP, TSCP ) ); EXTERNTSCP( misccode_list_2dintersection_v ); TSCP misccode_intersect2( i2882, i2883 ) TSCP i2882, i2883; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3474 ); X2 = misccode_rue_2dlist_71bcc9dd( i2882 ); X3 = misccode_rue_2dlist_71bcc9dd( i2883 ); X1 = misccode_list_2dintersection( X2, X3 ); X3 = misccode_lse_2dlist_1c8651d( i2882 ); X4 = misccode_lse_2dlist_1c8651d( i2883 ); X2 = misccode_list_2dintersection( X3, X4 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); } DEFTSCP( misccode_list_2dintersection_v ); DEFCSTRING( t3476, "LIST-INTERSECTION" ); EXTERNTSCPP( scrt1_member, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_member_v ); TSCP misccode_list_2dintersection( l2886, l2887 ) TSCP l2886, l2887; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3476 ); L3477: if ( EQ( _S2CUINT( l2886 ), _S2CUINT( EMPTYLIST ) ) ) goto L3478; if ( EQ( TSCPTAG( l2886 ), PAIRTAG ) ) goto L3483; scrt1__24__car_2derror( l2886 ); L3483: X1 = PAIR_CAR( l2886 ); if ( FALSE( scrt1_member( X1, l2887 ) ) ) goto L3480; X2 = PAIR_CAR( l2886 ); X1 = scrt1_cons_2a( X2, CONS( EMPTYLIST, EMPTYLIST ) ); X3 = PAIR_CDR( l2886 ); X2 = misccode_list_2dintersection( X3, l2887 ); POPSTACKTRACE( scrt1_append_2dtwo( X1, X2 ) ); L3480: if ( EQ( TSCPTAG( l2886 ), PAIRTAG ) ) goto L3488; scrt1__24__cdr_2derror( l2886 ); L3488: X1 = PAIR_CDR( l2886 ); l2886 = X1; GOBACK( L3477 ); L3478: POPSTACKTRACE( EMPTYLIST ); } DEFTSCP( misccode_tersection_bbeb56bc_v ); DEFCSTRING( t3490, "STORED-CONDITIONS-INTERSECTION" ); TSCP misccode_tersection_bbeb56bc( l2911 ) TSCP l2911; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3490 ); X3 = l2911; X4 = EMPTYLIST; X5 = EMPTYLIST; L3494: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3495; X2 = X4; goto L3502; L3495: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3498; scrt1__24__car_2derror( X3 ); L3498: X8 = PAIR_CAR( X3 ); X7 = misccode_ion_2dinfo_659a45e5( X8 ); X6 = sc_cons( X7, EMPTYLIST ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3501; X7 = PAIR_CDR( X3 ); X5 = X6; X4 = X6; X3 = X7; GOBACK( L3494 ); L3501: X7 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3506; scdebug_error( c2979, c2980, CONS( X5, EMPTYLIST ) ); L3506: X5 = SETGEN( PAIR_CDR( X5 ), X6 ); X3 = X7; GOBACK( L3494 ); L3502: X1 = scrt1_remove( EMPTYLIST, X2 ); if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3509; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3512; scrt1__24__car_2derror( X1 ); L3512: X2 = PAIR_CAR( X1 ); X3 = PAIR_CDR( X1 ); L3515: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3516; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3519; scrt1__24__car_2derror( X3 ); L3519: X5 = PAIR_CAR( X3 ); X4 = misccode_intersect2( X2, X5 ); X3 = PAIR_CDR( X3 ); X2 = X4; GOBACK( L3515 ); L3516: POPSTACKTRACE( X2 ); L3509: POPSTACKTRACE( gencode_ion_2dinfo_cc47b64b_v ); } DEFTSCP( misccode_dbefore_3f_136acdb0_v ); DEFCSTRING( t3522, "$CALL-TESTED-TRUE-BEFORE?" ); TSCP misccode_dbefore_3f_136acdb0( t2993 ) TSCP t2993; { TSCP X1; PUSHSTACKTRACE( t3522 ); X1 = misccode_rue_2dlist_71bcc9dd( gencode_ion_2dinfo_f92fd619_v ); POPSTACKTRACE( scrt1_member( t2993, X1 ) ); } DEFTSCP( misccode_dbefore_3f_d2e61671_v ); DEFCSTRING( t3524, "$CALL-TESTED-FALSE-BEFORE?" ); TSCP misccode_dbefore_3f_d2e61671( t2995 ) TSCP t2995; { TSCP X1; PUSHSTACKTRACE( t3524 ); X1 = misccode_lse_2dlist_1c8651d( gencode_ion_2dinfo_f92fd619_v ); POPSTACKTRACE( scrt1_member( t2995, X1 ) ); } DEFTSCP( misccode_add_2dcondition_v ); DEFCSTRING( t3526, "ADD-CONDITION" ); TSCP misccode_add_2dcondition( t2997, t2998 ) TSCP t2997, t2998; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3526 ); if ( FALSE( t2998 ) ) goto L3528; X2 = scrt1_cons_2a( t2997, CONS( EMPTYLIST, EMPTYLIST ) ); X4 = misccode_rue_2dlist_71bcc9dd( gencode_ion_2dinfo_f92fd619_v ); X3 = scrt1_remove( t2997, X4 ); X1 = scrt1_append_2dtwo( X2, X3 ); X2 = misccode_lse_2dlist_1c8651d( gencode_ion_2dinfo_f92fd619_v ); POPSTACKTRACE( SET( gencode_ion_2dinfo_f92fd619_v, sc_cons( X1, X2 ) ) ); L3528: X1 = misccode_rue_2dlist_71bcc9dd( gencode_ion_2dinfo_f92fd619_v ); X3 = scrt1_cons_2a( t2997, CONS( EMPTYLIST, EMPTYLIST ) ); X5 = misccode_lse_2dlist_1c8651d( gencode_ion_2dinfo_f92fd619_v ); X4 = scrt1_remove( t2997, X5 ); X2 = scrt1_append_2dtwo( X3, X4 ); POPSTACKTRACE( SET( gencode_ion_2dinfo_f92fd619_v, sc_cons( X1, X2 ) ) ); } DEFTSCP( misccode_args_2dset_21_3f_v ); DEFCSTRING( t3530, "ARGS-SET!?" ); TSCP misccode_args_2dset_21_3f( a3000 ) TSCP a3000; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3530 ); L3531: if ( EQ( _S2CUINT( a3000 ), _S2CUINT( EMPTYLIST ) ) ) goto L3532; if ( EQ( TSCPTAG( a3000 ), PAIRTAG ) ) goto L3535; scrt1__24__cdr_2derror( a3000 ); L3535: X1 = PAIR_CDR( a3000 ); X2 = PAIR_CAR( a3000 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3539; X4 = plist_get( X2, c2150 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c3022 ) ) ) goto L3541; X3 = FALSEVALUE; goto L3542; L3541: X4 = plist_get( X2, c2150 ); X3 = BOOLEAN( NEQ( _S2CUINT( X4 ), _S2CUINT( c3029 ) ) ); L3542: if ( TRUE( X3 ) ) goto L3544; X4 = plist_get( X2, c3036 ); if ( TRUE( X4 ) ) goto L3547; a3000 = X1; GOBACK( L3531 ); L3547: POPSTACKTRACE( X4 ); L3544: POPSTACKTRACE( X3 ); L3539: POPSTACKTRACE( TRUEVALUE ); L3532: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( misccode_dreturn_3f_ca61fd98_v ); DEFCSTRING( t3549, "IF-LEG-HAS-NO-RETURN?" ); EXTERNTSCP( gencode_error_2did_v ); EXTERNTSCP( gencode__24__cdr_2derror_2did_v ); EXTERNTSCP( gencode__24__car_2derror_2did_v ); TSCP misccode_dreturn_3f_ca61fd98( l3047 ) TSCP l3047; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3549 ); if ( NEQ( TSCPTAG( l3047 ), PAIRTAG ) ) goto L3551; X2 = PAIR_CAR( l3047 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2487 ) ) ); goto L3552; L3551: X1 = FALSEVALUE; L3552: if ( FALSE( X1 ) ) goto L3555; if ( NEQ( TSCPTAG( l3047 ), PAIRTAG ) ) goto L3557; X4 = PAIR_CAR( l3047 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2487 ) ) ); goto L3558; L3557: X3 = FALSEVALUE; L3558: if ( FALSE( X3 ) ) goto L3561; X2 = scrt1_caddr( l3047 ); goto L3562; L3561: X2 = X3; L3562: X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( gencode__24__cdr_2derror_2did_v, X4 ); X3 = scrt1_cons_2a( gencode_error_2did_v, CONS( gencode__24__car_2derror_2did_v, X4 ) ); POPSTACKTRACE( scrt1_member( X2, X3 ) ); L3555: POPSTACKTRACE( X1 ); } void scrt3__init(); void scdebug__init(); void expform__init(); void scrt1__init(); void lap__init(); void gencode__init(); void plist__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt3__init(); scdebug__init(); expform__init(); scrt1__init(); lap__init(); gencode__init(); plist__init(); MAXDISPLAY( 0 ); } void misccode__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(misccode SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3142, ADR( misccode_symbol_2dgenc_v ), MAKEPROCEDURE( 3, 0, misccode_symbol_2dgenc, EMPTYLIST ) ); INITIALIZEVAR( t3168, ADR( misccode__24define_2dgenc_v ), MAKEPROCEDURE( 3, 0, misccode__24define_2dgenc, EMPTYLIST ) ); INITIALIZEVAR( t3199, ADR( misccode__24set_2dgenc_v ), MAKEPROCEDURE( 3, 0, misccode__24set_2dgenc, EMPTYLIST ) ); INITIALIZEVAR( t3284, ADR( misccode__24if_2dgenc_v ), MAKEPROCEDURE( 3, 0, misccode__24if_2dgenc, EMPTYLIST ) ); INITIALIZEVAR( t3346, ADR( misccode_2doptimize_474b940d_v ), MAKEPROCEDURE( 4, 0, misccode_2doptimize_474b940d, EMPTYLIST ) ); INITIALIZEVAR( t3425, ADR( misccode_rue_2dlist_71bcc9dd_v ), MAKEPROCEDURE( 1, 0, misccode_rue_2dlist_71bcc9dd, EMPTYLIST ) ); INITIALIZEVAR( t3430, ADR( misccode_lse_2dlist_1c8651d_v ), MAKEPROCEDURE( 1, 0, misccode_lse_2dlist_1c8651d, EMPTYLIST ) ); INITIALIZEVAR( t3435, ADR( misccode_ion_2dinfo_37ee0438_v ), MAKEPROCEDURE( 1, 0, misccode_ion_2dinfo_37ee0438, EMPTYLIST ) ); INITIALIZEVAR( t3437, ADR( misccode_ion_2dinfo_659a45e5_v ), MAKEPROCEDURE( 1, 0, misccode_ion_2dinfo_659a45e5, EMPTYLIST ) ); INITIALIZEVAR( t3442, ADR( misccode_ion_2dinfo_2b7559ad_v ), MAKEPROCEDURE( 1, 0, misccode_ion_2dinfo_2b7559ad, EMPTYLIST ) ); INITIALIZEVAR( t3447, ADR( misccode_ion_2dinfo_fbff5bfd_v ), MAKEPROCEDURE( 1, 1, misccode_ion_2dinfo_fbff5bfd, EMPTYLIST ) ); INITIALIZEVAR( t3455, ADR( misccode_combine2_v ), MAKEPROCEDURE( 2, 0, misccode_combine2, EMPTYLIST ) ); INITIALIZEVAR( t3457, ADR( misccode_list_2dcombination_v ), MAKEPROCEDURE( 2, 0, misccode_list_2dcombination, EMPTYLIST ) ); INITIALIZEVAR( t3466, ADR( misccode_ion_2dinfo_bd1601d7_v ), MAKEPROCEDURE( 1, 1, misccode_ion_2dinfo_bd1601d7, EMPTYLIST ) ); INITIALIZEVAR( t3474, ADR( misccode_intersect2_v ), MAKEPROCEDURE( 2, 0, misccode_intersect2, EMPTYLIST ) ); INITIALIZEVAR( t3476, ADR( misccode_list_2dintersection_v ), MAKEPROCEDURE( 2, 0, misccode_list_2dintersection, EMPTYLIST ) ); INITIALIZEVAR( t3490, ADR( misccode_tersection_bbeb56bc_v ), MAKEPROCEDURE( 1, 0, misccode_tersection_bbeb56bc, EMPTYLIST ) ); INITIALIZEVAR( t3522, ADR( misccode_dbefore_3f_136acdb0_v ), MAKEPROCEDURE( 1, 0, misccode_dbefore_3f_136acdb0, EMPTYLIST ) ); INITIALIZEVAR( t3524, ADR( misccode_dbefore_3f_d2e61671_v ), MAKEPROCEDURE( 1, 0, misccode_dbefore_3f_d2e61671, EMPTYLIST ) ); INITIALIZEVAR( t3526, ADR( misccode_add_2dcondition_v ), MAKEPROCEDURE( 2, 0, misccode_add_2dcondition, EMPTYLIST ) ); INITIALIZEVAR( t3530, ADR( misccode_args_2dset_21_3f_v ), MAKEPROCEDURE( 1, 0, misccode_args_2dset_21_3f, EMPTYLIST ) ); INITIALIZEVAR( t3549, ADR( misccode_dreturn_3f_ca61fd98_v ), MAKEPROCEDURE( 1, 0, misccode_dreturn_3f_ca61fd98, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/misccode.sc000066400000000000000000000255751203736146400166670ustar00rootroot00000000000000;;; Code generator for symbols and $set, $if, and $define expressions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module misccode) ;;; External and in-line declarations. (include "plist.sch") (include "expform.sch") (include "lambdaexp.sch") (include "miscexp.sch") (include "gencode.sch") (include "lap.sch") ;;; identifier ;;; ;;; Load it's value into the location. (define (SYMBOL-GENC loc exp bindings) (let ((var (lookup exp bindings)) (c-type (and (eq? (id-use exp) 'global) (id-type exp)))) (cond ((eq? loc 'no-value) #f) (c-type (emit-lap `(SET ,(vname loc) ,(case (if (id-lambda exp) 'pointer c-type) ((char) `(CHAR_TSCP ,var)) ((int shortint longint) `(S2CINT_TSCP (_S2CINT ,var))) ((unsigned shortunsigned longunsigned) `(S2CUINT_TSCP (_S2CUINT ,var))) ((pointer array) `(POINTER_TSCP ,var)) ((tscp) var) ((float) `(DOUBLE_TSCP (CDOUBLE ,var))) ((double) `(DOUBLE_TSCP ,var)) (else (report-error "Cannot load value of" (id-printname exp))))))) (else (emit-lap `(SET ,(vname loc) ,var)))))) ;;; ($define var exp) ;;; ;;; Emit code to declare the global variable, evaluate its initial value, ;;; and inform the run-time system of its existence. (define ($DEFINE-GENC loc exp bindings) (let* ((name ($define-id exp)) (body ($define-exp exp)) (temp (make-c-global)) (string-name (symbol->string (id-printname name)))) (set! current-define-name (id-printname name)) (emit-global-lap `(DEFTSCP ,(vname name))) (if (not (or (eq? top-level-symbols #t) (memq (id-printname name) top-level-symbols))) (set! string-name (string-append module-name-upcase "_" string-name))) (emit-global-lap `(DEFCSTRING ,(vname temp) (CSTRING ,string-name))) (set! current-define-string temp) (exp-genc 'tos body bindings) (set-id-external! name #t) (emit-lap `(INITIALIZEVAR ,(vname temp) (ADR ,(vname name)) tos)) (set! current-define-name 'top-level))) ;;; ($set var exp) ;;; ;;; Emit code for expression and store it in var. Note the special case ;;; for procedures. (define ($SET-GENC loc exp bindings) (let* ((var ($set-id exp)) (set (if (var-in-stack var) 'SETGEN (if (var-is-top-level var) 'SETGENTL 'SET))) (c-type (and (eq? (id-use var) 'global) (id-type var)))) (cond ((and (id-lambda var) (not (eq? (lambda-generate (id-lambda var)) 'closed-procedure))) (exp-genc 'no-value ($set-exp exp) bindings)) (c-type (let ((temp (if (eq? loc 'no-value) 'tos (use-lap-temp)))) (exp-genc temp ($set-exp exp) bindings) (emit-lap `(SET tos ,(vname temp))) (emit-lap `(SET ,(lookup var bindings) ,(case c-type ((char) '(TSCP_CHAR tos)) ((int) '(INT (TSCP_S2CINT tos))) ((tscp) 'tos) ((shortint) '(SHORTINT (TSCP_S2CINT tos))) ((longint) '(LONGINT (TSCP_S2CINT tos))) ((unsigned) '(UNSIGNED (TSCP_S2CUINT tos))) ((shortunsigned) '(SHORTUNSIGNED (TSCP_S2CUINT tos))) ((longunsigned) '(LONGUNSIGNED (TSCP_S2CUINT tos))) ((pointer array) '(TSCP_POINTER tos)) ((float) '(CFLOAT (TSCP_DOUBLE tos))) ((double) '(TSCP_DOUBLE tos))))) (unless (eq? temp 'tos) (emit-lap `(SET ,(vname loc) ,(vname temp))) (drop-lap-temp temp)))) (else (let ((temp (if (eq? set 'setgen) (use-lap-temp) 'tos))) (exp-genc temp ($set-exp exp) bindings) (if (eq? loc 'no-value) (emit-lap `(,SET ,(lookup var bindings) ,temp)) (emit-lap `(SET ,(vname loc) (,SET ,(lookup var bindings) ,temp)))) (unless (eq? temp 'tos) (drop-lap-temp temp))))))) ;;; ($if test true false) ;;; ;;; Emit code for $if expression. If the test condition has been performed ;;; before, then optimization can be done by taking the one leg that is ;;; known to be true and ignoring the other one that is known to be false. (define ($IF-GENC loc exp bindings) (let ((test ($if-test exp)) (true ($if-true exp)) (false ($if-false exp))) (if (and ($call? test) ($lap? ($call-func test)) (not (args-set!? ($call-argl test)))) (begin (cond (($call-tested-true-before? test) (exp-genc loc true bindings)) (($call-tested-false-before? test) (exp-genc loc false bindings)) (else ($if-genc-no-optimize loc exp bindings test)))) ($if-genc-no-optimize loc exp bindings #f)))) ;;; Generate code for evaluating the test and then branching appropriately. ;;; The branch condition will be reversed when the true leg is returning a ;;; variable value. (define ($IF-GENC-NO-OPTIMIZE loc exp bindings add-test) (let* ((l1 (make-label)) (l2 (make-label)) (test ($if-test exp)) (true ($if-true exp)) (false ($if-false exp)) (t/f-reversed #f) (tleg-condition '(())) (fleg-condition '(())) (save-condition global-condition-info) (temp (if (eq? loc 'tos) (use-lap-temp) loc))) (exp-genc 'tos test bindings) (cond ((and (symbol? true) (memq loc '(return no-value))) (emit-lap `(IF (TRUE tos) ,l1)) (set! false true) (set! true ($if-false exp)) (set! t/f-reversed #t)) (else (emit-lap `(IF (FALSE tos) ,l1)))) (if add-test (add-condition add-test (not t/f-reversed))) (exp-genc temp true bindings) (set! tleg-condition global-condition-info) (set! global-condition-info save-condition) (if add-test (add-condition add-test t/f-reversed)) (if (or (not (eq? loc 'no-value)) (not (symbol? false))) (begin (if (not (eq? loc 'return)) (emit-lap `(GOTO ,l2))) (emit-lap `(LABEL ,l1)) (exp-genc temp false bindings) (if (not (eq? loc 'return)) (emit-lap `(LABEL ,l2)))) (emit-lap `(LABEL ,l1))) (when (eq? loc 'tos) (emit-lap `(SET tos ,(vname temp))) (drop-lap-temp temp)) (set! fleg-condition global-condition-info) (set! global-condition-info save-condition) (cond ((if-leg-has-no-return? true) (combine-with-global-condition-info fleg-condition)) ((if-leg-has-no-return? false) (combine-with-global-condition-info tleg-condition)) (else (combine-with-global-condition-info (intersect2 tleg-condition fleg-condition)))))) ;; The following are operations that pertain to code optimization by ;; elimination of unnecessary $if test conditions that have been tested ;; for already. (define (CONDITION-INFO-TRUE-LIST x) (car x)) (define (CONDITION-INFO-FALSE-LIST x) (cdr x)) (define (STORE-CONDITION-INFO id) (put id 'condition-info global-condition-info)) (define (RETRIEVE-CONDITION-INFO id) (let ((stored-info (get id 'condition-info))) (if stored-info stored-info empty-condition-info))) (define (UPDATE-CONDITION-INFO id) (let ((stored-info (get id 'condition-info))) (if (null? stored-info) (put id 'condition-info global-condition-info) (put id 'condition-info (intersect2 stored-info global-condition-info))))) (define (COMBINE-WITH-GLOBAL-CONDITION-INFO info . info-list) (if (null? info-list) (set! global-condition-info (combine2 info global-condition-info)) (combine-with-global-condition-info (combine2 info (car info-list)) (cdr info-list)))) (define (COMBINE2 info1 info2) (cons (list-combination (condition-info-true-list info1) (condition-info-true-list info2)) (list-combination (condition-info-false-list info1) (condition-info-false-list info2)))) (define (LIST-COMBINATION lst1 lst2) (if (null? lst2) lst1 (list-combination (append `(,(car lst2)) (remove (car lst2) lst1)) (cdr lst2)))) (define (INTERSECT-WITH-GLOBAL-CONDITION-INFO info . info-list) (if (null? info-list) (set! global-condition-info (intersect2 info global-condition-info)) (intersect-with-global-condition-info (intersect2 info (car info-list)) (cdr info-list)))) (define (INTERSECT2 info1 info2) (cons (list-intersection (condition-info-true-list info1) (condition-info-true-list info2)) (list-intersection (condition-info-false-list info1) (condition-info-false-list info2)))) (define (LIST-INTERSECTION lst1 lst2) (if (null? lst1) '() (if (member (car lst1) lst2) (append `(,(car lst1)) (list-intersection (cdr lst1) lst2)) (list-intersection (cdr lst1) lst2)))) (define (STORED-CONDITIONS-INTERSECTION lid-list) (define (iter info info-list) (if (null? info-list) info (iter (intersect2 info (car info-list)) (cdr info-list)))) (let ((stored-info-list (remove '() (map (lambda (lid) (retrieve-condition-info lid)) lid-list)))) (if (null? stored-info-list) empty-condition-info (iter (car stored-info-list) (cdr stored-info-list))))) (define ($CALL-TESTED-TRUE-BEFORE? test) (member test (condition-info-true-list global-condition-info))) (define ($CALL-TESTED-FALSE-BEFORE? test) (member test (condition-info-false-list global-condition-info))) (define (ADD-CONDITION test t/f-flag) (if t/f-flag ; add true condition (set! global-condition-info (cons (append `(,test) (remove test (condition-info-true-list global-condition-info))) (condition-info-false-list global-condition-info))) ; otherwise add false condition (set! global-condition-info (cons (condition-info-true-list global-condition-info) (append `(,test) (remove test (condition-info-false-list global-condition-info))))))) (define (ARGS-SET!? argl) (if (null? argl) #f (let ((first-arg (car argl)) (rest-args (cdr argl))) (if (symbol? first-arg) (or (not (or (eq? (id-use first-arg) 'LEXICAL) (eq? (id-use first-arg) 'CONSTANT))) (id-set! first-arg) (args-set!? rest-args)) #t)))) (define (IF-LEG-HAS-NO-RETURN? leg) (and ($call? leg) (member ($call-func leg) `(,error-id ,$_car-error-id ,$_cdr-error-id)))) scheme2c-2012.10.14/scsc/miscexp.c000066400000000000000000002000531203736146400163500ustar00rootroot00000000000000 /* SCHEME->C */ #include void miscexp__init(); DEFSTATICTSCP( id_2duse_v ); DEFSTATICTSCP( exp_2dform_2dlist_v ); DEFSTATICTSCP( _24lambda_3f_v ); DEFSTATICTSCP( id_2dset_21_v ); DEFSTATICTSCP( name_2da_2dlambda_v ); DEFSTATICTSCP( _24lambda_2dbody_v ); DEFSTATICTSCP( islist_v ); DEFSTATICTSCP( expand_2derror_v ); DEFSTATICTSCP( set_2dlambda_2dreqvars_21_v ); DEFSTATICTSCP( set_2dlambda_2doptvars_21_v ); DEFSTATICTSCP( exp_2dform_v ); DEFSTATICTSCP( lambda_2dreqvars_v ); DEFSTATICTSCP( lambda_2doptvars_v ); DEFSTATICTSCP( _24lambda_2did_v ); DEFSTATICTSCP( newv_v ); DEFSTATICTSCP( bound_v ); DEFSTATICTSCP( false_2dalpha_v ); DEFSTATICTSCP( empty_2dlist_2dalpha_v ); DEFSTATICTSCP( true_2dalpha_v ); DEFSTATICTSCP( set_2did_2dset_21_21_v ); DEFSTATICTSCP( id_2dvalue_v ); DEFSTATICTSCP( current_2ddefine_2dname_v ); DEFSTATICTSCP( module_2dname_v ); DEFSTATICTSCP( assign_2dknown_2dname_v ); DEFSTATICTSCP( c3109 ); DEFSTATICTSCP( c3104 ); DEFSTATICTSCP( c3100 ); DEFSTATICTSCP( c3098 ); DEFSTATICTSCP( c3097 ); DEFSTATICTSCP( c3089 ); DEFSTATICTSCP( c2885 ); DEFSTATICTSCP( c2871 ); DEFSTATICTSCP( c2714 ); DEFSTATICTSCP( c2713 ); DEFSTATICTSCP( c2711 ); DEFSTATICTSCP( c2710 ); DEFSTATICTSCP( c2709 ); DEFSTATICTSCP( c2690 ); DEFSTATICTSCP( c2509 ); DEFSTATICTSCP( c2508 ); DEFSTATICTSCP( c2507 ); DEFSTATICTSCP( c2470 ); DEFSTATICTSCP( c2430 ); DEFCSTRING( t3328, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2343 ); DEFSTATICTSCP( c2342 ); DEFSTATICTSCP( c2269 ); DEFSTATICTSCP( c2268 ); DEFSTATICTSCP( c2225 ); DEFSTATICTSCP( c2163 ); DEFSTATICTSCP( c2107 ); DEFSTATICTSCP( c2073 ); static void init_constants() { id_2duse_v = STRINGTOSYMBOL( CSTRING_TSCP( "ID-USE" ) ); CONSTANTEXP( ADR( id_2duse_v ) ); exp_2dform_2dlist_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXP-FORM-LIST" ) ); CONSTANTEXP( ADR( exp_2dform_2dlist_v ) ); _24lambda_3f_v = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA?" ) ); CONSTANTEXP( ADR( _24lambda_3f_v ) ); id_2dset_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "ID-SET!" ) ); CONSTANTEXP( ADR( id_2dset_21_v ) ); name_2da_2dlambda_v = STRINGTOSYMBOL( CSTRING_TSCP( "NAME-A-LAMBDA" ) ); CONSTANTEXP( ADR( name_2da_2dlambda_v ) ); _24lambda_2dbody_v = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA-BODY" ) ); CONSTANTEXP( ADR( _24lambda_2dbody_v ) ); islist_v = STRINGTOSYMBOL( CSTRING_TSCP( "ISLIST" ) ); CONSTANTEXP( ADR( islist_v ) ); expand_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXPAND-ERROR" ) ); CONSTANTEXP( ADR( expand_2derror_v ) ); set_2dlambda_2dreqvars_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-LAM\ BDA-REQVARS!" ) ); CONSTANTEXP( ADR( set_2dlambda_2dreqvars_21_v ) ); set_2dlambda_2doptvars_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-LAM\ BDA-OPTVARS!" ) ); CONSTANTEXP( ADR( set_2dlambda_2doptvars_21_v ) ); exp_2dform_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXP-FORM" ) ); CONSTANTEXP( ADR( exp_2dform_v ) ); lambda_2dreqvars_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA-REQVARS" ) ); CONSTANTEXP( ADR( lambda_2dreqvars_v ) ); lambda_2doptvars_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA-OPTVARS" ) ); CONSTANTEXP( ADR( lambda_2doptvars_v ) ); _24lambda_2did_v = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA-ID" ) ); CONSTANTEXP( ADR( _24lambda_2did_v ) ); newv_v = STRINGTOSYMBOL( CSTRING_TSCP( "NEWV" ) ); CONSTANTEXP( ADR( newv_v ) ); bound_v = STRINGTOSYMBOL( CSTRING_TSCP( "BOUND" ) ); CONSTANTEXP( ADR( bound_v ) ); false_2dalpha_v = STRINGTOSYMBOL( CSTRING_TSCP( "FALSE-ALPHA" ) ); CONSTANTEXP( ADR( false_2dalpha_v ) ); empty_2dlist_2dalpha_v = STRINGTOSYMBOL( CSTRING_TSCP( "EMPTY-LIST-A\ LPHA" ) ); CONSTANTEXP( ADR( empty_2dlist_2dalpha_v ) ); true_2dalpha_v = STRINGTOSYMBOL( CSTRING_TSCP( "TRUE-ALPHA" ) ); CONSTANTEXP( ADR( true_2dalpha_v ) ); set_2did_2dset_21_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-ID-SET!!\ " ) ); CONSTANTEXP( ADR( set_2did_2dset_21_21_v ) ); id_2dvalue_v = STRINGTOSYMBOL( CSTRING_TSCP( "ID-VALUE" ) ); CONSTANTEXP( ADR( id_2dvalue_v ) ); current_2ddefine_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-D\ EFINE-NAME" ) ); CONSTANTEXP( ADR( current_2ddefine_2dname_v ) ); module_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE-NAME" ) ); CONSTANTEXP( ADR( module_2dname_v ) ); assign_2dknown_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "ASSIGN-KNOW\ N-NAME" ) ); CONSTANTEXP( ADR( assign_2dknown_2dname_v ) ); c3109 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c3109 ) ); c3104 = STRINGTOSYMBOL( CSTRING_TSCP( "$DEFINE" ) ); CONSTANTEXP( ADR( c3104 ) ); c3100 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINED" ) ); CONSTANTEXP( ADR( c3100 ) ); c3098 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); CONSTANTEXP( ADR( c3098 ) ); c3097 = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL" ) ); CONSTANTEXP( ADR( c3097 ) ); c3089 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE" ) ); CONSTANTEXP( ADR( c3089 ) ); c2885 = STRINGTOSYMBOL( CSTRING_TSCP( "$IF" ) ); CONSTANTEXP( ADR( c2885 ) ); c2871 = STRINGTOSYMBOL( CSTRING_TSCP( "IF" ) ); CONSTANTEXP( ADR( c2871 ) ); c2714 = STRINGTOSYMBOL( CSTRING_TSCP( "$_EMPTY-STRING" ) ); CONSTANTEXP( ADR( c2714 ) ); c2713 = STRINGTOSYMBOL( CSTRING_TSCP( "$_EMPTY-VECTOR" ) ); CONSTANTEXP( ADR( c2713 ) ); c2711 = STRINGTOSYMBOL( CSTRING_TSCP( "VALUE" ) ); CONSTANTEXP( ADR( c2711 ) ); c2710 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2710 ) ); c2709 = STRINGTOSYMBOL( CSTRING_TSCP( "C" ) ); CONSTANTEXP( ADR( c2709 ) ); c2690 = STRINGTOSYMBOL( CSTRING_TSCP( "QUOTE" ) ); CONSTANTEXP( ADR( c2690 ) ); c2509 = STRINGTOSYMBOL( CSTRING_TSCP( "SET" ) ); CONSTANTEXP( ADR( c2509 ) ); c2508 = STRINGTOSYMBOL( CSTRING_TSCP( "READ-ONLY" ) ); CONSTANTEXP( ADR( c2508 ) ); c2507 = STRINGTOSYMBOL( CSTRING_TSCP( "BOOLEAN" ) ); CONSTANTEXP( ADR( c2507 ) ); c2470 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAP" ) ); CONSTANTEXP( ADR( c2470 ) ); c2430 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2430 ) ); c2343 = CSTRING_TSCP( t3328 ); CONSTANTEXP( ADR( c2343 ) ); c2342 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CAR!" ) ); CONSTANTEXP( ADR( c2342 ) ); c2269 = STRINGTOSYMBOL( CSTRING_TSCP( "CONS" ) ); CONSTANTEXP( ADR( c2269 ) ); c2268 = EMPTYLIST; c2268 = CONS( EMPTYLIST, c2268 ); c2268 = CONS( c2690, c2268 ); CONSTANTEXP( ADR( c2268 ) ); c2225 = STRINGTOSYMBOL( CSTRING_TSCP( "$SET" ) ); CONSTANTEXP( ADR( c2225 ) ); c2163 = STRINGTOSYMBOL( CSTRING_TSCP( "CALL" ) ); CONSTANTEXP( ADR( c2163 ) ); c2107 = STRINGTOSYMBOL( CSTRING_TSCP( "CONSTANT" ) ); CONSTANTEXP( ADR( c2107 ) ); c2073 = STRINGTOSYMBOL( CSTRING_TSCP( "$CALL" ) ); CONSTANTEXP( ADR( c2073 ) ); } DEFTSCP( miscexp_quote_2dconstants_v ); DEFCSTRING( t3329, "QUOTE-CONSTANTS" ); DEFTSCP( miscexp_2dconstant_109f5a09_v ); DEFCSTRING( t3330, "FIND-QUOTE-CONSTANT" ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); TSCP miscexp_2dconstant_109f5a09( c2012, t2013 ) TSCP c2012, t2013; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3330 ); X1 = miscexp_quote_2dconstants_v; X2 = X1; L3334: if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3335; X3 = PAIR_CAR( X2 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3340; scrt1__24__car_2derror( X3 ); L3340: X4 = PAIR_CAR( X3 ); X6 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3345; scrt1__24__car_2derror( X6 ); L3345: X5 = PAIR_CAR( X6 ); X6 = scrt1_equal_3f( X4, c2012 ); if ( FALSE( X6 ) ) goto L3354; X8 = SYMBOL_VALUE( id_2duse_v ); X8 = UNKNOWNCALL( X8, 1 ); X7 = VIA( PROCEDURE_CODE( X8 ) )( X5, PROCEDURE_CLOSURE( X8 ) ); if ( NEQ( _S2CUINT( X7 ), _S2CUINT( t2013 ) ) ) goto L3354; POPSTACKTRACE( X5 ); L3335: POPSTACKTRACE( FALSEVALUE ); L3354: X2 = PAIR_CDR( X2 ); GOBACK( L3334 ); } DEFTSCP( miscexp_call_2dexp_v ); DEFCSTRING( t3356, "CALL-EXP" ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( miscexp_letrec_2dlambdas, XAL2( TSCP, TSCP ) ); EXTERNTSCP( miscexp_letrec_2dlambdas_v ); EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); EXTERNTSCPP( miscexp_call_2dexp_2dcons, XAL1( TSCP ) ); EXTERNTSCP( miscexp_call_2dexp_2dcons_v ); TSCP miscexp_call_2dexp( e2061, e2062 ) TSCP e2061, e2062; { TSCP X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3356 ); e2061 = CONS( e2061, EMPTYLIST ); X11 = PAIR_CAR( e2061 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L3359; scrt1__24__car_2derror( X11 ); L3359: X10 = PAIR_CAR( X11 ); X9 = e2062; X9 = UNKNOWNCALL( X9, 2 ); X1 = VIA( PROCEDURE_CODE( X9 ) )( X10, e2062, PROCEDURE_CLOSURE( X9 ) ); X9 = SYMBOL_VALUE( _24lambda_3f_v ); X9 = UNKNOWNCALL( X9, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X9 ) )( X1, PROCEDURE_CLOSURE( X9 ) ) ) ) goto L3362; X9 = SYMBOL_VALUE( _24lambda_2did_v ); X9 = UNKNOWNCALL( X9, 1 ); X4 = VIA( PROCEDURE_CODE( X9 ) )( X1, PROCEDURE_CLOSURE( X9 ) ); goto L3363; L3362: X4 = FALSEVALUE; L3363: if ( FALSE( X4 ) ) goto L3365; X9 = PAIR_CAR( e2061 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3369; scrt1__24__cdr_2derror( X9 ); L3369: X8 = PAIR_CDR( X9 ); X9 = SYMBOL_VALUE( lambda_2dreqvars_v ); X9 = UNKNOWNCALL( X9, 1 ); X7 = VIA( PROCEDURE_CODE( X9 ) )( X4, PROCEDURE_CLOSURE( X9 ) ); X9 = SYMBOL_VALUE( lambda_2doptvars_v ); X9 = UNKNOWNCALL( X9, 1 ); X5 = VIA( PROCEDURE_CODE( X9 ) )( X4, PROCEDURE_CLOSURE( X9 ) ); X3 = EMPTYLIST; X6 = EMPTYLIST; X2 = EMPTYLIST; L3371: X2 = CONS( X2, EMPTYLIST ); X6 = CONS( X6, EMPTYLIST ); X3 = CONS( X3, EMPTYLIST ); X9 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ); if ( TRUE( X9 ) ) goto L3376; if ( NEQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3376; if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3381; scrt1__24__car_2derror( X8 ); L3381: X12 = PAIR_CAR( X8 ); X11 = e2062; X11 = UNKNOWNCALL( X11, 2 ); X10 = VIA( PROCEDURE_CODE( X11 ) )( X12, e2062, PROCEDURE_CLOSURE( X11 ) ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L3384; scrt1__24__car_2derror( X7 ); L3384: X11 = PAIR_CAR( X7 ); X12 = sc_cons( X11, PAIR_CAR( X3 ) ); SETGEN( PAIR_CAR( X3 ), X12 ); X12 = sc_cons( X10, PAIR_CAR( X6 ) ); SETGEN( PAIR_CAR( X6 ), X12 ); if ( NOT( AND( EQ( TSCPTAG( X10 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X10 ), SYMBOLTAG ) ) ) ) goto L3389; X13 = SYMBOL_VALUE( id_2duse_v ); X13 = UNKNOWNCALL( X13, 1 ); X12 = VIA( PROCEDURE_CODE( X13 ) )( X10, PROCEDURE_CLOSURE( X13 ) ); if ( NEQ( _S2CUINT( X12 ), _S2CUINT( c2107 ) ) ) goto L3389; X12 = sc_cons( X11, PAIR_CAR( X2 ) ); SETGEN( PAIR_CAR( X2 ), X12 ); L3389: X12 = SYMBOL_VALUE( _24lambda_3f_v ); X12 = UNKNOWNCALL( X12, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X12 ) )( X10, PROCEDURE_CLOSURE( X12 ) ) ) ) goto L3393; X12 = SYMBOL_VALUE( id_2dset_21_v ); X12 = UNKNOWNCALL( X12, 1 ); if ( TRUE( VIA( PROCEDURE_CODE( X12 ) )( X11, PROCEDURE_CLOSURE( X12 ) ) ) ) goto L3393; X12 = SYMBOL_VALUE( name_2da_2dlambda_v ); X12 = UNKNOWNCALL( X12, 2 ); VIA( PROCEDURE_CODE( X12 ) )( X11, X10, PROCEDURE_CLOSURE( X12 ) ); L3393: X10 = PAIR_CDR( X8 ); X11 = PAIR_CDR( X7 ); X2 = PAIR_CAR( X2 ); X6 = PAIR_CAR( X6 ); X3 = PAIR_CAR( X3 ); X7 = X11; X8 = X10; GOBACK( L3371 ); L3365: X13 = PAIR_CAR( e2061 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L3399; scrt1__24__cdr_2derror( X13 ); L3399: X12 = PAIR_CDR( X13 ); X11 = SYMBOL_VALUE( exp_2dform_2dlist_v ); X11 = UNKNOWNCALL( X11, 2 ); X10 = VIA( PROCEDURE_CODE( X11 ) )( X12, e2062, PROCEDURE_CLOSURE( X11 ) ); X9 = sc_cons( X1, X10 ); SETGEN( PAIR_CAR( e2061 ), X9 ); X10 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X9 = CONS( scrt1_append_2dtwo( PAIR_CAR( e2061 ), X10 ), EMPTYLIST ); POPSTACKTRACE( scrt1_cons_2a( c2073, CONS( EMPTYLIST, X9 ) ) ); L3376: if ( FALSE( PAIR_CAR( X2 ) ) ) goto L3402; X10 = SYMBOL_VALUE( _24lambda_2dbody_v ); X10 = UNKNOWNCALL( X10, 1 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( X1, PROCEDURE_CLOSURE( X10 ) ); miscexp_letrec_2dlambdas( PAIR_CAR( X2 ), X9 ); L3402: X9 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ); if ( FALSE( X9 ) ) goto L3414; if ( NEQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L3414; if ( NEQ( _S2CUINT( X7 ), _S2CUINT( EMPTYLIST ) ) ) goto L3414; X11 = scrt1_reverse( PAIR_CAR( X6 ) ); X12 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X10 = CONS( scrt1_append_2dtwo( X11, X12 ), EMPTYLIST ); X10 = CONS( X1, X10 ); POPSTACKTRACE( scrt1_cons_2a( c2073, CONS( EMPTYLIST, X10 ) ) ); L3414: if ( FALSE( X5 ) ) goto L3424; X9 = SYMBOL_VALUE( islist_v ); X9 = UNKNOWNCALL( X9, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X9 ) )( X8, _TSCP( 0 ), PROCEDURE_CLOSURE( X9 ) ) ) ) goto L3424; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3422; scrt1__24__car_2derror( X5 ); L3422: X12 = PAIR_CAR( X5 ); X11 = sc_cons( X12, PAIR_CAR( X3 ) ); X10 = scrt1_reverse( X11 ); X9 = SYMBOL_VALUE( set_2dlambda_2dreqvars_21_v ); X9 = UNKNOWNCALL( X9, 2 ); VIA( PROCEDURE_CODE( X9 ) )( X4, X10, PROCEDURE_CLOSURE( X9 ) ); X9 = SYMBOL_VALUE( set_2dlambda_2doptvars_21_v ); X9 = UNKNOWNCALL( X9, 2 ); VIA( PROCEDURE_CODE( X9 ) )( X4, EMPTYLIST, PROCEDURE_CLOSURE( X9 ) ); X10 = scrt1_reverse( PAIR_CAR( X6 ) ); X14 = miscexp_call_2dexp_2dcons( X8 ); X13 = SYMBOL_VALUE( exp_2dform_v ); X13 = UNKNOWNCALL( X13, 2 ); X12 = VIA( PROCEDURE_CODE( X13 ) )( X14, e2062, PROCEDURE_CLOSURE( X13 ) ); X11 = scrt1_cons_2a( X12, CONS( EMPTYLIST, EMPTYLIST ) ); X9 = CONS( scrt1_append_2dtwo( X10, X11 ), EMPTYLIST ); X9 = CONS( X1, X9 ); POPSTACKTRACE( scrt1_cons_2a( c2073, CONS( EMPTYLIST, X9 ) ) ); L3424: X9 = SYMBOL_VALUE( expand_2derror_v ); X9 = UNKNOWNCALL( X9, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X9 ) )( c2163, PAIR_CAR( e2061 ), PROCEDURE_CLOSURE( X9 ) ) ); } DEFTSCP( miscexp_letrec_2dlambdas_v ); DEFCSTRING( t3425, "LETREC-LAMBDAS" ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); TSCP miscexp_letrec_2dlambdas( v2185, e2186 ) TSCP v2185, e2186; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3425 ); L3426: if ( NEQ( TSCPTAG( e2186 ), PAIRTAG ) ) goto L3427; X2 = PAIR_CAR( e2186 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3431; X4 = PAIR_CAR( X2 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2225 ) ) ); goto L3432; L3431: X3 = FALSEVALUE; L3432: if ( FALSE( X3 ) ) goto L3435; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3438; scrt1__24__cdr_2derror( X2 ); L3438: X4 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3441; scrt1__24__car_2derror( X4 ); L3441: X1 = PAIR_CAR( X4 ); goto L3436; L3435: X1 = X3; L3436: X3 = PAIR_CAR( e2186 ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3445; X5 = PAIR_CAR( X3 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2225 ) ) ); goto L3446; L3445: X4 = FALSEVALUE; L3446: if ( FALSE( X4 ) ) goto L3449; X2 = scrt1_caddr( X3 ); goto L3450; L3449: X2 = X4; L3450: if ( FALSE( scrt1_memq( X1, v2185 ) ) ) goto L3452; X3 = SYMBOL_VALUE( _24lambda_3f_v ); X3 = UNKNOWNCALL( X3, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X3 ) )( X2, PROCEDURE_CLOSURE( X3 ) ) ) ) goto L3457; X4 = SYMBOL_VALUE( id_2dset_21_v ); X4 = UNKNOWNCALL( X4, 1 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( X1, PROCEDURE_CLOSURE( X4 ) ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L3457; X3 = SYMBOL_VALUE( name_2da_2dlambda_v ); X3 = UNKNOWNCALL( X3, 2 ); VIA( PROCEDURE_CODE( X3 ) )( X1, X2, PROCEDURE_CLOSURE( X3 ) ); L3457: e2186 = PAIR_CDR( e2186 ); GOBACK( L3426 ); L3452: POPSTACKTRACE( FALSEVALUE ); L3427: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( miscexp_call_2dexp_2dcons_v ); DEFCSTRING( t3460, "CALL-EXP-CONS" ); TSCP miscexp_call_2dexp_2dcons( v2267 ) TSCP v2267; { TSCP X2, X1; PUSHSTACKTRACE( t3460 ); if ( FALSE( v2267 ) ) goto L3462; X1 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( v2267 ), PAIRTAG ) ) goto L3465; scrt1__24__cdr_2derror( v2267 ); L3465: X2 = PAIR_CDR( v2267 ); X1 = CONS( miscexp_call_2dexp_2dcons( X2 ), X1 ); POPSTACKTRACE( scrt1_cons_2a( c2269, CONS( PAIR_CAR( v2267 ), X1 ) ) ); L3462: POPSTACKTRACE( c2268 ); } DEFTSCP( miscexp__24call_3f_v ); DEFCSTRING( t3468, "$CALL?" ); TSCP miscexp__24call_3f( x2280 ) TSCP x2280; { TSCP X1; PUSHSTACKTRACE( t3468 ); if ( NEQ( TSCPTAG( x2280 ), PAIRTAG ) ) goto L3470; X1 = PAIR_CAR( x2280 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2073 ) ) ) ); L3470: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( miscexp__24call_2dtail_v ); DEFCSTRING( t3473, "$CALL-TAIL" ); TSCP miscexp__24call_2dtail( x2298 ) TSCP x2298; { TSCP X2, X1; PUSHSTACKTRACE( t3473 ); if ( NEQ( TSCPTAG( x2298 ), PAIRTAG ) ) goto L3475; X2 = PAIR_CAR( x2298 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2073 ) ) ); goto L3476; L3475: X1 = FALSEVALUE; L3476: if ( FALSE( X1 ) ) goto L3479; if ( EQ( TSCPTAG( x2298 ), PAIRTAG ) ) goto L3482; scrt1__24__cdr_2derror( x2298 ); L3482: X2 = PAIR_CDR( x2298 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3485; scrt1__24__car_2derror( X2 ); L3485: POPSTACKTRACE( PAIR_CAR( X2 ) ); L3479: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp__2dtail_21_86d6576f_v ); DEFCSTRING( t3487, "SET-$CALL-TAIL!" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); TSCP miscexp__2dtail_21_86d6576f( x2332, v2333 ) TSCP x2332, v2333; { TSCP X1; PUSHSTACKTRACE( t3487 ); if ( EQ( TSCPTAG( x2332 ), PAIRTAG ) ) goto L3490; scrt1__24__cdr_2derror( x2332 ); L3490: X1 = PAIR_CDR( x2332 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3493; scdebug_error( c2342, c2343, CONS( X1, EMPTYLIST ) ); L3493: POPSTACKTRACE( SETGEN( PAIR_CAR( X1 ), v2333 ) ); } DEFTSCP( miscexp__24call_2dfunc_v ); DEFCSTRING( t3495, "$CALL-FUNC" ); TSCP miscexp__24call_2dfunc( x2350 ) TSCP x2350; { TSCP X2, X1; PUSHSTACKTRACE( t3495 ); if ( NEQ( TSCPTAG( x2350 ), PAIRTAG ) ) goto L3497; X2 = PAIR_CAR( x2350 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2073 ) ) ); goto L3498; L3497: X1 = FALSEVALUE; L3498: if ( FALSE( X1 ) ) goto L3501; POPSTACKTRACE( scrt1_caddr( x2350 ) ); L3501: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp__2dfunc_21_4935643_v ); DEFCSTRING( t3503, "SET-$CALL-FUNC!" ); TSCP miscexp__2dfunc_21_4935643( x2374, f2375 ) TSCP x2374, f2375; { TSCP X2, X1; PUSHSTACKTRACE( t3503 ); if ( EQ( TSCPTAG( x2374 ), PAIRTAG ) ) goto L3506; scrt1__24__cdr_2derror( x2374 ); L3506: X2 = PAIR_CDR( x2374 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3509; scrt1__24__cdr_2derror( X2 ); L3509: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3512; scdebug_error( c2342, c2343, CONS( X1, EMPTYLIST ) ); L3512: POPSTACKTRACE( SETGEN( PAIR_CAR( X1 ), f2375 ) ); } DEFTSCP( miscexp__24call_2dargl_v ); DEFCSTRING( t3514, "$CALL-ARGL" ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); TSCP miscexp__24call_2dargl( x2396 ) TSCP x2396; { TSCP X2, X1; PUSHSTACKTRACE( t3514 ); if ( NEQ( TSCPTAG( x2396 ), PAIRTAG ) ) goto L3516; X2 = PAIR_CAR( x2396 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2073 ) ) ); goto L3517; L3516: X1 = FALSEVALUE; L3517: if ( FALSE( X1 ) ) goto L3520; POPSTACKTRACE( scrt1_cdddr( x2396 ) ); L3520: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp__2dargl_21_89422a52_v ); DEFCSTRING( t3522, "SET-$CALL-ARGL!" ); TSCP miscexp__2dargl_21_89422a52( x2420, a2421 ) TSCP x2420, a2421; { TSCP X2, X1; PUSHSTACKTRACE( t3522 ); if ( EQ( TSCPTAG( x2420 ), PAIRTAG ) ) goto L3525; scrt1__24__cdr_2derror( x2420 ); L3525: X2 = PAIR_CDR( x2420 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3528; scrt1__24__cdr_2derror( X2 ); L3528: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3531; scdebug_error( c2430, c2343, CONS( X1, EMPTYLIST ) ); L3531: POPSTACKTRACE( SETGEN( PAIR_CDR( X1 ), a2421 ) ); } DEFTSCP( miscexp_lap_2dexp_v ); DEFCSTRING( t3533, "LAP-EXP" ); EXTERNTSCPP( miscexp_l2513, XAL1( TSCP ) ); TSCP miscexp_l2513( e2515 ) TSCP e2515; { TSCP X2, X1; PUSHSTACKTRACE( "LOOP [inside LAP-EXP]" ); L3558: X1 = BOOLEAN( EQ( TSCPTAG( e2515 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L3568; if ( EQ( TSCPTAG( e2515 ), PAIRTAG ) ) goto L3566; scrt1__24__car_2derror( e2515 ); L3566: X2 = PAIR_CAR( e2515 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2509 ) ) ) goto L3568; POPSTACKTRACE( TRUEVALUE ); L3568: if ( NEQ( TSCPTAG( e2515 ), PAIRTAG ) ) goto L3569; X2 = PAIR_CAR( e2515 ); X1 = miscexp_l2513( X2 ); if ( TRUE( X1 ) ) goto L3573; e2515 = PAIR_CDR( e2515 ); GOBACK( L3558 ); L3573: POPSTACKTRACE( X1 ); L3569: POPSTACKTRACE( FALSEVALUE ); } EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); TSCP miscexp_lap_2dexp( e2443, e2444 ) TSCP e2443, e2444; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3533 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2443, _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3600; if ( EQ( TSCPTAG( e2443 ), PAIRTAG ) ) goto L3542; scrt1__24__cdr_2derror( e2443 ); L3542: X4 = PAIR_CDR( e2443 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3545; scrt1__24__car_2derror( X4 ); L3545: X3 = PAIR_CAR( X4 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X2 ) )( X3, _TSCP( 0 ), PROCEDURE_CLOSURE( X2 ) ) ) ) goto L3600; X3 = PAIR_CDR( e2443 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3549; scrt1__24__car_2derror( X3 ); L3549: X2 = PAIR_CAR( X3 ); X4 = PAIR_CDR( e2443 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3554; scrt1__24__cdr_2derror( X4 ); L3554: X3 = PAIR_CDR( X4 ); X4 = miscexp_l2513( X3 ); X6 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X5 = CONS( scrt1_append_2dtwo( X3, X6 ), EMPTYLIST ); X5 = CONS( X2, X5 ); if ( FALSE( X4 ) ) goto L3577; X6 = c2509; goto L3590; L3577: X7 = scrt1_length( X3 ); if ( BITAND( BITOR( _S2CINT( X7 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L3581; if ( EQ( _S2CUINT( X7 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L3585; X6 = c2508; goto L3590; L3581: if ( TRUE( scrt2__3d_2dtwo( X7, _TSCP( 4 ) ) ) ) goto L3585; X6 = c2508; goto L3590; L3585: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3592; scrt1__24__car_2derror( X3 ); L3592: X8 = PAIR_CAR( X3 ); if ( NEQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3589; X9 = PAIR_CAR( X3 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L3598; scrt1__24__car_2derror( X9 ); L3598: X8 = PAIR_CAR( X9 ); if ( NEQ( _S2CUINT( X8 ), _S2CUINT( c2507 ) ) ) goto L3594; X6 = c2507; goto L3590; L3594: X6 = c2508; goto L3590; L3589: X6 = c2508; L3590: POPSTACKTRACE( scrt1_cons_2a( c2470, CONS( X6, X5 ) ) ); L3600: if ( EQ( TSCPTAG( e2443 ), PAIRTAG ) ) goto L3602; scrt1__24__car_2derror( e2443 ); L3602: X2 = PAIR_CAR( e2443 ); X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( X2, e2443, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( miscexp__24lap_3f_v ); DEFCSTRING( t3604, "$LAP?" ); TSCP miscexp__24lap_3f( x2565 ) TSCP x2565; { TSCP X1; PUSHSTACKTRACE( t3604 ); if ( NEQ( TSCPTAG( x2565 ), PAIRTAG ) ) goto L3606; X1 = PAIR_CAR( x2565 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2470 ) ) ) ); L3606: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( miscexp__24lap_2dtype_v ); DEFCSTRING( t3609, "$LAP-TYPE" ); TSCP miscexp__24lap_2dtype( x2583 ) TSCP x2583; { TSCP X2, X1; PUSHSTACKTRACE( t3609 ); if ( NEQ( TSCPTAG( x2583 ), PAIRTAG ) ) goto L3611; X2 = PAIR_CAR( x2583 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2470 ) ) ); goto L3612; L3611: X1 = FALSEVALUE; L3612: if ( FALSE( X1 ) ) goto L3615; if ( EQ( TSCPTAG( x2583 ), PAIRTAG ) ) goto L3618; scrt1__24__cdr_2derror( x2583 ); L3618: X2 = PAIR_CDR( x2583 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3621; scrt1__24__car_2derror( X2 ); L3621: POPSTACKTRACE( PAIR_CAR( X2 ) ); L3615: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp__24lap_2dvars_v ); DEFCSTRING( t3623, "$LAP-VARS" ); TSCP miscexp__24lap_2dvars( x2617 ) TSCP x2617; { TSCP X2, X1; PUSHSTACKTRACE( t3623 ); if ( NEQ( TSCPTAG( x2617 ), PAIRTAG ) ) goto L3625; X2 = PAIR_CAR( x2617 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2470 ) ) ); goto L3626; L3625: X1 = FALSEVALUE; L3626: if ( FALSE( X1 ) ) goto L3629; POPSTACKTRACE( scrt1_caddr( x2617 ) ); L3629: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp__24lap_2dbody_v ); DEFCSTRING( t3631, "$LAP-BODY" ); TSCP miscexp__24lap_2dbody( x2641 ) TSCP x2641; { TSCP X2, X1; PUSHSTACKTRACE( t3631 ); if ( NEQ( TSCPTAG( x2641 ), PAIRTAG ) ) goto L3633; X2 = PAIR_CAR( x2641 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2470 ) ) ); goto L3634; L3633: X1 = FALSEVALUE; L3634: if ( FALSE( X1 ) ) goto L3637; POPSTACKTRACE( scrt1_cdddr( x2641 ) ); L3637: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp__2dbody_21_c6f79d45_v ); DEFCSTRING( t3639, "SET-$LAP-BODY!" ); TSCP miscexp__2dbody_21_c6f79d45( e2665, b2666 ) TSCP e2665, b2666; { TSCP X2, X1; PUSHSTACKTRACE( t3639 ); if ( EQ( TSCPTAG( e2665 ), PAIRTAG ) ) goto L3642; scrt1__24__cdr_2derror( e2665 ); L3642: X2 = PAIR_CDR( e2665 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3645; scrt1__24__cdr_2derror( X2 ); L3645: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3648; scdebug_error( c2430, c2343, CONS( X1, EMPTYLIST ) ); L3648: POPSTACKTRACE( SETGEN( PAIR_CDR( X1 ), b2666 ) ); } DEFTSCP( miscexp_quote_2dexp_v ); DEFCSTRING( t3650, "QUOTE-EXP" ); EXTERNTSCP( sc_emptystring ); EXTERNTSCP( sc_emptyvector ); TSCP miscexp_quote_2dexp( e2687, e2688 ) TSCP e2687, e2688; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3650 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( e2687, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L3652; if ( EQ( TSCPTAG( e2687 ), PAIRTAG ) ) goto L3655; scrt1__24__cdr_2derror( e2687 ); L3655: X2 = PAIR_CDR( e2687 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3658; scrt1__24__car_2derror( X2 ); L3658: X1 = PAIR_CAR( X2 ); X2 = miscexp_2dconstant_109f5a09( X1, c2107 ); if ( TRUE( X2 ) ) goto L3662; if ( EQ( _S2CUINT( X1 ), _S2CUINT( TRUEVALUE ) ) ) goto L3664; if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3666; if ( EQ( _S2CUINT( X1 ), _S2CUINT( FALSEVALUE ) ) ) goto L3668; if ( FALSE( scrt1_equal_3f( X1, sc_emptystring ) ) ) goto L3670; X3 = SYMBOL_VALUE( bound_v ); X3 = UNKNOWNCALL( X3, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X3 ) )( c2714, PROCEDURE_CLOSURE( X3 ) ) ); L3670: if ( FALSE( scrt1_equal_3f( X1, sc_emptyvector ) ) ) goto L3672; X3 = SYMBOL_VALUE( bound_v ); X3 = UNKNOWNCALL( X3, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X3 ) )( c2713, PROCEDURE_CLOSURE( X3 ) ) ); L3672: X4 = SYMBOL_VALUE( newv_v ); X4 = UNKNOWNCALL( X4, 5 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( c2709, c2710, c2107, c2711, X1, PROCEDURE_CLOSURE( X4 ) ); X6 = sc_cons( X3, EMPTYLIST ); X5 = sc_cons( X1, X6 ); X4 = X5; miscexp_quote_2dconstants_v = sc_cons( X4, miscexp_quote_2dconstants_v ); POPSTACKTRACE( X3 ); L3668: POPSTACKTRACE( SYMBOL_VALUE( false_2dalpha_v ) ); L3666: POPSTACKTRACE( SYMBOL_VALUE( empty_2dlist_2dalpha_v ) ); L3664: POPSTACKTRACE( SYMBOL_VALUE( true_2dalpha_v ) ); L3662: POPSTACKTRACE( X2 ); L3652: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2690, e2687, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( miscexp_set_21_2dexp_v ); DEFCSTRING( t3676, "SET!-EXP" ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); TSCP miscexp_set_21_2dexp( e2730, e2731 ) TSCP e2730, e2731; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3676 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2730, _TSCP( 12 ), _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3700; if ( EQ( TSCPTAG( e2730 ), PAIRTAG ) ) goto L3685; scrt1__24__cdr_2derror( e2730 ); L3685: X3 = PAIR_CDR( e2730 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3688; scrt1__24__car_2derror( X3 ); L3688: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3700; X4 = scrt1_caddr( e2730 ); X3 = e2731; X3 = UNKNOWNCALL( X3, 2 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( X4, e2731, PROCEDURE_CLOSURE( X3 ) ); X6 = PAIR_CDR( e2730 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3692; scrt1__24__car_2derror( X6 ); L3692: X5 = PAIR_CAR( X6 ); X4 = e2731; X4 = UNKNOWNCALL( X4, 2 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( X5, e2731, PROCEDURE_CLOSURE( X4 ) ); X6 = SYMBOL_VALUE( id_2dset_21_v ); X6 = UNKNOWNCALL( X6, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X6 ) )( X3, PROCEDURE_CLOSURE( X6 ) ) ) ) goto L3695; X7 = SYMBOL_VALUE( id_2dset_21_v ); X7 = UNKNOWNCALL( X7, 1 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( X3, PROCEDURE_CLOSURE( X7 ) ); if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X6 ) ), 3 ) ) goto L3698; X5 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X6 ) ) ); goto L3696; L3698: X5 = scrt2__2b_2dtwo( _TSCP( 4 ), X6 ); goto L3696; L3695: X5 = _TSCP( 4 ); L3696: X4 = SYMBOL_VALUE( set_2did_2dset_21_21_v ); X4 = UNKNOWNCALL( X4, 2 ); VIA( PROCEDURE_CODE( X4 ) )( X3, X5, PROCEDURE_CLOSURE( X4 ) ); X4 = CONS( EMPTYLIST, EMPTYLIST ); X4 = CONS( X2, X4 ); POPSTACKTRACE( scrt1_cons_2a( c2225, CONS( X3, X4 ) ) ); L3700: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2509, e2730, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( miscexp__24set_3f_v ); DEFCSTRING( t3701, "$SET?" ); TSCP miscexp__24set_3f( x2770 ) TSCP x2770; { TSCP X1; PUSHSTACKTRACE( t3701 ); if ( NEQ( TSCPTAG( x2770 ), PAIRTAG ) ) goto L3703; X1 = PAIR_CAR( x2770 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2225 ) ) ) ); L3703: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( miscexp__24set_2did_v ); DEFCSTRING( t3706, "$SET-ID" ); TSCP miscexp__24set_2did( x2788 ) TSCP x2788; { TSCP X2, X1; PUSHSTACKTRACE( t3706 ); if ( NEQ( TSCPTAG( x2788 ), PAIRTAG ) ) goto L3708; X2 = PAIR_CAR( x2788 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2225 ) ) ); goto L3709; L3708: X1 = FALSEVALUE; L3709: if ( FALSE( X1 ) ) goto L3712; if ( EQ( TSCPTAG( x2788 ), PAIRTAG ) ) goto L3715; scrt1__24__cdr_2derror( x2788 ); L3715: X2 = PAIR_CDR( x2788 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3718; scrt1__24__car_2derror( X2 ); L3718: POPSTACKTRACE( PAIR_CAR( X2 ) ); L3712: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp__24set_2dexp_v ); DEFCSTRING( t3720, "$SET-EXP" ); TSCP miscexp__24set_2dexp( x2822 ) TSCP x2822; { TSCP X2, X1; PUSHSTACKTRACE( t3720 ); if ( NEQ( TSCPTAG( x2822 ), PAIRTAG ) ) goto L3722; X2 = PAIR_CAR( x2822 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2225 ) ) ); goto L3723; L3722: X1 = FALSEVALUE; L3723: if ( FALSE( X1 ) ) goto L3726; POPSTACKTRACE( scrt1_caddr( x2822 ) ); L3726: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp_set_2d_24set_2dexp_21_v ); DEFCSTRING( t3728, "SET-$SET-EXP!" ); TSCP miscexp_set_2d_24set_2dexp_21( x2846, e2847 ) TSCP x2846, e2847; { TSCP X2, X1; PUSHSTACKTRACE( t3728 ); if ( EQ( TSCPTAG( x2846 ), PAIRTAG ) ) goto L3731; scrt1__24__cdr_2derror( x2846 ); L3731: X2 = PAIR_CDR( x2846 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3734; scrt1__24__cdr_2derror( X2 ); L3734: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3737; scdebug_error( c2342, c2343, CONS( X1, EMPTYLIST ) ); L3737: POPSTACKTRACE( SETGEN( PAIR_CAR( X1 ), e2847 ) ); } DEFTSCP( miscexp_if_2dexp_v ); DEFCSTRING( t3739, "IF-EXP" ); EXTERNTSCPP( scrt1_cadddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadddr_v ); TSCP miscexp_if_2dexp( e2868, e2869 ) TSCP e2868, e2869; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3739 ); X4 = SYMBOL_VALUE( islist_v ); X4 = UNKNOWNCALL( X4, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X4 ) )( e2868, _TSCP( 12 ), _TSCP( 16 ), PROCEDURE_CLOSURE( X4 ) ) ) ) goto L3741; if ( FALSE( scrt1_cdddr( e2868 ) ) ) goto L3743; X1 = scrt1_cadddr( e2868 ); goto L3744; L3743: X1 = FALSEVALUE; L3744: X2 = scrt1_caddr( e2868 ); if ( EQ( TSCPTAG( e2868 ), PAIRTAG ) ) goto L3746; scrt1__24__cdr_2derror( e2868 ); L3746: X6 = PAIR_CDR( e2868 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3749; scrt1__24__car_2derror( X6 ); L3749: X5 = PAIR_CAR( X6 ); X4 = e2869; X4 = UNKNOWNCALL( X4, 2 ); X3 = VIA( PROCEDURE_CODE( X4 ) )( X5, e2869, PROCEDURE_CLOSURE( X4 ) ); X4 = BOOLEAN( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ); if ( FALSE( X4 ) ) goto L3760; X6 = SYMBOL_VALUE( id_2duse_v ); X6 = UNKNOWNCALL( X6, 1 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( X3, PROCEDURE_CLOSURE( X6 ) ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2107 ) ) ) goto L3760; X5 = SYMBOL_VALUE( id_2dvalue_v ); X5 = UNKNOWNCALL( X5, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X5 ) )( X3, PROCEDURE_CLOSURE( X5 ) ) ) ) goto L3758; X5 = e2869; X5 = UNKNOWNCALL( X5, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X5 ) )( X2, e2869, PROCEDURE_CLOSURE( X5 ) ) ); L3758: X5 = e2869; X5 = UNKNOWNCALL( X5, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X5 ) )( X1, e2869, PROCEDURE_CLOSURE( X5 ) ) ); L3741: X4 = SYMBOL_VALUE( expand_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X4 ) )( c2871, e2868, PROCEDURE_CLOSURE( X4 ) ) ); L3760: X4 = CONS( EMPTYLIST, EMPTYLIST ); X5 = e2869; X5 = UNKNOWNCALL( X5, 2 ); X4 = CONS( VIA( PROCEDURE_CODE( X5 ) )( X1, e2869, PROCEDURE_CLOSURE( X5 ) ), X4 ); X5 = e2869; X5 = UNKNOWNCALL( X5, 2 ); X4 = CONS( VIA( PROCEDURE_CODE( X5 ) )( X2, e2869, PROCEDURE_CLOSURE( X5 ) ), X4 ); POPSTACKTRACE( scrt1_cons_2a( c2885, CONS( X3, X4 ) ) ); } DEFTSCP( miscexp__24if_3f_v ); DEFCSTRING( t3761, "$IF?" ); TSCP miscexp__24if_3f( x2899 ) TSCP x2899; { TSCP X1; PUSHSTACKTRACE( t3761 ); if ( NEQ( TSCPTAG( x2899 ), PAIRTAG ) ) goto L3763; X1 = PAIR_CAR( x2899 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c2885 ) ) ) ); L3763: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( miscexp__24if_2dtest_v ); DEFCSTRING( t3766, "$IF-TEST" ); TSCP miscexp__24if_2dtest( x2917 ) TSCP x2917; { TSCP X2, X1; PUSHSTACKTRACE( t3766 ); if ( NEQ( TSCPTAG( x2917 ), PAIRTAG ) ) goto L3768; X2 = PAIR_CAR( x2917 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2885 ) ) ); goto L3769; L3768: X1 = FALSEVALUE; L3769: if ( FALSE( X1 ) ) goto L3772; if ( EQ( TSCPTAG( x2917 ), PAIRTAG ) ) goto L3775; scrt1__24__cdr_2derror( x2917 ); L3775: X2 = PAIR_CDR( x2917 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3778; scrt1__24__car_2derror( X2 ); L3778: POPSTACKTRACE( PAIR_CAR( X2 ) ); L3772: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp_set_2d_24if_2dtest_21_v ); DEFCSTRING( t3780, "SET-$IF-TEST!" ); TSCP miscexp_set_2d_24if_2dtest_21( x2951, t2952 ) TSCP x2951, t2952; { TSCP X1; PUSHSTACKTRACE( t3780 ); if ( EQ( TSCPTAG( x2951 ), PAIRTAG ) ) goto L3783; scrt1__24__cdr_2derror( x2951 ); L3783: X1 = PAIR_CDR( x2951 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3786; scdebug_error( c2342, c2343, CONS( X1, EMPTYLIST ) ); L3786: POPSTACKTRACE( SETGEN( PAIR_CAR( X1 ), t2952 ) ); } DEFTSCP( miscexp__24if_2dtrue_v ); DEFCSTRING( t3788, "$IF-TRUE" ); TSCP miscexp__24if_2dtrue( x2967 ) TSCP x2967; { TSCP X2, X1; PUSHSTACKTRACE( t3788 ); if ( NEQ( TSCPTAG( x2967 ), PAIRTAG ) ) goto L3790; X2 = PAIR_CAR( x2967 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2885 ) ) ); goto L3791; L3790: X1 = FALSEVALUE; L3791: if ( FALSE( X1 ) ) goto L3794; POPSTACKTRACE( scrt1_caddr( x2967 ) ); L3794: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp_set_2d_24if_2dtrue_21_v ); DEFCSTRING( t3796, "SET-$IF-TRUE!" ); TSCP miscexp_set_2d_24if_2dtrue_21( x2991, v2992 ) TSCP x2991, v2992; { TSCP X2, X1; PUSHSTACKTRACE( t3796 ); if ( EQ( TSCPTAG( x2991 ), PAIRTAG ) ) goto L3799; scrt1__24__cdr_2derror( x2991 ); L3799: X2 = PAIR_CDR( x2991 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3802; scrt1__24__cdr_2derror( X2 ); L3802: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3805; scdebug_error( c2342, c2343, CONS( X1, EMPTYLIST ) ); L3805: POPSTACKTRACE( SETGEN( PAIR_CAR( X1 ), v2992 ) ); } DEFTSCP( miscexp__24if_2dfalse_v ); DEFCSTRING( t3807, "$IF-FALSE" ); TSCP miscexp__24if_2dfalse( x3013 ) TSCP x3013; { TSCP X2, X1; PUSHSTACKTRACE( t3807 ); if ( NEQ( TSCPTAG( x3013 ), PAIRTAG ) ) goto L3809; X2 = PAIR_CAR( x3013 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c2885 ) ) ); goto L3810; L3809: X1 = FALSEVALUE; L3810: if ( FALSE( X1 ) ) goto L3813; POPSTACKTRACE( scrt1_cadddr( x3013 ) ); L3813: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp_2dfalse_21_a223c70f_v ); DEFCSTRING( t3815, "SET-$IF-FALSE!" ); TSCP miscexp_2dfalse_21_a223c70f( x3037, v3038 ) TSCP x3037, v3038; { TSCP X1; PUSHSTACKTRACE( t3815 ); X1 = scrt1_cdddr( x3037 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3818; scdebug_error( c2342, c2343, CONS( X1, EMPTYLIST ) ); L3818: POPSTACKTRACE( SETGEN( PAIR_CAR( X1 ), v3038 ) ); } DEFTSCP( miscexp_define_2dexp_v ); DEFCSTRING( t3820, "DEFINE-EXP" ); EXTERNTSCPP( scrt1_caadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caadr_v ); TSCP miscexp_define_2dexp( e3049, e3050 ) TSCP e3049, e3050; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3820 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e3049, _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3848; if ( EQ( TSCPTAG( e3049 ), PAIRTAG ) ) goto L3830; scrt1__24__cdr_2derror( e3049 ); L3830: X3 = PAIR_CDR( e3049 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3833; scrt1__24__car_2derror( X3 ); L3833: X2 = PAIR_CAR( X3 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) goto L3835; if ( EQ( TSCPTAG( e3049 ), PAIRTAG ) ) goto L3840; scrt1__24__cdr_2derror( e3049 ); L3840: X3 = PAIR_CDR( e3049 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3843; scrt1__24__car_2derror( X3 ); L3843: X2 = PAIR_CAR( X3 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3848; X2 = scrt1_caadr( e3049 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3848; L3835: X2 = PAIR_CDR( e3049 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3851; scrt1__24__car_2derror( X2 ); L3851: X1 = PAIR_CAR( X2 ); X3 = PAIR_CDR( e3049 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3856; scrt1__24__cdr_2derror( X3 ); L3856: X2 = PAIR_CDR( X3 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3859; X3 = PAIR_CAR( X1 ); goto L3860; L3859: X3 = X1; L3860: X3 = CONS( X3, EMPTYLIST ); SETGENTL( SYMBOL_VALUE( current_2ddefine_2dname_v ), PAIR_CAR( X3 ) ); X6 = SYMBOL_VALUE( module_2dname_v ); X5 = SYMBOL_VALUE( newv_v ); X5 = UNKNOWNCALL( X5, 7 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( PAIR_CAR( X3 ), c2710, c3097, c3098, X6, c3100, TRUEVALUE, PROCEDURE_CLOSURE( X5 ) ); SETGEN( PAIR_CAR( X3 ), X4 ); X4 = SYMBOL_VALUE( assign_2dknown_2dname_v ); X4 = UNKNOWNCALL( X4, 1 ); VIA( PROCEDURE_CODE( X4 ) )( PAIR_CAR( X3 ), PROCEDURE_CLOSURE( X4 ) ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3863; X4 = CONS( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( EMPTYLIST, EMPTYLIST ); X7 = CONS( scrt1_append_2dtwo( X2, X8 ), EMPTYLIST ); X6 = scrt1_cons_2a( c3109, CONS( PAIR_CDR( X1 ), X7 ) ); X5 = e3050; X5 = UNKNOWNCALL( X5, 2 ); X4 = CONS( VIA( PROCEDURE_CODE( X5 ) )( X6, e3050, PROCEDURE_CLOSURE( X5 ) ), X4 ); POPSTACKTRACE( scrt1_cons_2a( c3104, CONS( PAIR_CAR( X3 ), X4 ) ) ); L3863: X4 = CONS( EMPTYLIST, EMPTYLIST ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3867; scrt1__24__car_2derror( X2 ); L3867: X6 = PAIR_CAR( X2 ); X5 = e3050; X5 = UNKNOWNCALL( X5, 2 ); X4 = CONS( VIA( PROCEDURE_CODE( X5 ) )( X6, e3050, PROCEDURE_CLOSURE( X5 ) ), X4 ); POPSTACKTRACE( scrt1_cons_2a( c3104, CONS( PAIR_CAR( X3 ), X4 ) ) ); L3848: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c3089, e3049, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( miscexp__24define_3f_v ); DEFCSTRING( t3869, "$DEFINE?" ); TSCP miscexp__24define_3f( x3142 ) TSCP x3142; { TSCP X1; PUSHSTACKTRACE( t3869 ); if ( NEQ( TSCPTAG( x3142 ), PAIRTAG ) ) goto L3871; X1 = PAIR_CAR( x3142 ); POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( c3104 ) ) ) ); L3871: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( miscexp__24define_2did_v ); DEFCSTRING( t3874, "$DEFINE-ID" ); TSCP miscexp__24define_2did( x3160 ) TSCP x3160; { TSCP X2, X1; PUSHSTACKTRACE( t3874 ); if ( NEQ( TSCPTAG( x3160 ), PAIRTAG ) ) goto L3876; X2 = PAIR_CAR( x3160 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c3104 ) ) ); goto L3877; L3876: X1 = FALSEVALUE; L3877: if ( FALSE( X1 ) ) goto L3880; if ( EQ( TSCPTAG( x3160 ), PAIRTAG ) ) goto L3883; scrt1__24__cdr_2derror( x3160 ); L3883: X2 = PAIR_CDR( x3160 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3886; scrt1__24__car_2derror( X2 ); L3886: POPSTACKTRACE( PAIR_CAR( X2 ) ); L3880: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp__24define_2dexp_v ); DEFCSTRING( t3888, "$DEFINE-EXP" ); TSCP miscexp__24define_2dexp( x3194 ) TSCP x3194; { TSCP X2, X1; PUSHSTACKTRACE( t3888 ); if ( NEQ( TSCPTAG( x3194 ), PAIRTAG ) ) goto L3890; X2 = PAIR_CAR( x3194 ); X1 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( c3104 ) ) ); goto L3891; L3890: X1 = FALSEVALUE; L3891: if ( FALSE( X1 ) ) goto L3894; POPSTACKTRACE( scrt1_caddr( x3194 ) ); L3894: POPSTACKTRACE( X1 ); } DEFTSCP( miscexp_e_2dexp_21_7e57cd5d_v ); DEFCSTRING( t3896, "SET-$DEFINE-EXP!" ); TSCP miscexp_e_2dexp_21_7e57cd5d( x3218, e3219 ) TSCP x3218, e3219; { TSCP X2, X1; PUSHSTACKTRACE( t3896 ); if ( EQ( TSCPTAG( x3218 ), PAIRTAG ) ) goto L3899; scrt1__24__cdr_2derror( x3218 ); L3899: X2 = PAIR_CDR( x3218 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3902; scrt1__24__cdr_2derror( X2 ); L3902: X1 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3905; scdebug_error( c2342, c2343, CONS( X1, EMPTYLIST ) ); L3905: POPSTACKTRACE( SETGEN( PAIR_CAR( X1 ), e3219 ) ); } void scrt2__init(); void scdebug__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt2__init(); scdebug__init(); scrt1__init(); MAXDISPLAY( 0 ); } void miscexp__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(miscexp SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3329, ADR( miscexp_quote_2dconstants_v ), EMPTYLIST ); INITIALIZEVAR( t3330, ADR( miscexp_2dconstant_109f5a09_v ), MAKEPROCEDURE( 2, 0, miscexp_2dconstant_109f5a09, EMPTYLIST ) ); INITIALIZEVAR( t3356, ADR( miscexp_call_2dexp_v ), MAKEPROCEDURE( 2, 0, miscexp_call_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t3425, ADR( miscexp_letrec_2dlambdas_v ), MAKEPROCEDURE( 2, 0, miscexp_letrec_2dlambdas, EMPTYLIST ) ); INITIALIZEVAR( t3460, ADR( miscexp_call_2dexp_2dcons_v ), MAKEPROCEDURE( 1, 0, miscexp_call_2dexp_2dcons, EMPTYLIST ) ); INITIALIZEVAR( t3468, ADR( miscexp__24call_3f_v ), MAKEPROCEDURE( 1, 0, miscexp__24call_3f, EMPTYLIST ) ); INITIALIZEVAR( t3473, ADR( miscexp__24call_2dtail_v ), MAKEPROCEDURE( 1, 0, miscexp__24call_2dtail, EMPTYLIST ) ); INITIALIZEVAR( t3487, ADR( miscexp__2dtail_21_86d6576f_v ), MAKEPROCEDURE( 2, 0, miscexp__2dtail_21_86d6576f, EMPTYLIST ) ); INITIALIZEVAR( t3495, ADR( miscexp__24call_2dfunc_v ), MAKEPROCEDURE( 1, 0, miscexp__24call_2dfunc, EMPTYLIST ) ); INITIALIZEVAR( t3503, ADR( miscexp__2dfunc_21_4935643_v ), MAKEPROCEDURE( 2, 0, miscexp__2dfunc_21_4935643, EMPTYLIST ) ); INITIALIZEVAR( t3514, ADR( miscexp__24call_2dargl_v ), MAKEPROCEDURE( 1, 0, miscexp__24call_2dargl, EMPTYLIST ) ); INITIALIZEVAR( t3522, ADR( miscexp__2dargl_21_89422a52_v ), MAKEPROCEDURE( 2, 0, miscexp__2dargl_21_89422a52, EMPTYLIST ) ); INITIALIZEVAR( t3533, ADR( miscexp_lap_2dexp_v ), MAKEPROCEDURE( 2, 0, miscexp_lap_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t3604, ADR( miscexp__24lap_3f_v ), MAKEPROCEDURE( 1, 0, miscexp__24lap_3f, EMPTYLIST ) ); INITIALIZEVAR( t3609, ADR( miscexp__24lap_2dtype_v ), MAKEPROCEDURE( 1, 0, miscexp__24lap_2dtype, EMPTYLIST ) ); INITIALIZEVAR( t3623, ADR( miscexp__24lap_2dvars_v ), MAKEPROCEDURE( 1, 0, miscexp__24lap_2dvars, EMPTYLIST ) ); INITIALIZEVAR( t3631, ADR( miscexp__24lap_2dbody_v ), MAKEPROCEDURE( 1, 0, miscexp__24lap_2dbody, EMPTYLIST ) ); INITIALIZEVAR( t3639, ADR( miscexp__2dbody_21_c6f79d45_v ), MAKEPROCEDURE( 2, 0, miscexp__2dbody_21_c6f79d45, EMPTYLIST ) ); INITIALIZEVAR( t3650, ADR( miscexp_quote_2dexp_v ), MAKEPROCEDURE( 2, 0, miscexp_quote_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t3676, ADR( miscexp_set_21_2dexp_v ), MAKEPROCEDURE( 2, 0, miscexp_set_21_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t3701, ADR( miscexp__24set_3f_v ), MAKEPROCEDURE( 1, 0, miscexp__24set_3f, EMPTYLIST ) ); INITIALIZEVAR( t3706, ADR( miscexp__24set_2did_v ), MAKEPROCEDURE( 1, 0, miscexp__24set_2did, EMPTYLIST ) ); INITIALIZEVAR( t3720, ADR( miscexp__24set_2dexp_v ), MAKEPROCEDURE( 1, 0, miscexp__24set_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t3728, ADR( miscexp_set_2d_24set_2dexp_21_v ), MAKEPROCEDURE( 2, 0, miscexp_set_2d_24set_2dexp_21, EMPTYLIST ) ); INITIALIZEVAR( t3739, ADR( miscexp_if_2dexp_v ), MAKEPROCEDURE( 2, 0, miscexp_if_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t3761, ADR( miscexp__24if_3f_v ), MAKEPROCEDURE( 1, 0, miscexp__24if_3f, EMPTYLIST ) ); INITIALIZEVAR( t3766, ADR( miscexp__24if_2dtest_v ), MAKEPROCEDURE( 1, 0, miscexp__24if_2dtest, EMPTYLIST ) ); INITIALIZEVAR( t3780, ADR( miscexp_set_2d_24if_2dtest_21_v ), MAKEPROCEDURE( 2, 0, miscexp_set_2d_24if_2dtest_21, EMPTYLIST ) ); INITIALIZEVAR( t3788, ADR( miscexp__24if_2dtrue_v ), MAKEPROCEDURE( 1, 0, miscexp__24if_2dtrue, EMPTYLIST ) ); INITIALIZEVAR( t3796, ADR( miscexp_set_2d_24if_2dtrue_21_v ), MAKEPROCEDURE( 2, 0, miscexp_set_2d_24if_2dtrue_21, EMPTYLIST ) ); INITIALIZEVAR( t3807, ADR( miscexp__24if_2dfalse_v ), MAKEPROCEDURE( 1, 0, miscexp__24if_2dfalse, EMPTYLIST ) ); INITIALIZEVAR( t3815, ADR( miscexp_2dfalse_21_a223c70f_v ), MAKEPROCEDURE( 2, 0, miscexp_2dfalse_21_a223c70f, EMPTYLIST ) ); INITIALIZEVAR( t3820, ADR( miscexp_define_2dexp_v ), MAKEPROCEDURE( 2, 0, miscexp_define_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t3869, ADR( miscexp__24define_3f_v ), MAKEPROCEDURE( 1, 0, miscexp__24define_3f, EMPTYLIST ) ); INITIALIZEVAR( t3874, ADR( miscexp__24define_2did_v ), MAKEPROCEDURE( 1, 0, miscexp__24define_2did, EMPTYLIST ) ); INITIALIZEVAR( t3888, ADR( miscexp__24define_2dexp_v ), MAKEPROCEDURE( 1, 0, miscexp__24define_2dexp, EMPTYLIST ) ); INITIALIZEVAR( t3896, ADR( miscexp_e_2dexp_21_7e57cd5d_v ), MAKEPROCEDURE( 2, 0, miscexp_e_2dexp_21_7e57cd5d, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/miscexp.sc000066400000000000000000000217441203736146400165430ustar00rootroot00000000000000;;; The functions in this file expand those special forms which don't require ;;; gobs of code. The global variables that are visible outside this module ;;; include: ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module miscexp) ;;; External and in-line definitions. (include "plist.sch") (include "miscexp.sch") (define QUOTE-CONSTANTS '()) ; A-list for constants. ;;; Find a constant of the right type in QUOTE-CONSTANTS. (define (FIND-QUOTE-CONSTANT constant type) (let loop ((l quote-constants)) (if (pair? l) (let* ((const-var (car l)) (const (car const-var)) (var (cadr const-var))) (if (and (equal? const constant) (eq? (id-use var) type)) var (loop (cdr l)))) #f))) ;;; (f a b c) ==> ($call tail-call f' a' b' c') ;;; ;;; Expands a function call, where x' denotes x expanded by exp-func. The ;;; tail-call flag is set later on calls that could be tail recursive. ;;; Functions with are lambda expressions with optional arguments require ;;; special processing. This is done so TRANSFORM will only have to transform ;;; calls to lambda expressions with a fixed number of elements. Lambda ;;; variables which are bound to functions are also noted here. (define (CALL-EXP exp exp-func) (let* ((call (exp-func (car exp) exp-func)) (id (if ($lambda? call) ($lambda-id call) #f))) (cond (id (do ((vals (cdr exp) (cdr vals)) (vars (lambda-reqvars id) (cdr vars)) (opt (lambda-optvars id)) (newvars '()) (newvals '()) (const-bnd '())) ((or (null? vars) (not (pair? vals))) (if const-bnd (letrec-lambdas const-bnd ($lambda-body call))) (cond ((and (null? opt) (null? vals) (null? vars)) `($call () ,call ,@(reverse newvals))) ((and opt (islist vals 0)) (set-lambda-reqvars! id (reverse (cons (car opt) newvars))) (set-lambda-optvars! id '()) `($call () ,call ,@(reverse newvals) ,(exp-form (call-exp-cons vals) exp-func))) (else (expand-error 'call exp)))) (let ((var (car vars)) (val (exp-func (car vals) exp-func))) (set! newvars (cons var newvars)) (set! newvals (cons val newvals)) (if (and (symbol? val) (eq? (id-use val) 'constant)) (set! const-bnd (cons var const-bnd))) (if (and ($lambda? val) (not (id-set! var))) (name-a-lambda var val))))) (else (set! exp (cons call (exp-form-list (cdr exp) exp-func))) `($call () ,@exp))))) (define (LETREC-LAMBDAS vars exps) (if (pair? exps) (let ((var ($set-id (car exps))) (val ($set-exp (car exps)))) (if (memq var vars) (begin (if (and ($lambda? val) (eq? (id-set! var) 1)) (name-a-lambda var val)) (letrec-lambdas vars (cdr exps))))))) (define (CALL-EXP-CONS vals) (cond (vals `(cons ,(car vals) ,(call-exp-cons (cdr vals)))) (else ''()))) (define ($CALL? x) ($call? x)) (define ($CALL-TAIL x) ($call-tail x)) (define (SET-$CALL-TAIL! x v) (set-$call-tail! x v)) (define ($CALL-FUNC x) ($call-func x)) (define (SET-$CALL-FUNC! x f) (set-$call-func! x f)) (define ($CALL-ARGL x) ($call-argl x)) (define (SET-$CALL-ARGL! x al) (SET-$CALL-ARGL! x al)) ;;; The special form LAP allows the definition of "inline" C code. An inline ;;; function is called by: ;;; ;;; ((lap (vars ... ) ...) args ...) ;;; ;;; The arguments will be evaluated and then the values are substituted for ;;; the variables in the lap code. The form returns a tagged scheme pointer ;;; as its value. ;;; ;;; Unless the contains the macro SET, then it is assumed that the ;;; code does not change any cells. The macro BOOLEAN converts a C boolean ;;; into a Scheme boolean. When it is the outermost form, it allows some ;;; optimizing transforms. (define (LAP-EXP exp exp-func) (if (and (islist exp 3) (islist (cadr exp) 0)) (let* ((vars (cadr exp)) (body (cddr exp)) (set (let loop ((exp body)) (cond ((and (pair? exp) (eq? (car exp) 'set)) #t) ((pair? exp) (or (loop (car exp)) (loop (cdr exp)))) (else #f))))) `($lap ,(cond (set 'set) ((and (= (length body) 1) (pair? (car body)) (eq? (caar body) 'boolean)) 'boolean) (else 'read-only)) ,vars ,@body)) (expand-error (car exp) exp))) (define ($LAP? x) ($lap? x)) (define ($LAP-TYPE x) ($lap-type x)) (define ($LAP-VARS x) ($lap-vars x)) (define ($LAP-BODY x) ($lap-body x)) (define (SET-$LAP-BODY! exp body) (set-$lap-body! exp body)) ;;; (quote x) ==> const_ ;;; ;;; Quoted objects become constant variables. Multiple occurences of the same ;;; object will share the same variable. Note that some constants are ;;; globally defined so they get turned into a reference to that external ;;; variable. (define (QUOTE-EXP exp exp-func) (if (islist exp 2 2) (let* ((const (cadr exp)) (var (find-quote-constant const 'constant))) (cond (var var) ((eq? const '#t) true-alpha) ((eq? const '()) empty-list-alpha) ((eq? const '#f) false-alpha) ((equal? const "") (bound '$_empty-string)) ((equal? const '#()) (bound '$_empty-vector)) (else (let ((var (newv 'c 'use 'constant 'value const))) (set! quote-constants (cons (list const var) quote-constants)) var)))) (expand-error 'quote exp))) ;;; (set! x y) ==> ($set 'x 'y) ;;; ;;; Covert the arguments, set! is retained as a special form. (define (SET!-EXP exp exp-func) (if (and (islist exp 3 3) (symbol? (cadr exp))) (let ((var (exp-func (cadr exp) exp-func)) (value (exp-func (caddr exp) exp-func))) (set-id-set!! var (if (id-set! var) (+ 1 (id-set! var)) 1)) `($set ,var ,value)) (expand-error 'set exp))) (define ($SET? x) ($SET? x)) (define ($SET-ID x) ($SET-ID x)) (define ($SET-EXP x) ($SET-EXP x)) (define (SET-$SET-EXP! x e) (SET-$SET-EXP! x e)) ;;; (if a b [ c ]) ==> ($if a' b' c') ;;; ==> b' ;;; ==> c' ;;; ;;; Convert the arguments, if is retained as a special form. If the test ;;; turns out to be a constant expression, then only the appropriate leg of ;;; the if will be expanded and retained. (define (IF-EXP exp exp-func) (cond ((islist exp 3 4) (let ((test (exp-func (cadr exp) exp-func)) (true (caddr exp)) (false (if (cdddr exp) (cadddr exp) #f))) (cond ((and (symbol? test) (eq? (id-use test) 'constant)) (if (id-value test) (exp-func true exp-func) (exp-func false exp-func))) (else `($if ,test ,(exp-func true exp-func) ,(exp-func false exp-func)))))) (else (expand-error 'if exp)))) (define ($IF? x) ($if? x)) (define ($IF-TEST x)($if-test x)) (define (SET-$IF-TEST! x test) (set-$if-test! x test)) (define ($IF-TRUE x) ($if-true x)) (define (SET-$IF-TRUE! x v)(set-$if-true! x v)) (define ($IF-FALSE x) ($if-false x)) (define (SET-$IF-FALSE! x v) (set-$if-false! x v)) ;;; Defines come in two flavors: ;;; ;;; (define (f x y ...) body ... ) defines a function. ;;; (define f body) defines a top-level variable. ;;; ;;; The first is converted to a lambda expression and then processed. The ;;; second processed as is. All forms end up as: ($define id body). (define (DEFINE-EXP exp exp-func) (if (and (islist exp 3) (or (symbol? (cadr exp)) (and (pair? (cadr exp)) (symbol? (caadr exp))))) (let* ((name (cadr exp)) (body (cddr exp)) (var (if (pair? name) (car name) name))) (set! current-define-name var) (set! var (newv var 'use 'global 'module module-name 'defined #t)) (assign-known-name var) (if (pair? name) `($define ,var ,(exp-func `(lambda ,(cdr name) ,@body) exp-func)) `($define ,var ,(exp-func (car body) exp-func)))) (expand-error 'define exp))) (define ($DEFINE? x) ($define? x)) (define ($DEFINE-ID x) ($define-id x)) (define ($DEFINE-EXP x) ($define-exp x)) (define (SET-$DEFINE-EXP! x e) (set-$define-exp! x e)) scheme2c-2012.10.14/scsc/miscexp.sch000066400000000000000000000032471203736146400167110ustar00rootroot00000000000000;;; External and in-line definitions for miscexp.sc (define-in-line ($CALL? x) (and (pair? x) (eq? (car x) '$call))) (define-in-line ($CALL-TAIL x) (and ($call? x) (cadr x))) (define-in-line (SET-$CALL-TAIL! x v) (set-car! (cdr x) v)) (define-in-line ($CALL-FUNC x) (and ($call? x) (caddr x))) (define-in-line (SET-$CALL-FUNC! x f) (set-car! (cddr x) f)) (define-in-line ($CALL-ARGL x) (and ($call? x) (cdddr x))) (define-in-line (SET-$CALL-ARGL! x al) (set-cdr! (cddr x) al)) (define-in-line ($LAP? x) (and (pair? x) (eq? (car x) '$lap))) (define-in-line ($LAP-TYPE x) (and ($lap? x) (cadr x))) (define-in-line ($LAP-VARS x) (and ($lap? x) (caddr x))) (define-in-line ($LAP-BODY x) (and ($lap? x) (cdddr x))) (define-in-line (SET-$LAP-BODY! exp body) (set-cdr! (cddr exp) body)) (define-in-line ($SET? x) (and (pair? x) (eq? (car x) '$set))) (define-in-line ($SET-ID x) (and ($set? x) (cadr x))) (define-in-line ($SET-EXP x) (and ($set? x) (caddr x))) (define-in-line (SET-$SET-EXP! x e) (set-car! (cddr x) e)) (define-in-line ($IF? x) (and (pair? x) (eq? (car x) '$if))) (define-in-line ($IF-TEST x) (and ($if? x) (cadr x))) (define-in-line (SET-$IF-TEST! x test) (set-car! (cdr x) test)) (define-in-line ($IF-TRUE x) (and ($if? x) (caddr x))) (define-in-line (SET-$IF-TRUE! x v) (set-car! (cddr x) v)) (define-in-line ($IF-FALSE x) (and ($if? x) (cadddr x))) (define-in-line (SET-$IF-FALSE! x v) (set-car! (cdddr x) v)) (define-in-line ($DEFINE? x) (and (pair? x) (eq? (car x) '$define))) (define-in-line ($DEFINE-ID x) (and ($define? x) (cadr x))) (define-in-line ($DEFINE-EXP x) (and ($define? x) (caddr x))) (define-in-line (SET-$DEFINE-EXP! x e) (set-car! (cddr x) e)) scheme2c-2012.10.14/scsc/plist.c000066400000000000000000000171051203736146400160370ustar00rootroot00000000000000 /* SCHEME->C */ #include void plist__init(); DEFSTATICTSCP( c2125 ); DEFSTATICTSCP( _2aobarray_2a_v ); DEFCSTRING( t2131, "Index is not in bounds: ~s" ); DEFSTATICTSCP( c2107 ); DEFCSTRING( t2132, "Argument is not an INTEGER: ~s" ); DEFSTATICTSCP( c2103 ); DEFCSTRING( t2133, "Argument is not a VECTOR: ~s" ); DEFSTATICTSCP( c2100 ); DEFSTATICTSCP( c2099 ); DEFCSTRING( t2134, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2030 ); DEFSTATICTSCP( c2029 ); DEFSTATICTSCP( c2013 ); static void init_constants() { c2125 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-LENGTH" ) ); CONSTANTEXP( ADR( c2125 ) ); _2aobarray_2a_v = STRINGTOSYMBOL( CSTRING_TSCP( "*OBARRAY*" ) ); CONSTANTEXP( ADR( _2aobarray_2a_v ) ); c2107 = CSTRING_TSCP( t2131 ); CONSTANTEXP( ADR( c2107 ) ); c2103 = CSTRING_TSCP( t2132 ); CONSTANTEXP( ADR( c2103 ) ); c2100 = CSTRING_TSCP( t2133 ); CONSTANTEXP( ADR( c2100 ) ); c2099 = STRINGTOSYMBOL( CSTRING_TSCP( "VECTOR-REF" ) ); CONSTANTEXP( ADR( c2099 ) ); c2030 = CSTRING_TSCP( t2134 ); CONSTANTEXP( ADR( c2030 ) ); c2029 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2029 ) ); c2013 = STRINGTOSYMBOL( CSTRING_TSCP( "SCC" ) ); CONSTANTEXP( ADR( c2013 ) ); } DEFTSCP( plist_get_v ); DEFCSTRING( t2135, "GET" ); EXTERNTSCPP( scrt1_assq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assq_v ); EXTERNTSCPP( scrt2_getprop, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2_getprop_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); TSCP plist_get( i2002, k2003 ) TSCP i2002, k2003; { TSCP X3, X2, X1; PUSHSTACKTRACE( t2135 ); X3 = scrt2_getprop( i2002, c2013 ); if ( FALSE( X3 ) ) goto L2138; X2 = X3; goto L2139; L2138: X2 = EMPTYLIST; L2139: X1 = scrt1_assq( k2003, X2 ); if ( FALSE( X1 ) ) goto L2141; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L2144; scrt1__24__cdr_2derror( X1 ); L2144: POPSTACKTRACE( PAIR_CDR( X1 ) ); L2141: POPSTACKTRACE( EMPTYLIST ); } DEFTSCP( plist_put_v ); DEFCSTRING( t2146, "PUT" ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt2_putprop, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt2_putprop_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); TSCP plist_put( i2017, k2018, v2019 ) TSCP i2017, k2018, v2019; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t2146 ); X2 = scrt2_getprop( i2017, c2013 ); if ( FALSE( X2 ) ) goto L2149; X1 = X2; goto L2150; L2149: X1 = EMPTYLIST; L2150: X2 = scrt1_assq( k2018, X1 ); if ( FALSE( X2 ) ) goto L2153; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L2156; scdebug_error( c2029, c2030, CONS( X2, EMPTYLIST ) ); L2156: SETGEN( PAIR_CDR( X2 ), v2019 ); goto L2154; L2153: X4 = sc_cons( k2018, v2019 ); X3 = sc_cons( X4, X1 ); scrt2_putprop( i2017, c2013, X3 ); L2154: POPSTACKTRACE( v2019 ); } DEFTSCP( plist_copy_2dplist_v ); DEFCSTRING( t2158, "COPY-PLIST" ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( plist_l2081, XAL1( TSCP ) ); TSCP plist_l2081( v2083 ) TSCP v2083; { TSCP X3, X2, X1; PUSHSTACKTRACE( "LOOP [inside COPY-PLIST]" ); if ( NEQ( TSCPTAG( v2083 ), PAIRTAG ) ) goto L2197; X2 = PAIR_CAR( v2083 ); X1 = plist_l2081( X2 ); X3 = PAIR_CDR( v2083 ); X2 = plist_l2081( X3 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L2197: POPSTACKTRACE( v2083 ); } TSCP plist_copy_2dplist( s2037, d2038 ) TSCP s2037, d2038; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t2158 ); X3 = SYMBOL_VALUE( _2aobarray_2a_v ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), VECTORTAG ) ) ) goto L2162; scdebug_error( c2125, c2100, CONS( X3, EMPTYLIST ) ); L2162: X2 = C_FIXED( VECTOR_LENGTH( X3 ) ); if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2165; X1 = _TSCP( IDIFFERENCE( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ) ); goto L2166; L2165: X1 = scrt2__2d_2dtwo( X2, _TSCP( 4 ) ); L2166: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( -4 ) ) ), 3 ) ) goto L2169; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( _TSCP( -4 ) ) ) ) goto L2173; POPSTACKTRACE( FALSEVALUE ); L2169: if ( FALSE( scrt2__3d_2dtwo( X1, _TSCP( -4 ) ) ) ) goto L2173; POPSTACKTRACE( FALSEVALUE ); L2173: X3 = SYMBOL_VALUE( _2aobarray_2a_v ); if ( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), VECTORTAG ) ) ) goto L2178; scdebug_error( c2099, c2100, CONS( X3, EMPTYLIST ) ); L2178: if ( EQ( TSCPTAG( X1 ), FIXNUMTAG ) ) goto L2180; scdebug_error( c2099, c2103, CONS( X1, EMPTYLIST ) ); L2180: if ( LT( _S2CUINT( FIXED_C( X1 ) ), _S2CUINT( VECTOR_LENGTH( X3 ) ) ) ) goto L2182; scdebug_error( c2099, c2107, CONS( X1, EMPTYLIST ) ); L2182: X2 = VECTOR_ELEMENT( X3, X1 ); X3 = X2; L2186: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L2187; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L2191; scrt1__24__car_2derror( X3 ); L2191: X4 = PAIR_CAR( X3 ); X6 = scrt2_getprop( X4, s2037 ); X5 = plist_l2081( X6 ); scrt2_putprop( X4, d2038, X5 ); X3 = PAIR_CDR( X3 ); GOBACK( L2186 ); L2187: if ( BITAND( BITOR( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L2202; X1 = _TSCP( IDIFFERENCE( _S2CINT( X1 ), _S2CINT( _TSCP( 4 ) ) ) ); GOBACK( L2166 ); L2202: X1 = scrt2__2d_2dtwo( X1, _TSCP( 4 ) ); GOBACK( L2166 ); } void scdebug__init(); void scrt2__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scdebug__init(); scrt2__init(); scrt1__init(); MAXDISPLAY( 0 ); } void plist__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(plist SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t2135, ADR( plist_get_v ), MAKEPROCEDURE( 2, 0, plist_get, EMPTYLIST ) ); INITIALIZEVAR( t2146, ADR( plist_put_v ), MAKEPROCEDURE( 3, 0, plist_put, EMPTYLIST ) ); INITIALIZEVAR( t2158, ADR( plist_copy_2dplist_v ), MAKEPROCEDURE( 2, 0, plist_copy_2dplist, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/plist.sc000066400000000000000000000042721203736146400162230ustar00rootroot00000000000000;;; The compilers "symbol table" is kept by recording an alist associated ;;; with each identifier under the key SCC. The function GET is used to ;;; access an item, and the function PUT is used to set an item. ;;; ;;; All property entries for all visible symbols (i.e. in *OBARRAY*) can be ;;; copied from one key to another by COPY-PLIST. This is used to save and ;;; restore initial values. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module plist) (define (GET id key) (let ((pl (assq key (or (getprop id 'scc) '())))) (if pl (cdr pl) '()))) (define (PUT id key value) (let* ((pl (or (getprop id 'scc) '())) (oldvalue (assq key pl))) (if oldvalue (set-cdr! oldvalue value) (putprop id 'scc (cons (cons key value) pl))) value)) (define (COPY-PLIST src-key dest-key) (do ((i (- (vector-length *obarray*) 1) (- i 1))) ((= i -1)) (for-each (lambda (var) (putprop var dest-key (let loop ((val (getprop var src-key))) (if (pair? val) (cons (loop (car val)) (loop (cdr val))) val)))) (vector-ref *obarray* i)))) scheme2c-2012.10.14/scsc/plist.sch000066400000000000000000000001721203736146400163660ustar00rootroot00000000000000;;; External declarations from plist.sc (define-external (GET id key) plist) (define-external (PUT id key value) plist) scheme2c-2012.10.14/scsc/readtext.c000066400000000000000000002101001203736146400165120ustar00rootroot00000000000000 /* SCHEME->C */ #include void readtext__init(); DEFSTATICTSCP( sc_2dsplice_v ); DEFSTATICTSCP( log_3f_v ); DEFSTATICTSCP( pretty_2dprint_2d_24tree_v ); DEFSTATICTSCP( sc_2dicode_v ); DEFSTATICTSCP( module_2dname_v ); DEFSTATICTSCP( sc_2dsource_2dname_v ); DEFSTATICTSCP( report_2dwarning_v ); DEFSTATICTSCP( sc_2dinput_v ); DEFSTATICTSCP( islist_v ); DEFSTATICTSCP( expand_2derror_v ); DEFSTATICTSCP( set_2dlambda_2dgenerate_21_v ); DEFSTATICTSCP( set_2dlambda_2dname_21_v ); DEFSTATICTSCP( _24lambda_2did_v ); DEFSTATICTSCP( exp_2dform_v ); DEFSTATICTSCP( hex28_v ); DEFSTATICTSCP( with_2dmodules_v ); DEFSTATICTSCP( set_2dlambda_2dreqvars_21_v ); DEFSTATICTSCP( set_2dlambda_2doptvars_21_v ); DEFSTATICTSCP( report_2derror_v ); DEFSTATICTSCP( sc_2dinclude_2ddirs_v ); DEFSTATICTSCP( module_2dname_2dupcase_v ); DEFSTATICTSCP( main_2dprogram_2dname_v ); DEFSTATICTSCP( top_2dlevel_2dsymbols_v ); DEFSTATICTSCP( heap_2dsize_v ); DEFSTATICTSCP( sc_2dinterpreter_v ); DEFCSTRING( t3311, "Illegal or duplicate MODULE clause" ); DEFSTATICTSCP( c3016 ); DEFSTATICTSCP( c3014 ); DEFSTATICTSCP( c2926 ); DEFSTATICTSCP( c2893 ); DEFCSTRING( t3312, "Argument is not a SYMBOL: ~s" ); DEFSTATICTSCP( c2833 ); DEFSTATICTSCP( c2832 ); DEFCSTRING( t3313, "MODULE name is already defined as:" ); DEFSTATICTSCP( c2816 ); DEFCSTRING( t3314, "Can't open INCLUDE file:" ); DEFSTATICTSCP( c2736 ); DEFSTATICTSCP( c2682 ); DEFSTATICTSCP( t3315 ); DEFSTATICTSCP( t3316 ); DEFSTATICTSCP( t3317 ); DEFSTATICTSCP( t3318 ); DEFSTATICTSCP( t3319 ); DEFSTATICTSCP( t3320 ); DEFSTATICTSCP( t3321 ); DEFSTATICTSCP( t3322 ); DEFSTATICTSCP( t3323 ); DEFSTATICTSCP( t3324 ); DEFSTATICTSCP( t3325 ); DEFSTATICTSCP( t3326 ); DEFSTATICTSCP( c2669 ); DEFSTATICTSCP( c2614 ); DEFCSTRING( t3327, "_v" ); DEFSTATICTSCP( c2520 ); DEFSTATICTSCP( c2518 ); DEFSTATICTSCP( c2502 ); DEFSTATICTSCP( c2497 ); DEFSTATICTSCP( c2496 ); DEFSTATICTSCP( c2495 ); DEFCSTRING( t3328, "_" ); DEFSTATICTSCP( c2494 ); DEFSTATICTSCP( c2394 ); DEFCSTRING( t3329, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2328 ); DEFSTATICTSCP( c2327 ); DEFSTATICTSCP( c2292 ); DEFSTATICTSCP( c2232 ); DEFSTATICTSCP( c2150 ); DEFSTATICTSCP( c2139 ); DEFCSTRING( t3330, "Module name defaults to:" ); DEFSTATICTSCP( c2136 ); DEFCSTRING( t3331, "Argument is not a STRING: ~s" ); DEFSTATICTSCP( c2133 ); DEFSTATICTSCP( c2132 ); DEFSTATICTSCP( c2110 ); DEFSTATICTSCP( c2077 ); DEFSTATICTSCP( c2073 ); DEFSTATICTSCP( c2069 ); DEFSTATICTSCP( c2065 ); DEFSTATICTSCP( c2061 ); DEFSTATICTSCP( c2057 ); DEFSTATICTSCP( c2053 ); DEFSTATICTSCP( c2035 ); static void init_constants() { sc_2dsplice_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-SPLICE" ) ); CONSTANTEXP( ADR( sc_2dsplice_v ) ); log_3f_v = STRINGTOSYMBOL( CSTRING_TSCP( "LOG?" ) ); CONSTANTEXP( ADR( log_3f_v ) ); pretty_2dprint_2d_24tree_v = STRINGTOSYMBOL( CSTRING_TSCP( "PRETTY-P\ RINT-$TREE" ) ); CONSTANTEXP( ADR( pretty_2dprint_2d_24tree_v ) ); sc_2dicode_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-ICODE" ) ); CONSTANTEXP( ADR( sc_2dicode_v ) ); module_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE-NAME" ) ); CONSTANTEXP( ADR( module_2dname_v ) ); sc_2dsource_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-SOURCE-NAME\ " ) ); CONSTANTEXP( ADR( sc_2dsource_2dname_v ) ); report_2dwarning_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-WARNING" ) ); CONSTANTEXP( ADR( report_2dwarning_v ) ); sc_2dinput_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-INPUT" ) ); CONSTANTEXP( ADR( sc_2dinput_v ) ); islist_v = STRINGTOSYMBOL( CSTRING_TSCP( "ISLIST" ) ); CONSTANTEXP( ADR( islist_v ) ); expand_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXPAND-ERROR" ) ); CONSTANTEXP( ADR( expand_2derror_v ) ); set_2dlambda_2dgenerate_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-LA\ MBDA-GENERATE!" ) ); CONSTANTEXP( ADR( set_2dlambda_2dgenerate_21_v ) ); set_2dlambda_2dname_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-LAMBDA\ -NAME!" ) ); CONSTANTEXP( ADR( set_2dlambda_2dname_21_v ) ); _24lambda_2did_v = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA-ID" ) ); CONSTANTEXP( ADR( _24lambda_2did_v ) ); exp_2dform_v = STRINGTOSYMBOL( CSTRING_TSCP( "EXP-FORM" ) ); CONSTANTEXP( ADR( exp_2dform_v ) ); hex28_v = STRINGTOSYMBOL( CSTRING_TSCP( "HEX28" ) ); CONSTANTEXP( ADR( hex28_v ) ); with_2dmodules_v = STRINGTOSYMBOL( CSTRING_TSCP( "WITH-MODULES" ) ); CONSTANTEXP( ADR( with_2dmodules_v ) ); set_2dlambda_2dreqvars_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-LAM\ BDA-REQVARS!" ) ); CONSTANTEXP( ADR( set_2dlambda_2dreqvars_21_v ) ); set_2dlambda_2doptvars_21_v = STRINGTOSYMBOL( CSTRING_TSCP( "SET-LAM\ BDA-OPTVARS!" ) ); CONSTANTEXP( ADR( set_2dlambda_2doptvars_21_v ) ); report_2derror_v = STRINGTOSYMBOL( CSTRING_TSCP( "REPORT-ERROR" ) ); CONSTANTEXP( ADR( report_2derror_v ) ); sc_2dinclude_2ddirs_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-INCLUDE-DI\ RS" ) ); CONSTANTEXP( ADR( sc_2dinclude_2ddirs_v ) ); module_2dname_2dupcase_v = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE-NAM\ E-UPCASE" ) ); CONSTANTEXP( ADR( module_2dname_2dupcase_v ) ); main_2dprogram_2dname_v = STRINGTOSYMBOL( CSTRING_TSCP( "MAIN-PROGRA\ M-NAME" ) ); CONSTANTEXP( ADR( main_2dprogram_2dname_v ) ); top_2dlevel_2dsymbols_v = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL-S\ YMBOLS" ) ); CONSTANTEXP( ADR( top_2dlevel_2dsymbols_v ) ); heap_2dsize_v = STRINGTOSYMBOL( CSTRING_TSCP( "HEAP-SIZE" ) ); CONSTANTEXP( ADR( heap_2dsize_v ) ); sc_2dinterpreter_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-INTERPRETER" ) ); CONSTANTEXP( ADR( sc_2dinterpreter_v ) ); c3016 = CSTRING_TSCP( t3311 ); CONSTANTEXP( ADR( c3016 ) ); c3014 = STRINGTOSYMBOL( CSTRING_TSCP( "WITH" ) ); CONSTANTEXP( ADR( c3014 ) ); c2926 = STRINGTOSYMBOL( CSTRING_TSCP( "HEAP" ) ); CONSTANTEXP( ADR( c2926 ) ); c2893 = STRINGTOSYMBOL( CSTRING_TSCP( "MAIN" ) ); CONSTANTEXP( ADR( c2893 ) ); c2833 = CSTRING_TSCP( t3312 ); CONSTANTEXP( ADR( c2833 ) ); c2832 = STRINGTOSYMBOL( CSTRING_TSCP( "SYMBOL->STRING" ) ); CONSTANTEXP( ADR( c2832 ) ); c2816 = CSTRING_TSCP( t3313 ); CONSTANTEXP( ADR( c2816 ) ); c2736 = CSTRING_TSCP( t3314 ); CONSTANTEXP( ADR( c2736 ) ); c2682 = EMPTYLIST; t3315 = STRINGTOSYMBOL( CSTRING_TSCP( "TSCP" ) ); c2682 = CONS( t3315, c2682 ); t3316 = STRINGTOSYMBOL( CSTRING_TSCP( "DOUBLE" ) ); c2682 = CONS( t3316, c2682 ); t3317 = STRINGTOSYMBOL( CSTRING_TSCP( "FLOAT" ) ); c2682 = CONS( t3317, c2682 ); t3318 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGUNSIGNED" ) ); c2682 = CONS( t3318, c2682 ); t3319 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTUNSIGNED" ) ); c2682 = CONS( t3319, c2682 ); t3320 = STRINGTOSYMBOL( CSTRING_TSCP( "UNSIGNED" ) ); c2682 = CONS( t3320, c2682 ); t3321 = STRINGTOSYMBOL( CSTRING_TSCP( "LONGINT" ) ); c2682 = CONS( t3321, c2682 ); t3322 = STRINGTOSYMBOL( CSTRING_TSCP( "SHORTINT" ) ); c2682 = CONS( t3322, c2682 ); t3323 = STRINGTOSYMBOL( CSTRING_TSCP( "INT" ) ); c2682 = CONS( t3323, c2682 ); t3324 = STRINGTOSYMBOL( CSTRING_TSCP( "CHAR" ) ); c2682 = CONS( t3324, c2682 ); t3325 = STRINGTOSYMBOL( CSTRING_TSCP( "ARRAY" ) ); c2682 = CONS( t3325, c2682 ); t3326 = STRINGTOSYMBOL( CSTRING_TSCP( "POINTER" ) ); c2682 = CONS( t3326, c2682 ); CONSTANTEXP( ADR( c2682 ) ); c2669 = STRINGTOSYMBOL( CSTRING_TSCP( "TYPE" ) ); CONSTANTEXP( ADR( c2669 ) ); c2614 = STRINGTOSYMBOL( CSTRING_TSCP( "VOID" ) ); CONSTANTEXP( ADR( c2614 ) ); c2520 = CSTRING_TSCP( t3327 ); CONSTANTEXP( ADR( c2520 ) ); c2518 = STRINGTOSYMBOL( CSTRING_TSCP( "VNAME" ) ); CONSTANTEXP( ADR( c2518 ) ); c2502 = STRINGTOSYMBOL( CSTRING_TSCP( "PROCEDURE" ) ); CONSTANTEXP( ADR( c2502 ) ); c2497 = STRINGTOSYMBOL( CSTRING_TSCP( "CNAME" ) ); CONSTANTEXP( ADR( c2497 ) ); c2496 = STRINGTOSYMBOL( CSTRING_TSCP( "GLOBAL" ) ); CONSTANTEXP( ADR( c2496 ) ); c2495 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c2495 ) ); c2494 = CSTRING_TSCP( t3328 ); CONSTANTEXP( ADR( c2494 ) ); c2394 = STRINGTOSYMBOL( CSTRING_TSCP( "TOP-LEVEL" ) ); CONSTANTEXP( ADR( c2394 ) ); c2328 = CSTRING_TSCP( t3329 ); CONSTANTEXP( ADR( c2328 ) ); c2327 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2327 ) ); c2292 = STRINGTOSYMBOL( CSTRING_TSCP( "*SC-APPLICATION-EXPANDER*" ) ); CONSTANTEXP( ADR( c2292 ) ); c2232 = STRINGTOSYMBOL( CSTRING_TSCP( "SOURCE" ) ); CONSTANTEXP( ADR( c2232 ) ); c2150 = STRINGTOSYMBOL( CSTRING_TSCP( "BEGIN" ) ); CONSTANTEXP( ADR( c2150 ) ); c2139 = STRINGTOSYMBOL( CSTRING_TSCP( "COMPILE" ) ); CONSTANTEXP( ADR( c2139 ) ); c2136 = CSTRING_TSCP( t3330 ); CONSTANTEXP( ADR( c2136 ) ); c2133 = CSTRING_TSCP( t3331 ); CONSTANTEXP( ADR( c2133 ) ); c2132 = STRINGTOSYMBOL( CSTRING_TSCP( "STRING-LENGTH" ) ); CONSTANTEXP( ADR( c2132 ) ); c2110 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); CONSTANTEXP( ADR( c2110 ) ); c2077 = STRINGTOSYMBOL( CSTRING_TSCP( "EVAL-WHEN" ) ); CONSTANTEXP( ADR( c2077 ) ); c2073 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-CONSTANT" ) ); CONSTANTEXP( ADR( c2073 ) ); c2069 = STRINGTOSYMBOL( CSTRING_TSCP( "INCLUDE" ) ); CONSTANTEXP( ADR( c2069 ) ); c2065 = STRINGTOSYMBOL( CSTRING_TSCP( "MODULE" ) ); CONSTANTEXP( ADR( c2065 ) ); c2061 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-MACRO" ) ); CONSTANTEXP( ADR( c2061 ) ); c2057 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-C-EXTERNAL" ) ); CONSTANTEXP( ADR( c2057 ) ); c2053 = STRINGTOSYMBOL( CSTRING_TSCP( "DEFINE-EXTERNAL" ) ); CONSTANTEXP( ADR( c2053 ) ); c2035 = STRINGTOSYMBOL( CSTRING_TSCP( "MACRO" ) ); CONSTANTEXP( ADR( c2035 ) ); } DEFTSCP( readtext_read_2dtext_v ); DEFCSTRING( t3332, "READ-TEXT" ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( readtext_sc_2dexpand, XAL1( TSCP ) ); EXTERNTSCP( readtext_sc_2dexpand_v ); EXTERNTSCPP( readtext_sc_2dinput_3d56933a, XAL0( ) ); EXTERNTSCP( readtext_sc_2dinput_3d56933a_v ); EXTERNTSCPP( scrt6_newline, XAL1( TSCP ) ); EXTERNTSCP( scrt6_newline_v ); EXTERNTSCPP( readtext_2dexternal_66fe3106, XAL1( TSCP ) ); EXTERNTSCP( readtext_2dexternal_66fe3106_v ); EXTERNTSCPP( readtext_2dexternal_7d8f1d02, XAL1( TSCP ) ); EXTERNTSCP( readtext_2dexternal_7d8f1d02_v ); EXTERNTSCPP( readtext_do_2dmodule, XAL1( TSCP ) ); EXTERNTSCP( readtext_do_2dmodule_v ); EXTERNTSCPP( readtext_do_2dinclude, XAL1( TSCP ) ); EXTERNTSCP( readtext_do_2dinclude_v ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( sceval_eval, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sceval_eval_v ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( scrt1_cadar, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadar_v ); EXTERNTSCPP( scrt1_append_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_append_2dtwo_v ); EXTERNTSCPP( scrt1_cddar, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cddar_v ); EXTERNTSCPP( scrt1_equal_3f, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_equal_3f_v ); EXTERNTSCP( sc_emptystring ); EXTERNTSCPP( scrt3_substring, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scrt3_substring_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt2__2d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2d_2dtwo_v ); TSCP readtext_read_2dtext( ) { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3332 ); L3333: X1 = EMPTYLIST; X1 = CONS( X1, EMPTYLIST ); if ( FALSE( SYMBOL_VALUE( sc_2dsplice_v ) ) ) goto L3335; X3 = SYMBOL_VALUE( sc_2dsplice_v ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3339; scrt1__24__car_2derror( X3 ); L3339: X2 = PAIR_CAR( X3 ); SETGEN( PAIR_CAR( X1 ), X2 ); X2 = SYMBOL_VALUE( sc_2dsplice_v ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3342; scrt1__24__cdr_2derror( X2 ); L3342: SETGENTL( SYMBOL_VALUE( sc_2dsplice_v ), PAIR_CDR( X2 ) ); goto L3345; L3335: X3 = readtext_sc_2dinput_3d56933a( ); X2 = readtext_sc_2dexpand( X3 ); SETGEN( PAIR_CAR( X1 ), X2 ); X2 = SYMBOL_VALUE( log_3f_v ); X2 = UNKNOWNCALL( X2, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X2 ) )( c2035, PROCEDURE_CLOSURE( X2 ) ) ) ) goto L3345; X3 = SYMBOL_VALUE( sc_2dicode_v ); X2 = SYMBOL_VALUE( pretty_2dprint_2d_24tree_v ); X2 = UNKNOWNCALL( X2, 2 ); VIA( PROCEDURE_CODE( X2 ) )( PAIR_CAR( X1 ), X3, PROCEDURE_CLOSURE( X2 ) ); scrt6_newline( CONS( SYMBOL_VALUE( sc_2dicode_v ), EMPTYLIST ) ); L3345: if ( NEQ( TSCPTAG( PAIR_CAR( X1 ) ), PAIRTAG ) ) goto L3348; X3 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3351; scrt1__24__car_2derror( X3 ); L3351: X2 = PAIR_CAR( X3 ); goto L3349; L3348: X2 = FALSEVALUE; L3349: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2053 ) ) ) goto L3354; readtext_2dexternal_66fe3106( PAIR_CAR( X1 ) ); GOBACK( L3333 ); L3354: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2057 ) ) ) goto L3357; readtext_2dexternal_7d8f1d02( PAIR_CAR( X1 ) ); GOBACK( L3333 ); L3357: if ( EQ( _S2CUINT( X2 ), _S2CUINT( c2061 ) ) ) GOBACK( L3333 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2065 ) ) ) goto L3362; readtext_do_2dmodule( PAIR_CAR( X1 ) ); GOBACK( L3333 ); L3362: if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2069 ) ) ) goto L3365; readtext_do_2dinclude( PAIR_CAR( X1 ) ); GOBACK( L3333 ); L3365: if ( EQ( _S2CUINT( X2 ), _S2CUINT( c2073 ) ) ) GOBACK( L3333 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2077 ) ) ) goto L3370; X4 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3377; scrt1__24__cdr_2derror( X4 ); L3377: X5 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3380; scrt1__24__car_2derror( X5 ); L3380: X3 = PAIR_CAR( X5 ); if ( FALSE( scrt1_memq( c2139, X3 ) ) ) GOBACK( L3333 ); X5 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3384; scrt1__24__cdr_2derror( X5 ); L3384: X6 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3387; scrt1__24__cdr_2derror( X6 ); L3387: X4 = PAIR_CDR( X6 ); X3 = sc_cons( c2150, X4 ); sceval_eval( X3, EMPTYLIST ); GOBACK( L3333 ); L3370: X3 = BOOLEAN( EQ( TSCPTAG( PAIR_CAR( X1 ) ), PAIRTAG ) ); if ( FALSE( X3 ) ) goto L3414; X5 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3397; scrt1__24__car_2derror( X5 ); L3397: X4 = PAIR_CAR( X5 ); if ( NEQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3414; X5 = PAIR_CAR( X1 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3404; scrt1__24__car_2derror( X5 ); L3404: X6 = PAIR_CAR( X5 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L3407; scrt1__24__car_2derror( X6 ); L3407: X4 = PAIR_CAR( X6 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2110 ) ) ) goto L3414; X4 = scrt1_cadar( PAIR_CAR( X1 ) ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3414; X4 = scrt1_cddar( PAIR_CAR( X1 ) ); X5 = SYMBOL_VALUE( sc_2dsplice_v ); SETGENTL( SYMBOL_VALUE( sc_2dsplice_v ), scrt1_append_2dtwo( X4, X5 ) ); GOBACK( L3333 ); L3414: X2 = SYMBOL_VALUE( module_2dname_v ); if ( FALSE( scrt1_equal_3f( X2, sc_emptystring ) ) ) goto L3416; X2 = SYMBOL_VALUE( sc_2dsource_2dname_v ); X5 = SYMBOL_VALUE( sc_2dsource_2dname_v ); if ( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), STRINGTAG ) ) ) goto L3420; scdebug_error( c2132, c2133, CONS( X5, EMPTYLIST ) ); L3420: X4 = C_FIXED( STRING_LENGTH( X5 ) ); if ( BITAND( BITOR( _S2CINT( X4 ), _S2CINT( _TSCP( 12 ) ) ), 3 ) ) goto L3423; X3 = _TSCP( IDIFFERENCE( _S2CINT( X4 ), _S2CINT( _TSCP( 12 ) ) ) ); goto L3424; L3423: X3 = scrt2__2d_2dtwo( X4, _TSCP( 12 ) ); L3424: SETGENTL( SYMBOL_VALUE( module_2dname_v ), scrt3_substring( X2, _TSCP( 0 ), X3 ) ); X3 = SYMBOL_VALUE( module_2dname_v ); X2 = SYMBOL_VALUE( report_2dwarning_v ); X2 = UNKNOWNCALL( X2, 2 ); VIA( PROCEDURE_CODE( X2 ) )( c2136, X3, PROCEDURE_CLOSURE( X2 ) ); L3416: POPSTACKTRACE( PAIR_CAR( X1 ) ); } DEFTSCP( readtext_sc_2dinput_3d56933a_v ); DEFCSTRING( t3425, "READ-FROM-SC-INPUT" ); EXTERNTSCPP( scrt6_read, XAL1( TSCP ) ); EXTERNTSCP( scrt6_read_v ); EXTERNTSCPP( scrt6_eof_2dobject_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt6_eof_2dobject_3f_v ); EXTERNTSCPP( scrt5_close_2dport, XAL1( TSCP ) ); EXTERNTSCP( scrt5_close_2dport_v ); TSCP readtext_sc_2dinput_3d56933a( ) { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3425 ); X2 = SYMBOL_VALUE( sc_2dinput_v ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3429; scrt1__24__car_2derror( X2 ); L3429: X1 = scrt6_read( CONS( PAIR_CAR( X2 ), EMPTYLIST ) ); L3431: X3 = scrt6_eof_2dobject_3f( X1 ); if ( FALSE( X3 ) ) goto L3433; X5 = SYMBOL_VALUE( sc_2dinput_v ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3436; scrt1__24__cdr_2derror( X5 ); L3436: X4 = PAIR_CDR( X5 ); X2 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ); goto L3434; L3433: X2 = X3; L3434: if ( TRUE( X2 ) ) goto L3442; if ( FALSE( scrt6_eof_2dobject_3f( X1 ) ) ) goto L3442; X4 = SYMBOL_VALUE( sc_2dinput_v ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3447; scrt1__24__car_2derror( X4 ); L3447: X3 = PAIR_CAR( X4 ); scrt5_close_2dport( X3 ); X3 = SYMBOL_VALUE( sc_2dinput_v ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3451; scrt1__24__cdr_2derror( X3 ); L3451: X4 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3454; scrt1__24__car_2derror( X4 ); L3454: SETGENTL( SYMBOL_VALUE( sc_2dsplice_v ), PAIR_CAR( X4 ) ); X3 = SYMBOL_VALUE( sc_2dinput_v ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3458; scrt1__24__cdr_2derror( X3 ); L3458: X4 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3461; scrt1__24__cdr_2derror( X4 ); L3461: SETGENTL( SYMBOL_VALUE( sc_2dinput_v ), PAIR_CDR( X4 ) ); X3 = SYMBOL_VALUE( sc_2dinput_v ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3464; scrt1__24__car_2derror( X3 ); L3464: X1 = scrt6_read( CONS( PAIR_CAR( X3 ), EMPTYLIST ) ); GOBACK( L3431 ); L3442: X2 = SYMBOL_VALUE( log_3f_v ); X2 = UNKNOWNCALL( X2, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X2 ) )( c2232, PROCEDURE_CLOSURE( X2 ) ) ) ) goto L3467; X3 = SYMBOL_VALUE( sc_2dicode_v ); X2 = SYMBOL_VALUE( pretty_2dprint_2d_24tree_v ); X2 = UNKNOWNCALL( X2, 2 ); VIA( PROCEDURE_CODE( X2 ) )( X1, X3, PROCEDURE_CLOSURE( X2 ) ); scrt6_newline( CONS( SYMBOL_VALUE( sc_2dicode_v ), EMPTYLIST ) ); L3467: POPSTACKTRACE( X1 ); } DEFTSCP( readtext_sc_2dexpand_v ); DEFCSTRING( t3470, "SC-EXPAND" ); EXTERNTSCPP( readtext_2dexpander_c83ee5f9, XAL2( TSCP, TSCP ) ); EXTERNTSCP( readtext_2dexpander_c83ee5f9_v ); TSCP readtext_sc_2dexpand( x2239 ) TSCP x2239; { PUSHSTACKTRACE( t3470 ); POPSTACKTRACE( readtext_2dexpander_c83ee5f9( x2239, readtext_2dexpander_c83ee5f9_v ) ); } DEFTSCP( readtext_2dexpander_c83ee5f9_v ); DEFCSTRING( t3472, "SC-INITIAL-EXPANDER" ); EXTERNTSCPP( readtext_xpander_2a_b26e591c, XAL2( TSCP, TSCP ) ); EXTERNTSCP( readtext_xpander_2a_b26e591c_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); EXTERNTSCPP( readtext_xpander_2a_afbc6f79, XAL2( TSCP, TSCP ) ); EXTERNTSCP( readtext_xpander_2a_afbc6f79_v ); TSCP readtext_l2265( x2266, e2267, c3485 ) TSCP x2266, e2267, c3485; { PUSHSTACKTRACE( "readtext_l2265 [inside SC-INITIAL-EXPANDER]" ); POPSTACKTRACE( x2266 ); } TSCP readtext_2dexpander_c83ee5f9( x2242, e2243 ) TSCP x2242, e2243; { TSCP X3, X2, X1; PUSHSTACKTRACE( t3472 ); if ( NOT( AND( EQ( TSCPTAG( x2242 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( x2242 ), SYMBOLTAG ) ) ) ) goto L3474; X1 = readtext_xpander_2a_b26e591c_v; goto L3477; L3474: if ( NEQ( TSCPTAG( x2242 ), PAIRTAG ) ) goto L3476; X2 = PAIR_CAR( x2242 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3478; X3 = PAIR_CAR( x2242 ); X2 = plist_get( X3, c2035 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), PROCEDURETAG ) ) ) ) goto L3483; X1 = X2; goto L3477; L3483: X1 = readtext_xpander_2a_afbc6f79_v; goto L3477; L3478: X1 = readtext_xpander_2a_afbc6f79_v; goto L3477; L3476: X1 = MAKEPROCEDURE( 2, 0, readtext_l2265, EMPTYLIST ); L3477: X2 = X1; X2 = UNKNOWNCALL( X2, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X2 ) )( x2242, e2243, PROCEDURE_CLOSURE( X2 ) ) ); } DEFTSCP( readtext_sc_2dexpand_2donce_v ); DEFCSTRING( t3488, "SC-EXPAND-ONCE" ); TSCP readtext_l2272( x2273, e2274, c3490 ) TSCP x2273, e2274, c3490; { PUSHSTACKTRACE( "readtext_l2272 [inside SC-EXPAND-ONCE]" ); POPSTACKTRACE( x2273 ); } TSCP readtext_sc_2dexpand_2donce( x2271 ) TSCP x2271; { TSCP X1; PUSHSTACKTRACE( t3488 ); X1 = MAKEPROCEDURE( 2, 0, readtext_l2272, EMPTYLIST ); POPSTACKTRACE( readtext_2dexpander_c83ee5f9( x2271, X1 ) ); } DEFTSCP( readtext_xpander_2a_b26e591c_v ); DEFCSTRING( t3492, "*SC-IDENTIFIER-EXPANDER*" ); TSCP readtext_xpander_2a_b26e591c( x2276, e2277 ) TSCP x2276, e2277; { TSCP X1; PUSHSTACKTRACE( t3492 ); X1 = plist_get( x2276, c2035 ); if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3495; POPSTACKTRACE( PAIR_CAR( X1 ) ); L3495: POPSTACKTRACE( x2276 ); } DEFTSCP( readtext_xpander_2a_afbc6f79_v ); DEFCSTRING( t3498, "*SC-APPLICATION-EXPANDER*" ); TSCP readtext_xpander_2a_afbc6f79( x2287, e2288 ) TSCP x2287, e2288; { TSCP X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3498 ); X1 = SYMBOL_VALUE( islist_v ); X1 = UNKNOWNCALL( X1, 2 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( x2287, _TSCP( 4 ), PROCEDURE_CLOSURE( X1 ) ) ) ) goto L3500; X1 = x2287; X2 = EMPTYLIST; X3 = EMPTYLIST; L3503: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L3504; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3507; scrt1__24__car_2derror( X1 ); L3507: X7 = PAIR_CAR( X1 ); X6 = e2288; X6 = UNKNOWNCALL( X6, 2 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( X7, e2288, PROCEDURE_CLOSURE( X6 ) ); X4 = sc_cons( X5, EMPTYLIST ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( EMPTYLIST ) ) ) goto L3510; X5 = PAIR_CDR( X1 ); X3 = X4; X2 = X4; X1 = X5; GOBACK( L3503 ); L3510: X5 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3515; scdebug_error( c2327, c2328, CONS( X3, EMPTYLIST ) ); L3515: X3 = SETGEN( PAIR_CDR( X3 ), X4 ); X1 = X5; GOBACK( L3503 ); L3504: POPSTACKTRACE( X2 ); L3500: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2292, x2287, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( readtext_2dexpander_924034c5_v ); DEFCSTRING( t3517, "INSTALL-SC-EXPANDER" ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); TSCP readtext_2dexpander_924034c5( k2341, f2342 ) TSCP k2341, f2342; { PUSHSTACKTRACE( t3517 ); POPSTACKTRACE( plist_put( k2341, c2035, f2342 ) ); } DEFTSCP( readtext_2dexternal_66fe3106_v ); DEFCSTRING( t3519, "DO-DEFINE-EXTERNAL" ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( expform_lchexname, XAL1( TSCP ) ); EXTERNTSCP( expform_lchexname_v ); EXTERNTSCPP( expform_newv, XAL2( TSCP, TSCP ) ); EXTERNTSCP( expform_newv_v ); EXTERNTSCPP( scrt3_string_2dappend, XAL1( TSCP ) ); EXTERNTSCP( scrt3_string_2dappend_v ); EXTERNTSCPP( scrt1_cadddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadddr_v ); EXTERNTSCP( screp_top_2dlevel_v ); EXTERNTSCPP( scrt1_member, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_member_v ); EXTERNTSCPP( scrt1_caadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caadr_v ); EXTERNTSCPP( scrt1_cdadr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdadr_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); TSCP readtext_2dexternal_66fe3106( e2344 ) TSCP e2344; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3519 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2344, _TSCP( 12 ), _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3546; if ( EQ( TSCPTAG( e2344 ), PAIRTAG ) ) goto L3529; scrt1__24__cdr_2derror( e2344 ); L3529: X3 = PAIR_CDR( e2344 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3532; scrt1__24__car_2derror( X3 ); L3532: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3546; X2 = scrt1_caddr( e2344 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3546; X3 = PAIR_CDR( e2344 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3538; scrt1__24__car_2derror( X3 ); L3538: X2 = PAIR_CAR( X3 ); X3 = expform_lchexname( X2 ); X5 = scrt1_caddr( e2344 ); X4 = expform_lchexname( X5 ); X5 = scrt1_caddr( e2344 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2394 ) ) ) goto L3543; X6 = CONS( c2520, EMPTYLIST ); X7 = SYMBOL_VALUE( hex28_v ); X7 = UNKNOWNCALL( X7, 2 ); X5 = CONS( scrt3_string_2dappend( CONS( VIA( PROCEDURE_CODE( X7 ) )( sc_emptystring, X3, PROCEDURE_CLOSURE( X7 ) ), X6 ) ), EMPTYLIST ); X5 = CONS( c2518, X5 ); X5 = CONS( c2394, X5 ); X5 = CONS( c2065, X5 ); X5 = CONS( c2394, X5 ); POPSTACKTRACE( expform_newv( X2, CONS( c2495, X5 ) ) ); L3543: X6 = CONS( c2520, EMPTYLIST ); X7 = SYMBOL_VALUE( hex28_v ); X7 = UNKNOWNCALL( X7, 2 ); X5 = CONS( scrt3_string_2dappend( CONS( VIA( PROCEDURE_CODE( X7 ) )( X4, X3, PROCEDURE_CLOSURE( X7 ) ), X6 ) ), EMPTYLIST ); X5 = CONS( c2518, X5 ); X5 = CONS( X4, X5 ); X5 = CONS( c2065, X5 ); X5 = CONS( c2496, X5 ); POPSTACKTRACE( expform_newv( X2, CONS( c2495, X5 ) ) ); L3546: X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2344, _TSCP( 16 ), _TSCP( 16 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3577; if ( EQ( TSCPTAG( e2344 ), PAIRTAG ) ) goto L3555; scrt1__24__cdr_2derror( e2344 ); L3555: X3 = PAIR_CDR( e2344 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3558; scrt1__24__car_2derror( X3 ); L3558: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3577; X2 = scrt1_caddr( e2344 ); if ( NEQ( _S2CUINT( c2394 ), _S2CUINT( X2 ) ) ) goto L3577; X2 = scrt1_cadddr( e2344 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3577; X3 = PAIR_CDR( e2344 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3567; scrt1__24__car_2derror( X3 ); L3567: X2 = PAIR_CAR( X3 ); X3 = expform_lchexname( X2 ); X5 = scrt1_cadddr( e2344 ); X4 = expform_lchexname( X5 ); X6 = CONS( c2520, EMPTYLIST ); X7 = SYMBOL_VALUE( hex28_v ); X7 = UNKNOWNCALL( X7, 2 ); X5 = CONS( scrt3_string_2dappend( CONS( VIA( PROCEDURE_CODE( X7 ) )( sc_emptystring, X3, PROCEDURE_CLOSURE( X7 ) ), X6 ) ), EMPTYLIST ); X5 = CONS( c2518, X5 ); X5 = CONS( screp_top_2dlevel_v, X5 ); X5 = CONS( c2065, X5 ); X5 = CONS( c2394, X5 ); expform_newv( X2, CONS( c2495, X5 ) ); X5 = SYMBOL_VALUE( with_2dmodules_v ); if ( TRUE( scrt1_member( X4, X5 ) ) ) goto L3572; X5 = SYMBOL_VALUE( with_2dmodules_v ); X7 = sc_cons( X4, EMPTYLIST ); X6 = X7; POPSTACKTRACE( SETGENTL( SYMBOL_VALUE( with_2dmodules_v ), scrt1_append_2dtwo( X5, X6 ) ) ); L3572: POPSTACKTRACE( FALSEVALUE ); L3577: X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2344, _TSCP( 16 ), _TSCP( 16 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3607; if ( EQ( TSCPTAG( e2344 ), PAIRTAG ) ) goto L3586; scrt1__24__cdr_2derror( e2344 ); L3586: X3 = PAIR_CDR( e2344 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3589; scrt1__24__car_2derror( X3 ); L3589: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3607; X2 = scrt1_caddr( e2344 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) ) goto L3607; X2 = scrt1_cadddr( e2344 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) ) goto L3607; X3 = PAIR_CDR( e2344 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3598; scrt1__24__car_2derror( X3 ); L3598: X2 = PAIR_CAR( X3 ); X3 = scrt1_caddr( e2344 ); X4 = scrt1_cadddr( e2344 ); X4 = CONS( X4, EMPTYLIST ); if ( TRUE( scrt1_equal_3f( X3, sc_emptystring ) ) ) goto L3603; X6 = CONS( PAIR_CAR( X4 ), EMPTYLIST ); X6 = CONS( c2494, X6 ); X5 = scrt3_string_2dappend( CONS( X3, X6 ) ); SETGEN( PAIR_CAR( X4 ), X5 ); L3603: X5 = CONS( PAIR_CAR( X4 ), EMPTYLIST ); X5 = CONS( c2518, X5 ); X5 = CONS( X3, X5 ); X5 = CONS( c2065, X5 ); X5 = CONS( c2496, X5 ); POPSTACKTRACE( expform_newv( X2, CONS( c2495, X5 ) ) ); L3607: X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2344, _TSCP( 12 ), _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3634; if ( EQ( TSCPTAG( e2344 ), PAIRTAG ) ) goto L3616; scrt1__24__cdr_2derror( e2344 ); L3616: X3 = PAIR_CDR( e2344 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3619; scrt1__24__car_2derror( X3 ); L3619: X2 = PAIR_CAR( X3 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3634; X2 = scrt1_caadr( e2344 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3634; X2 = scrt1_caddr( e2344 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3634; X2 = scrt1_caadr( e2344 ); X3 = scrt1_cdadr( e2344 ); X4 = expform_lchexname( X2 ); X6 = scrt1_caddr( e2344 ); X5 = expform_lchexname( X6 ); X11 = CONS( EMPTYLIST, EMPTYLIST ); X10 = scrt1_cons_2a( c2110, CONS( X3, X11 ) ); X11 = SYMBOL_VALUE( exp_2dform_v ); X9 = SYMBOL_VALUE( exp_2dform_v ); X9 = UNKNOWNCALL( X9, 2 ); X8 = VIA( PROCEDURE_CODE( X9 ) )( X10, X11, PROCEDURE_CLOSURE( X9 ) ); X7 = SYMBOL_VALUE( _24lambda_2did_v ); X7 = UNKNOWNCALL( X7, 1 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( X8, PROCEDURE_CLOSURE( X7 ) ); X7 = EMPTYLIST; X7 = CONS( X7, EMPTYLIST ); X10 = SYMBOL_VALUE( hex28_v ); X10 = UNKNOWNCALL( X10, 2 ); X9 = CONS( scrt3_string_2dappend( CONS( VIA( PROCEDURE_CODE( X10 ) )( X5, X4, PROCEDURE_CLOSURE( X10 ) ), EMPTYLIST ) ), EMPTYLIST ); X9 = CONS( c2497, X9 ); X10 = CONS( c2520, EMPTYLIST ); X11 = SYMBOL_VALUE( hex28_v ); X11 = UNKNOWNCALL( X11, 2 ); X9 = CONS( scrt3_string_2dappend( CONS( VIA( PROCEDURE_CODE( X11 ) )( X5, X4, PROCEDURE_CLOSURE( X11 ) ), X10 ) ), X9 ); X9 = CONS( c2518, X9 ); X9 = CONS( X5, X9 ); X9 = CONS( c2065, X9 ); X9 = CONS( c2496, X9 ); X8 = expform_newv( X2, CONS( c2495, X9 ) ); SETGEN( PAIR_CAR( X7 ), X8 ); plist_put( PAIR_CAR( X7 ), c2110, X6 ); X8 = SYMBOL_VALUE( set_2dlambda_2dgenerate_21_v ); X8 = UNKNOWNCALL( X8, 2 ); VIA( PROCEDURE_CODE( X8 ) )( X6, c2502, PROCEDURE_CLOSURE( X8 ) ); X8 = SYMBOL_VALUE( set_2dlambda_2dname_21_v ); X8 = UNKNOWNCALL( X8, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X8 ) )( X6, PAIR_CAR( X7 ), PROCEDURE_CLOSURE( X8 ) ) ); L3634: X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2344, _TSCP( 16 ), _TSCP( 16 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3663; if ( EQ( TSCPTAG( e2344 ), PAIRTAG ) ) goto L3643; scrt1__24__cdr_2derror( e2344 ); L3643: X3 = PAIR_CDR( e2344 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3646; scrt1__24__car_2derror( X3 ); L3646: X2 = PAIR_CAR( X3 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L3663; X2 = scrt1_caadr( e2344 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3663; X2 = scrt1_caddr( e2344 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), STRINGTAG ) ) ) ) goto L3663; X2 = scrt1_caadr( e2344 ); X3 = scrt1_cdadr( e2344 ); X4 = scrt1_caddr( e2344 ); X5 = scrt1_cadddr( e2344 ); X5 = CONS( X5, EMPTYLIST ); X11 = CONS( EMPTYLIST, EMPTYLIST ); X10 = scrt1_cons_2a( c2110, CONS( X3, X11 ) ); X11 = SYMBOL_VALUE( exp_2dform_v ); X9 = SYMBOL_VALUE( exp_2dform_v ); X9 = UNKNOWNCALL( X9, 2 ); X8 = VIA( PROCEDURE_CODE( X9 ) )( X10, X11, PROCEDURE_CLOSURE( X9 ) ); X7 = SYMBOL_VALUE( _24lambda_2did_v ); X7 = UNKNOWNCALL( X7, 1 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( X8, PROCEDURE_CLOSURE( X7 ) ); X7 = EMPTYLIST; X7 = CONS( X7, EMPTYLIST ); if ( TRUE( scrt1_equal_3f( X4, sc_emptystring ) ) ) goto L3659; X9 = CONS( PAIR_CAR( X5 ), EMPTYLIST ); X9 = CONS( c2494, X9 ); X8 = scrt3_string_2dappend( CONS( X4, X9 ) ); SETGEN( PAIR_CAR( X5 ), X8 ); L3659: X9 = CONS( PAIR_CAR( X5 ), EMPTYLIST ); X9 = CONS( c2497, X9 ); X9 = CONS( X4, X9 ); X9 = CONS( c2065, X9 ); X9 = CONS( c2496, X9 ); X8 = expform_newv( X2, CONS( c2495, X9 ) ); SETGEN( PAIR_CAR( X7 ), X8 ); plist_put( PAIR_CAR( X7 ), c2110, X6 ); X8 = SYMBOL_VALUE( set_2dlambda_2dgenerate_21_v ); X8 = UNKNOWNCALL( X8, 2 ); VIA( PROCEDURE_CODE( X8 ) )( X6, c2502, PROCEDURE_CLOSURE( X8 ) ); X8 = SYMBOL_VALUE( set_2dlambda_2dname_21_v ); X8 = UNKNOWNCALL( X8, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X8 ) )( X6, PAIR_CAR( X7 ), PROCEDURE_CLOSURE( X8 ) ) ); L3663: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2053, e2344, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( readtext_2dexternal_7d8f1d02_v ); DEFCSTRING( t3664, "DO-DEFINE-C-EXTERNAL" ); TSCP readtext_c2584( x2681 ) TSCP x2681; { PUSHSTACKTRACE( "C-TYPE? [inside DO-DEFINE-C-EXTERNAL]" ); POPSTACKTRACE( scrt1_memq( x2681, c2682 ) ); } EXTERNTSCPP( scrt1_reverse, XAL1( TSCP ) ); EXTERNTSCP( scrt1_reverse_v ); TSCP readtext_2dexternal_7d8f1d02( e2579 ) TSCP e2579; { TSCP X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3664 ); X4 = SYMBOL_VALUE( islist_v ); X4 = UNKNOWNCALL( X4, 3 ); if ( FALSE( VIA( PROCEDURE_CODE( X4 ) )( e2579, _TSCP( 16 ), _TSCP( 16 ), PROCEDURE_CLOSURE( X4 ) ) ) ) goto L3666; X1 = scrt1_cadddr( e2579 ); X2 = scrt1_caddr( e2579 ); if ( EQ( TSCPTAG( e2579 ), PAIRTAG ) ) goto L3670; scrt1__24__cdr_2derror( e2579 ); L3670: X4 = PAIR_CDR( e2579 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3673; scrt1__24__car_2derror( X4 ); L3673: X3 = PAIR_CAR( X4 ); X4 = BOOLEAN( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ); if ( FALSE( X4 ) ) goto L3682; if ( FALSE( readtext_c2584( X2 ) ) ) goto L3682; X5 = CONS( X2, EMPTYLIST ); X5 = CONS( c2669, X5 ); X5 = CONS( X1, X5 ); X5 = CONS( c2518, X5 ); X5 = CONS( sc_emptystring, X5 ); X5 = CONS( c2065, X5 ); X5 = CONS( c2496, X5 ); POPSTACKTRACE( expform_newv( X3, CONS( c2495, X5 ) ) ); L3666: X4 = SYMBOL_VALUE( expand_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X4 ) )( c2057, e2579, PROCEDURE_CLOSURE( X4 ) ) ); L3682: X4 = BOOLEAN( EQ( TSCPTAG( X3 ), PAIRTAG ) ); if ( FALSE( X4 ) ) goto L3701; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3691; scrt1__24__car_2derror( X3 ); L3691: X5 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), SYMBOLTAG ) ) ) ) goto L3701; X5 = readtext_c2584( X2 ); if ( TRUE( X5 ) ) goto L3697; if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2614 ) ) ) goto L3701; L3697: X9 = CONS( EMPTYLIST, EMPTYLIST ); X8 = scrt1_cons_2a( c2110, CONS( PAIR_CDR( X3 ), X9 ) ); X9 = SYMBOL_VALUE( exp_2dform_v ); X7 = SYMBOL_VALUE( exp_2dform_v ); X7 = UNKNOWNCALL( X7, 2 ); X6 = VIA( PROCEDURE_CODE( X7 ) )( X8, X9, PROCEDURE_CLOSURE( X7 ) ); X5 = SYMBOL_VALUE( _24lambda_2did_v ); X5 = UNKNOWNCALL( X5, 1 ); X4 = VIA( PROCEDURE_CODE( X5 ) )( X6, PROCEDURE_CLOSURE( X5 ) ); X6 = PAIR_CAR( X3 ); X7 = CONS( X2, EMPTYLIST ); X7 = CONS( c2669, X7 ); X7 = CONS( X1, X7 ); X7 = CONS( c2497, X7 ); X7 = CONS( sc_emptystring, X7 ); X7 = CONS( c2065, X7 ); X7 = CONS( c2496, X7 ); X5 = expform_newv( X6, CONS( c2495, X7 ) ); X6 = PAIR_CDR( X3 ); X7 = EMPTYLIST; X8 = X6; L3708: if ( NEQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L3709; X10 = scrt1_reverse( X7 ); X9 = SYMBOL_VALUE( set_2dlambda_2dreqvars_21_v ); X9 = UNKNOWNCALL( X9, 2 ); VIA( PROCEDURE_CODE( X9 ) )( X4, X10, PROCEDURE_CLOSURE( X9 ) ); goto L3727; L3709: if ( FALSE( readtext_c2584( X8 ) ) ) goto L3711; X10 = scrt1_reverse( X7 ); X9 = SYMBOL_VALUE( set_2dlambda_2dreqvars_21_v ); X9 = UNKNOWNCALL( X9, 2 ); VIA( PROCEDURE_CODE( X9 ) )( X4, X10, PROCEDURE_CLOSURE( X9 ) ); X11 = sc_cons( X8, EMPTYLIST ); X10 = X11; X9 = SYMBOL_VALUE( set_2dlambda_2doptvars_21_v ); X9 = UNKNOWNCALL( X9, 2 ); VIA( PROCEDURE_CODE( X9 ) )( X4, X10, PROCEDURE_CLOSURE( X9 ) ); goto L3727; L3711: X9 = BOOLEAN( EQ( TSCPTAG( X8 ), PAIRTAG ) ); if ( FALSE( X9 ) ) goto L3726; if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L3722; scrt1__24__car_2derror( X8 ); L3722: X10 = PAIR_CAR( X8 ); if ( FALSE( readtext_c2584( X10 ) ) ) goto L3726; X11 = PAIR_CAR( X8 ); X10 = sc_cons( X11, X7 ); X8 = PAIR_CDR( X8 ); X7 = X10; GOBACK( L3708 ); L3726: X7 = SYMBOL_VALUE( expand_2derror_v ); X7 = UNKNOWNCALL( X7, 2 ); VIA( PROCEDURE_CODE( X7 ) )( c2057, e2579, PROCEDURE_CLOSURE( X7 ) ); L3727: plist_put( X5, c2110, X4 ); X6 = SYMBOL_VALUE( set_2dlambda_2dgenerate_21_v ); X6 = UNKNOWNCALL( X6, 2 ); VIA( PROCEDURE_CODE( X6 ) )( X4, c2502, PROCEDURE_CLOSURE( X6 ) ); X6 = SYMBOL_VALUE( set_2dlambda_2dname_21_v ); X6 = UNKNOWNCALL( X6, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X6 ) )( X4, X5, PROCEDURE_CLOSURE( X6 ) ) ); L3701: X4 = SYMBOL_VALUE( expand_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X4 ) )( c2057, e2579, PROCEDURE_CLOSURE( X4 ) ) ); } DEFTSCP( readtext_do_2ddefine_2dmacro_v ); DEFCSTRING( t3728, "DO-DEFINE-MACRO" ); TSCP readtext_do_2ddefine_2dmacro( e2685 ) TSCP e2685; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3728 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2685, _TSCP( 12 ), _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3746; if ( EQ( TSCPTAG( e2685 ), PAIRTAG ) ) goto L3737; scrt1__24__cdr_2derror( e2685 ); L3737: X3 = PAIR_CDR( e2685 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3740; scrt1__24__car_2derror( X3 ); L3740: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3746; X3 = PAIR_CDR( e2685 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3744; scrt1__24__car_2derror( X3 ); L3744: X2 = PAIR_CAR( X3 ); X4 = scrt1_caddr( e2685 ); X3 = sceval_eval( X4, CONS( EMPTYLIST, EMPTYLIST ) ); POPSTACKTRACE( plist_put( X2, c2035, X3 ) ); L3746: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2061, e2685, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( readtext_do_2dinclude_v ); DEFCSTRING( t3747, "DO-INCLUDE" ); EXTERNTSCPP( scrt4_catch_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt4_catch_2derror_v ); EXTERNTSCPP( scrt5_open_2dinput_2dfile, XAL1( TSCP ) ); EXTERNTSCP( scrt5_open_2dinput_2dfile_v ); TSCP readtext_l2726( c3777 ) TSCP c3777; { TSCP X2, X1; PUSHSTACKTRACE( "readtext_l2726 [inside DO-INCLUDE]" ); X1 = DISPLAY( 0 ); DISPLAY( 0 ) = CLOSURE_VAR( c3777, 0 ); X2 = scrt5_open_2dinput_2dfile( DISPLAY( 0 ) ); DISPLAY( 0 ) = X1; POPSTACKTRACE( X2 ); } TSCP readtext_do_2dinclude( e2713 ) TSCP e2713; { TSCP X7, X6, X5, X4, X3, X2, X1; TSCP SD0 = DISPLAY( 0 ); TSCP SDVAL; PUSHSTACKTRACE( t3747 ); X3 = SYMBOL_VALUE( islist_v ); X3 = UNKNOWNCALL( X3, 3 ); X2 = VIA( PROCEDURE_CODE( X3 ) )( e2713, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X3 ) ); if ( FALSE( X2 ) ) goto L3751; if ( EQ( TSCPTAG( e2713 ), PAIRTAG ) ) goto L3756; scrt1__24__cdr_2derror( e2713 ); L3756: X4 = PAIR_CDR( e2713 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3759; scrt1__24__car_2derror( X4 ); L3759: X3 = PAIR_CAR( X4 ); if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), STRINGTAG ) ) ) ) goto L3753; X3 = PAIR_CDR( e2713 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3763; scrt1__24__car_2derror( X3 ); L3763: X1 = PAIR_CAR( X3 ); goto L3752; L3753: X1 = FALSEVALUE; goto L3752; L3751: X1 = X2; L3752: if ( FALSE( X1 ) ) goto L3766; X2 = SYMBOL_VALUE( sc_2dinclude_2ddirs_v ); X3 = X2; L3770: if ( FALSE( X3 ) ) goto L3771; X5 = CONS( X1, EMPTYLIST ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3774; scrt1__24__car_2derror( X3 ); L3774: DISPLAY( 0 ) = scrt3_string_2dappend( CONS( PAIR_CAR( X3 ), X5 ) ); X6 = MAKEPROCEDURE( 0, 0, readtext_l2726, MAKECLOSURE( EMPTYLIST, 1, DISPLAY( 0 ) ) ); X5 = scrt4_catch_2derror( X6 ); if ( NOT( AND( EQ( TSCPTAG( X5 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X5 ), STRINGTAG ) ) ) ) goto L3780; X4 = FALSEVALUE; goto L3781; L3780: if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3783; scrt1__24__car_2derror( X5 ); L3783: X4 = PAIR_CAR( X5 ); L3781: if ( FALSE( X4 ) ) goto L3786; X6 = SYMBOL_VALUE( sc_2dsplice_v ); X7 = SYMBOL_VALUE( sc_2dinput_v ); X5 = sc_cons( X6, X7 ); SETGENTL( SYMBOL_VALUE( sc_2dinput_v ), sc_cons( X4, X5 ) ); SDVAL = SETGENTL( SYMBOL_VALUE( sc_2dsplice_v ), EMPTYLIST ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L3786: X3 = PAIR_CDR( X3 ); GOBACK( L3770 ); L3771: X4 = SYMBOL_VALUE( report_2derror_v ); X4 = UNKNOWNCALL( X4, 2 ); SDVAL = VIA( PROCEDURE_CODE( X4 ) )( c2736, X1, PROCEDURE_CLOSURE( X4 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); L3766: X2 = SYMBOL_VALUE( expand_2derror_v ); X2 = UNKNOWNCALL( X2, 2 ); SDVAL = VIA( PROCEDURE_CODE( X2 ) )( c2069, e2713, PROCEDURE_CLOSURE( X2 ) ); DISPLAY( 0 ) = SD0; POPSTACKTRACE( SDVAL ); } DEFTSCP( readtext_do_2dmodule_v ); DEFCSTRING( t3790, "DO-MODULE" ); EXTERNTSCPP( readtext__2dclauses_73970203, XAL1( TSCP ) ); EXTERNTSCP( readtext__2dclauses_73970203_v ); TSCP readtext_do_2dmodule( e2781 ) TSCP e2781; { TSCP X4, X3, X2, X1; PUSHSTACKTRACE( t3790 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e2781, _TSCP( 8 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3841; if ( EQ( TSCPTAG( e2781 ), PAIRTAG ) ) goto L3800; scrt1__24__cdr_2derror( e2781 ); L3800: X3 = PAIR_CDR( e2781 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3803; scrt1__24__car_2derror( X3 ); L3803: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3841; X3 = PAIR_CDR( e2781 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3809; scrt1__24__car_2derror( X3 ); L3809: X2 = PAIR_CAR( X3 ); if ( EQ( _S2CUINT( X2 ), _S2CUINT( c2394 ) ) ) goto L3841; X2 = SYMBOL_VALUE( module_2dname_v ); if ( FALSE( scrt1_equal_3f( X2, sc_emptystring ) ) ) goto L3812; X3 = PAIR_CDR( e2781 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3817; scrt1__24__car_2derror( X3 ); L3817: X2 = PAIR_CAR( X3 ); SETGENTL( SYMBOL_VALUE( module_2dname_v ), expform_lchexname( X2 ) ); X3 = PAIR_CDR( e2781 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3821; scrt1__24__car_2derror( X3 ); L3821: X2 = PAIR_CAR( X3 ); if ( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) goto L3824; scdebug_error( c2832, c2833, CONS( X2, EMPTYLIST ) ); L3824: SETGENTL( SYMBOL_VALUE( module_2dname_2dupcase_v ), SYMBOL_NAME( X2 ) ); goto L3813; L3812: X3 = SYMBOL_VALUE( module_2dname_v ); X2 = SYMBOL_VALUE( report_2derror_v ); X2 = UNKNOWNCALL( X2, 2 ); VIA( PROCEDURE_CODE( X2 ) )( c2816, X3, PROCEDURE_CLOSURE( X2 ) ); L3813: X3 = PAIR_CDR( e2781 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3828; scrt1__24__cdr_2derror( X3 ); L3828: X2 = PAIR_CDR( X3 ); X3 = X2; L3832: if ( EQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3833; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3837; scrt1__24__car_2derror( X3 ); L3837: X4 = PAIR_CAR( X3 ); readtext__2dclauses_73970203( X4 ); X3 = PAIR_CDR( X3 ); GOBACK( L3832 ); L3833: POPSTACKTRACE( FALSEVALUE ); L3841: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2065, e2781, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( readtext__2dclauses_73970203_v ); DEFCSTRING( t3842, "DO-MODULE-CLAUSES" ); EXTERNTSCPP( scrt2_round, XAL1( TSCP ) ); EXTERNTSCP( scrt2_round_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); EXTERNTSCPP( scrt2_positive_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_positive_3f_v ); TSCP readtext__2dclauses_73970203( c2878 ) TSCP c2878; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3842 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2878, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3874; if ( EQ( TSCPTAG( c2878 ), PAIRTAG ) ) goto L3852; scrt1__24__car_2derror( c2878 ); L3852: X2 = PAIR_CAR( c2878 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2893 ) ) ) goto L3874; if ( FALSE( SYMBOL_VALUE( main_2dprogram_2dname_v ) ) ) goto L3854; X2 = FALSEVALUE; goto L3855; L3854: X2 = TRUEVALUE; L3855: if ( FALSE( X2 ) ) goto L3874; X4 = PAIR_CDR( c2878 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3864; scrt1__24__car_2derror( X4 ); L3864: X3 = PAIR_CAR( X4 ); if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) ) goto L3874; if ( TRUE( SYMBOL_VALUE( sc_2dinterpreter_v ) ) ) goto L3866; X3 = PAIR_CDR( c2878 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3870; scrt1__24__car_2derror( X3 ); L3870: POPSTACKTRACE( SETGENTL( SYMBOL_VALUE( main_2dprogram_2dname_v ), PAIR_CAR( X3 ) ) ); L3866: POPSTACKTRACE( FALSEVALUE ); L3874: X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2878, _TSCP( 8 ), _TSCP( 8 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3917; if ( EQ( TSCPTAG( c2878 ), PAIRTAG ) ) goto L3883; scrt1__24__car_2derror( c2878 ); L3883: X2 = PAIR_CAR( c2878 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2926 ) ) ) goto L3917; X4 = PAIR_CDR( c2878 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3887; scrt1__24__car_2derror( X4 ); L3887: X3 = PAIR_CAR( X4 ); if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L3890; X2 = TRUEVALUE; goto L3893; L3890: if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), DOUBLEFLOATTAG ) ) ) ) goto L3892; X4 = scrt2_round( X3 ); if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( X4 ) ), 3 ) ) goto L3895; X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( X4 ) ) ); goto L3893; L3895: X2 = scrt2__3d_2dtwo( X3, X4 ); goto L3893; L3892: X2 = FALSEVALUE; L3893: if ( FALSE( X2 ) ) goto L3917; X4 = PAIR_CDR( c2878 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L3903; scrt1__24__car_2derror( X4 ); L3903: X3 = PAIR_CAR( X4 ); if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L3907; if ( GT( _S2CINT( X3 ), 0 ) ) goto L3911; goto L3917; L3907: if ( FALSE( scrt2_positive_3f( X3 ) ) ) goto L3917; L3911: X1 = PAIR_CDR( c2878 ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L3920; scrt1__24__car_2derror( X1 ); L3920: POPSTACKTRACE( SETGENTL( SYMBOL_VALUE( heap_2dsize_v ), PAIR_CAR( X1 ) ) ); L3917: X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2878, _TSCP( 4 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3936; if ( EQ( TSCPTAG( c2878 ), PAIRTAG ) ) goto L3930; scrt1__24__car_2derror( c2878 ); L3930: X2 = PAIR_CAR( c2878 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2394 ) ) ) goto L3936; X2 = SYMBOL_VALUE( top_2dlevel_2dsymbols_v ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( TRUEVALUE ) ) ) goto L3936; POPSTACKTRACE( SETGENTL( SYMBOL_VALUE( top_2dlevel_2dsymbols_v ), PAIR_CDR( c2878 ) ) ); L3936: X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 2 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( c2878, _TSCP( 8 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3967; if ( EQ( TSCPTAG( c2878 ), PAIRTAG ) ) goto L3945; scrt1__24__car_2derror( c2878 ); L3945: X2 = PAIR_CAR( c2878 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c3014 ) ) ) goto L3967; if ( TRUE( SYMBOL_VALUE( with_2dmodules_v ) ) ) goto L3967; X2 = PAIR_CDR( c2878 ); X3 = X2; X4 = EMPTYLIST; X5 = EMPTYLIST; L3953: if ( NEQ( _S2CUINT( X3 ), _S2CUINT( EMPTYLIST ) ) ) goto L3954; X6 = X4; goto L3961; L3954: if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3957; scrt1__24__car_2derror( X3 ); L3957: X9 = PAIR_CAR( X3 ); X8 = expform_lchexname( X9 ); X7 = sc_cons( X8, EMPTYLIST ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L3960; X8 = PAIR_CDR( X3 ); X5 = X7; X4 = X7; X3 = X8; GOBACK( L3953 ); L3960: X8 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L3965; scdebug_error( c2327, c2328, CONS( X5, EMPTYLIST ) ); L3965: X5 = SETGEN( PAIR_CDR( X5 ), X7 ); X3 = X8; GOBACK( L3953 ); L3961: POPSTACKTRACE( SETGENTL( SYMBOL_VALUE( with_2dmodules_v ), X6 ) ); L3967: X1 = SYMBOL_VALUE( report_2derror_v ); X1 = UNKNOWNCALL( X1, 1 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c3016, PROCEDURE_CLOSURE( X1 ) ) ); } DEFTSCP( readtext_2dconstant_f5c64566_v ); DEFCSTRING( t3968, "DO-DEFINE-CONSTANT" ); TSCP readtext_2dconstant_f5c64566( e3091 ) TSCP e3091; { TSCP X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t3968 ); X2 = SYMBOL_VALUE( islist_v ); X2 = UNKNOWNCALL( X2, 3 ); X1 = VIA( PROCEDURE_CODE( X2 ) )( e3091, _TSCP( 12 ), _TSCP( 12 ), PROCEDURE_CLOSURE( X2 ) ); if ( FALSE( X1 ) ) goto L3988; if ( EQ( TSCPTAG( e3091 ), PAIRTAG ) ) goto L3977; scrt1__24__cdr_2derror( e3091 ); L3977: X3 = PAIR_CDR( e3091 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3980; scrt1__24__car_2derror( X3 ); L3980: X2 = PAIR_CAR( X3 ); if ( NOT( AND( EQ( TSCPTAG( X2 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X2 ), SYMBOLTAG ) ) ) ) goto L3988; X3 = PAIR_CDR( e3091 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L3985; scrt1__24__car_2derror( X3 ); L3985: X2 = PAIR_CAR( X3 ); X6 = scrt1_caddr( e3091 ); X5 = sceval_eval( X6, CONS( EMPTYLIST, EMPTYLIST ) ); X4 = sc_cons( X5, EMPTYLIST ); X3 = X4; readtext_2dexpander_924034c5( X2, X3 ); POPSTACKTRACE( sceval_eval( e3091, EMPTYLIST ) ); L3988: X1 = SYMBOL_VALUE( expand_2derror_v ); X1 = UNKNOWNCALL( X1, 2 ); POPSTACKTRACE( VIA( PROCEDURE_CODE( X1 ) )( c2073, e3091, PROCEDURE_CLOSURE( X1 ) ) ); } void scrt4__init(); void screp__init(); void expform__init(); void plist__init(); void scrt5__init(); void scrt2__init(); void scdebug__init(); void scrt3__init(); void sceval__init(); void scrt6__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt4__init(); screp__init(); expform__init(); plist__init(); scrt5__init(); scrt2__init(); scdebug__init(); scrt3__init(); sceval__init(); scrt6__init(); scrt1__init(); MAXDISPLAY( 1 ); } void readtext__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(readtext SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t3332, ADR( readtext_read_2dtext_v ), MAKEPROCEDURE( 0, 0, readtext_read_2dtext, EMPTYLIST ) ); INITIALIZEVAR( t3425, ADR( readtext_sc_2dinput_3d56933a_v ), MAKEPROCEDURE( 0, 0, readtext_sc_2dinput_3d56933a, EMPTYLIST ) ); INITIALIZEVAR( t3470, ADR( readtext_sc_2dexpand_v ), MAKEPROCEDURE( 1, 0, readtext_sc_2dexpand, EMPTYLIST ) ); INITIALIZEVAR( t3472, ADR( readtext_2dexpander_c83ee5f9_v ), MAKEPROCEDURE( 2, 0, readtext_2dexpander_c83ee5f9, EMPTYLIST ) ); INITIALIZEVAR( t3488, ADR( readtext_sc_2dexpand_2donce_v ), MAKEPROCEDURE( 1, 0, readtext_sc_2dexpand_2donce, EMPTYLIST ) ); INITIALIZEVAR( t3492, ADR( readtext_xpander_2a_b26e591c_v ), MAKEPROCEDURE( 2, 0, readtext_xpander_2a_b26e591c, EMPTYLIST ) ); INITIALIZEVAR( t3498, ADR( readtext_xpander_2a_afbc6f79_v ), MAKEPROCEDURE( 2, 0, readtext_xpander_2a_afbc6f79, EMPTYLIST ) ); INITIALIZEVAR( t3517, ADR( readtext_2dexpander_924034c5_v ), MAKEPROCEDURE( 2, 0, readtext_2dexpander_924034c5, EMPTYLIST ) ); INITIALIZEVAR( t3519, ADR( readtext_2dexternal_66fe3106_v ), MAKEPROCEDURE( 1, 0, readtext_2dexternal_66fe3106, EMPTYLIST ) ); INITIALIZEVAR( t3664, ADR( readtext_2dexternal_7d8f1d02_v ), MAKEPROCEDURE( 1, 0, readtext_2dexternal_7d8f1d02, EMPTYLIST ) ); INITIALIZEVAR( t3728, ADR( readtext_do_2ddefine_2dmacro_v ), MAKEPROCEDURE( 1, 0, readtext_do_2ddefine_2dmacro, EMPTYLIST ) ); INITIALIZEVAR( t3747, ADR( readtext_do_2dinclude_v ), MAKEPROCEDURE( 1, 0, readtext_do_2dinclude, EMPTYLIST ) ); INITIALIZEVAR( t3790, ADR( readtext_do_2dmodule_v ), MAKEPROCEDURE( 1, 0, readtext_do_2dmodule, EMPTYLIST ) ); INITIALIZEVAR( t3842, ADR( readtext__2dclauses_73970203_v ), MAKEPROCEDURE( 1, 0, readtext__2dclauses_73970203, EMPTYLIST ) ); INITIALIZEVAR( t3968, ADR( readtext_2dconstant_f5c64566_v ), MAKEPROCEDURE( 1, 0, readtext_2dconstant_f5c64566, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/readtext.sc000066400000000000000000000325261203736146400167130ustar00rootroot00000000000000;;; The functions in this file read the program text, expand text macros, and ;;; process all MODULE, INCLUDE, DEFINE-EXTERNAL, DEFINE-C-EXTERNAK and ;;; DEFINE-MACRO directives. The function READ-TEXT is called to read each ;;; S-expression from the source files(s). It will return the eof-object when ;;; all text has been read. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module readtext) ;;; External definitions. (include "plist.sch") (include "expform.sch") (define (READ-TEXT) (let ((form '())) (if sc-splice (begin (set! form (car sc-splice)) (set! sc-splice (cdr sc-splice))) (begin (set! form (sc-expand (read-from-sc-input))) (if (log? 'macro) (begin (pretty-print-$tree form sc-icode) (newline sc-icode))))) (case (and (pair? form) (car form)) ((define-external) (do-define-external form) (read-text)) ((define-c-external) (do-define-c-external form) (read-text)) ((define-macro) (read-text)) ((module) (do-module form) (read-text)) ((include) (do-include form) (read-text)) ((define-constant) (read-text)) ((eval-when) (if (memq 'compile (cadr form)) (eval (cons 'begin (cddr form)))) (read-text)) (else (cond ((and (pair? form) (pair? (car form)) (eq? (caar form) 'lambda) (null? (cadar form))) (set! sc-splice (append (cddar form) sc-splice)) (read-text)) (else (if (equal? module-name "") (begin (set! module-name (substring sc-source-name 0 (- (string-length sc-source-name) 3))) (report-warning "Module name defaults to:" module-name))) form)))))) (define (READ-FROM-SC-INPUT) (do ((form (read (car sc-input)) (read (car sc-input)))) ((or (and (eof-object? form) (null? (cdr sc-input))) (not (eof-object? form))) (if (log? 'source) (begin (pretty-print-$tree form sc-icode) (newline sc-icode))) form) (close-port (car sc-input)) (set! sc-splice (cadr sc-input)) (set! sc-input (cddr sc-input)))) ;;; Macro expansion is done by this code. It is based upon the ideas in ;;; "Expansion-Passing Style: Beyond Conventional Macros", 1986 ACM Conference ;;; on Lisp and Functional Programming. (define (SC-EXPAND x) (sc-initial-expander x sc-initial-expander)) (define (SC-INITIAL-EXPANDER x e) (let ((e1 (cond ((symbol? x) *sc-identifier-expander*) ((not (pair? x)) (lambda (x e) x)) ((symbol? (car x)) (let ((func (get (car x) 'macro))) (if (procedure? func) func *sc-application-expander*))) (else *sc-application-expander*)))) (e1 x e))) (define (SC-EXPAND-ONCE x) (sc-initial-expander x (lambda (x e) x))) (define (*SC-IDENTIFIER-EXPANDER* x e) (let ((constant (get x 'macro))) (if (pair? constant) (car constant) x))) (define (*SC-APPLICATION-EXPANDER* x e) (if (islist x 1) (map (lambda (x) (e x e)) x) (expand-error '*SC-APPLICATION-EXPANDER* x))) (define (INSTALL-SC-EXPANDER keyword function) (put keyword 'macro function)) ;;; External functions and variables which follow Scheme's conventions are ;;; defined by the following form: ;;; ;;; (DEFINE-EXTERNAL var module) ;;; ;;; (DEFINE-EXTERNAL var TOP-LEVEL) ;;; ;;; (DEFINE-EXTERNAL var TOP-LEVEL module) ;;; ;;; (DEFINE-EXTERNAL var "module" "name") ;;; ;;; (DEFINE-EXTERNAL (func args...) module) ;;; ;;; (DEFINE-EXTERNAL (func args...) "module" "name") (define (DO-DEFINE-EXTERNAL exp) (cond ((and (islist exp 3 3) (symbol? (cadr exp)) (symbol? (caddr exp))) (let* ((var (cadr exp)) (hex (lchexname var)) (module (lchexname (caddr exp)))) (if (eq? (caddr exp) 'top-level) (newv var 'use 'top-level 'module 'top-level 'vname (string-append (hex28 "" hex) "_v")) (newv var 'use 'global 'module module 'vname (string-append (hex28 module hex) "_v"))))) ((and (islist exp 4 4) (symbol? (cadr exp)) (eq? 'top-level (caddr exp)) (symbol? (cadddr exp))) (let* ((var (cadr exp)) (hex (lchexname var)) (module (lchexname (cadddr exp)))) (newv var 'use 'top-level 'module top-level 'vname (string-append (hex28 "" hex) "_v")) (if (not (member module with-modules)) (set! with-modules (append with-modules (list module)))))) ((and (islist exp 4 4) (symbol? (cadr exp)) (string? (caddr exp)) (string? (cadddr exp))) (let* ((var (cadr exp)) (module (caddr exp)) (vname (cadddr exp))) (if (not (equal? module "")) (set! vname (string-append module "_" vname))) (newv var 'use 'global 'module module 'vname vname))) ((and (islist exp 3 3) (pair? (cadr exp)) (symbol? (caadr exp)) (symbol? (caddr exp))) (let* ((func (caadr exp)) (vars (cdadr exp)) (hex (lchexname func)) (module (lchexname (caddr exp))) (id ($lambda-id (exp-form `(lambda ,vars) exp-form))) (alpha '())) (set! alpha (newv func 'use 'global 'module module 'vname (string-append (hex28 module hex) "_v") 'cname (string-append (hex28 module hex)))) (set-id-lambda! alpha id) (set-lambda-generate! id 'procedure) (set-lambda-name! id alpha))) ((and (islist exp 4 4) (pair? (cadr exp)) (symbol? (caadr exp)) (string? (caddr exp))) (let* ((func (caadr exp)) (vars (cdadr exp)) (module (caddr exp)) (cname (cadddr exp)) (id ($lambda-id (exp-form `(lambda ,vars) exp-form))) (alpha '())) (if (not (equal? module "")) (set! cname (string-append module "_" cname))) (set! alpha (newv func 'use 'global 'module module 'cname cname)) (set-id-lambda! alpha id) (set-lambda-generate! id 'procedure) (set-lambda-name! id alpha))) (else (expand-error 'define-external exp)))) ;;; External variables and functions which follow C's conventions are defined ;;; by the following forms: ;;; ;;; (DEFINE-C-EXTERNAL var type "name") ;;; ;;; (DEFINE-C-EXTERNAL (var type ...) type "name") ;;; ;;; (DEFINE-C-EXTERNAL (var type ... . type) type "name") ;;; ;;; where "type" is one of the following: tscp, pointer, array, void, char, ;;; int, shortint, longint, unsigned, shortunsigned longunsigned, float or ;;; double. Argument conversion is determined by the type specifications as ;;; follows: ;;; ;;; pointer argument may be a string, procedure, or a number. The address ;;; of the first character of the string will be provided. The ;;; code address of a procedure will be provided. The integer ;;; value of a number will be provided. ;;; ;;; array treated as a pointer ;;; ;;; char argument is a character. Its value will be supplied. ;;; ;;; int argument is a number. Its int value will be supplied. ;;; shortint ;;; longint ;;; ;;; unsigned argument is a number. Its value will be supplied. ;;; shortunsigned ;;; longunsigned ;;; ;;; float argument is a number. Its float value will be supplied. ;;; ;;; double argument is a number. Its double value will be supplied. ;;; ;;; tscp argument is any Scheme value which will be passed as is. ;;; ;;; void not allowed. ;;; ;;; Result conversion is as follows: ;;; ;;; pointer the pointer result (an unsigned value) is returned as a number. ;;; ;;; array treated as a pointer. ;;; ;;; char the character result is returned as a character. ;;; ;;; int the integer result is returned as a number. ;;; shortint ;;; longint ;;; ;;; unsigned the unsigned result is returned as a number. ;;; shortunsigned ;;; longunsigned ;;; ;;; float the float result is returned as a number. ;;; ;;; double the double result is returned as a number. ;;; ;;; tscp the result is returned as is. ;;; ;;; void no result is returned. (define (DO-DEFINE-C-EXTERNAL exp) (if (islist exp 4 4) (let ((form (cadr exp)) (c-type (caddr exp)) (cname (cadddr exp)) (c-type? (lambda (x) (memq x '(pointer array char int shortint longint unsigned shortunsigned longunsigned float double tscp))))) (cond ((and (symbol? form) (c-type? c-type)) (newv form 'use 'global 'module "" 'vname cname 'type c-type)) ((and (pair? form) (symbol? (car form)) (or (c-type? c-type) (eq? c-type 'void))) (let ((id ($lambda-id (exp-form `(lambda ,(cdr form)) exp-form))) (alpha (newv (car form) 'use 'global 'module "" 'cname cname 'type c-type))) (let loop ((req '()) (vars (cdr form))) (cond ((null? vars) (set-lambda-reqvars! id (reverse req))) ((c-type? vars) (set-lambda-reqvars! id (reverse req)) (set-lambda-optvars! id (list vars))) ((and (pair? vars) (c-type? (car vars))) (loop (cons (car vars) req) (cdr vars))) (else (expand-error 'define-c-external exp)))) (set-id-lambda! alpha id) (set-lambda-generate! id 'procedure) (set-lambda-name! id alpha))) (else (expand-error 'define-c-external exp)))) (expand-error 'define-c-external exp))) ;;; Compile time text macros are defined by the form: ;;; ;;; (DEFINE-MACRO id macro-expander) ;;; ;;; where "id" is the identifier which is to be expanded, and "macro-expander" ;;; is an expression which is evaluated by the compiler and returns the ;;; function which does the macro expansion. This function must be a function ;;; of two arguments, where the first is the expression containing the ;;; identifier, and the second is the function to use to recursively expand ;;; the expression. (define (DO-DEFINE-MACRO exp) (if (and (islist exp 3 3) (symbol? (cadr exp))) (put (cadr exp) 'macro (eval (caddr exp) '())) (expand-error 'define-macro exp))) ;;; Source from additional files is included in the compilation by the ;;; INCLUDE form: ;;; ;;; (INCLUDE file) ;;; ;;; where file is a string which is the file name of the file containing the ;;; additional LISP source. (define (DO-INCLUDE exp) (define (TRY-OPEN name) (let ((result (catch-error (lambda () (open-input-file name))))) (if (string? result) #f (car result)))) (let ((file-name (and (islist exp 2 2) (string? (cadr exp)) (cadr exp)))) (if file-name (let loop ((dirs sc-include-dirs)) (if dirs (let ((port (try-open (string-append (car dirs) file-name)))) (if port (begin (set! sc-input (cons port (cons sc-splice sc-input))) (set! sc-splice '())) (loop (cdr dirs)))) (report-error "Can't open INCLUDE file:" file-name))) (expand-error 'include exp)))) ;;; The module name for this compilation is defined by including one (and only ;;; one) MODULE directive: ;;; ;;; (MODULE module-name ;;; [ (MAIN main-function) ] ;;; [ (HEAP heap-size) ] ;;; [ (TOP-LEVEL function ... ) ] ;;; [ (WITH module-name ...) ] ) ;;; ;;; where module-name is a symbol which is the name for the current module and ;;; main-program is an optional symbol which denotes the "main" program. (define (DO-MODULE exp) (if (and (islist exp 2) (symbol? (cadr exp)) (not (eq? (cadr exp) 'top-level))) (begin (if (equal? module-name "") (begin (set! module-name (lchexname (cadr exp))) (set! module-name-upcase (symbol->string (cadr exp)))) (report-error "MODULE name is already defined as:" module-name)) (for-each do-module-clauses (cddr exp))) (expand-error 'module exp))) (define (DO-MODULE-CLAUSES clause) (cond ((and (islist clause 2 2) (eq? (car clause) 'main) (not main-program-name) (symbol? (cadr clause))) (if (not sc-interpreter) (set! main-program-name (cadr clause)))) ((and (islist clause 2 2) (eq? (car clause) 'heap) (integer? (cadr clause)) (positive? (cadr clause))) (set! heap-size (cadr clause))) ((and (islist clause 1) (eq? (car clause) 'top-level) (eq? top-level-symbols #t)) (set! top-level-symbols (cdr clause))) ((and (islist clause 2) (eq? (car clause) 'with) (not with-modules)) (set! with-modules (map lchexname (cdr clause)))) (else (report-error "Illegal or duplicate MODULE clause")))) ;;; Constants may be defined by the form: ;;; ;;; (DEFINE-CONSTANT symbol value) (define (DO-DEFINE-CONSTANT exp) (if (and (islist exp 3 3) (symbol? (cadr exp))) (begin (install-sc-expander (cadr exp) (list (eval (caddr exp) '()))) (eval exp)) (expand-error 'define-constant exp))) scheme2c-2012.10.14/scsc/transform.c000066400000000000000000002641011203736146400167170ustar00rootroot00000000000000 /* SCHEME->C */ #include void transform__init(); DEFSTATICTSCP( current_2dlambda_2did_v ); DEFSTATICTSCP( true_2dalpha_v ); DEFSTATICTSCP( false_2dalpha_v ); DEFSTATICTSCP( name_2da_2dlambda_v ); DEFSTATICTSCP( lambda_2dexp_v ); DEFSTATICTSCP( log_3f_v ); DEFSTATICTSCP( pretty_2dprint_2d_24tree_v ); DEFSTATICTSCP( sc_2dicode_v ); DEFCSTRING( t5983, "~A" ); DEFSTATICTSCP( c5386 ); DEFCSTRING( t5984, " replaced by lambda " ); DEFSTATICTSCP( c5249 ); DEFCSTRING( t5985, " replaced by " ); DEFSTATICTSCP( c5228 ); DEFSTATICTSCP( c4819 ); DEFSTATICTSCP( c4781 ); DEFSTATICTSCP( c4671 ); DEFSTATICTSCP( c4667 ); DEFSTATICTSCP( c4010 ); DEFSTATICTSCP( c4009 ); DEFCSTRING( t5986, "Lambda ~A collapsed~%" ); DEFSTATICTSCP( c4005 ); DEFSTATICTSCP( c3929 ); DEFSTATICTSCP( c3917 ); DEFSTATICTSCP( c3910 ); DEFSTATICTSCP( c3851 ); DEFSTATICTSCP( c3847 ); DEFSTATICTSCP( c3818 ); DEFCSTRING( t5987, "~%~%" ); DEFSTATICTSCP( c3795 ); DEFCSTRING( t5988, " => ~%" ); DEFSTATICTSCP( c3791 ); DEFSTATICTSCP( c3787 ); DEFSTATICTSCP( c3710 ); DEFSTATICTSCP( c3504 ); DEFSTATICTSCP( c3503 ); DEFSTATICTSCP( c3476 ); DEFSTATICTSCP( c3216 ); DEFSTATICTSCP( t5989 ); DEFSTATICTSCP( t5990 ); DEFSTATICTSCP( t5991 ); DEFSTATICTSCP( c3178 ); DEFSTATICTSCP( c3165 ); DEFSTATICTSCP( c2965 ); DEFSTATICTSCP( c2882 ); DEFSTATICTSCP( c2833 ); DEFSTATICTSCP( c2832 ); DEFSTATICTSCP( c2603 ); DEFSTATICTSCP( c2358 ); DEFCSTRING( t5992, "Argument not a PAIR: ~s" ); DEFSTATICTSCP( c2126 ); DEFSTATICTSCP( c2125 ); DEFSTATICTSCP( c2115 ); DEFSTATICTSCP( c2099 ); DEFSTATICTSCP( c2083 ); DEFSTATICTSCP( c2067 ); DEFSTATICTSCP( c2051 ); static void init_constants() { TSCP X1; current_2dlambda_2did_v = STRINGTOSYMBOL( CSTRING_TSCP( "CURRENT-LAM\ BDA-ID" ) ); CONSTANTEXP( ADR( current_2dlambda_2did_v ) ); true_2dalpha_v = STRINGTOSYMBOL( CSTRING_TSCP( "TRUE-ALPHA" ) ); CONSTANTEXP( ADR( true_2dalpha_v ) ); false_2dalpha_v = STRINGTOSYMBOL( CSTRING_TSCP( "FALSE-ALPHA" ) ); CONSTANTEXP( ADR( false_2dalpha_v ) ); name_2da_2dlambda_v = STRINGTOSYMBOL( CSTRING_TSCP( "NAME-A-LAMBDA" ) ); CONSTANTEXP( ADR( name_2da_2dlambda_v ) ); lambda_2dexp_v = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA-EXP" ) ); CONSTANTEXP( ADR( lambda_2dexp_v ) ); log_3f_v = STRINGTOSYMBOL( CSTRING_TSCP( "LOG?" ) ); CONSTANTEXP( ADR( log_3f_v ) ); pretty_2dprint_2d_24tree_v = STRINGTOSYMBOL( CSTRING_TSCP( "PRETTY-P\ RINT-$TREE" ) ); CONSTANTEXP( ADR( pretty_2dprint_2d_24tree_v ) ); sc_2dicode_v = STRINGTOSYMBOL( CSTRING_TSCP( "SC-ICODE" ) ); CONSTANTEXP( ADR( sc_2dicode_v ) ); c5386 = CSTRING_TSCP( t5983 ); CONSTANTEXP( ADR( c5386 ) ); c5249 = CSTRING_TSCP( t5984 ); CONSTANTEXP( ADR( c5249 ) ); c5228 = CSTRING_TSCP( t5985 ); CONSTANTEXP( ADR( c5228 ) ); c4819 = STRINGTOSYMBOL( CSTRING_TSCP( "LEXICAL" ) ); CONSTANTEXP( ADR( c4819 ) ); c4781 = STRINGTOSYMBOL( CSTRING_TSCP( "OPTVARS" ) ); CONSTANTEXP( ADR( c4781 ) ); c4671 = STRINGTOSYMBOL( CSTRING_TSCP( "DISPLAY" ) ); CONSTANTEXP( ADR( c4671 ) ); c4667 = STRINGTOSYMBOL( CSTRING_TSCP( "SET!" ) ); CONSTANTEXP( ADR( c4667 ) ); c4010 = STRINGTOSYMBOL( CSTRING_TSCP( "INLINE" ) ); CONSTANTEXP( ADR( c4010 ) ); c4009 = STRINGTOSYMBOL( CSTRING_TSCP( "GENERATE" ) ); CONSTANTEXP( ADR( c4009 ) ); c4005 = CSTRING_TSCP( t5986 ); CONSTANTEXP( ADR( c4005 ) ); c3929 = STRINGTOSYMBOL( CSTRING_TSCP( "BOTH" ) ); CONSTANTEXP( ADR( c3929 ) ); c3917 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-CHANGE" ) ); CONSTANTEXP( ADR( c3917 ) ); c3910 = STRINGTOSYMBOL( CSTRING_TSCP( "NO-VALUE" ) ); CONSTANTEXP( ADR( c3910 ) ); c3851 = STRINGTOSYMBOL( CSTRING_TSCP( "CALLS" ) ); CONSTANTEXP( ADR( c3851 ) ); c3847 = STRINGTOSYMBOL( CSTRING_TSCP( "REFS" ) ); CONSTANTEXP( ADR( c3847 ) ); c3818 = STRINGTOSYMBOL( CSTRING_TSCP( "TCL" ) ); CONSTANTEXP( ADR( c3818 ) ); c3795 = CSTRING_TSCP( t5987 ); CONSTANTEXP( ADR( c3795 ) ); c3791 = CSTRING_TSCP( t5988 ); CONSTANTEXP( ADR( c3791 ) ); c3787 = STRINGTOSYMBOL( CSTRING_TSCP( "TRANSFORM" ) ); CONSTANTEXP( ADR( c3787 ) ); c3710 = STRINGTOSYMBOL( CSTRING_TSCP( "VALUE" ) ); CONSTANTEXP( ADR( c3710 ) ); c3504 = STRINGTOSYMBOL( CSTRING_TSCP( "CONSTANT" ) ); CONSTANTEXP( ADR( c3504 ) ); c3503 = STRINGTOSYMBOL( CSTRING_TSCP( "USE" ) ); CONSTANTEXP( ADR( c3503 ) ); c3476 = STRINGTOSYMBOL( CSTRING_TSCP( "IF2" ) ); CONSTANTEXP( ADR( c3476 ) ); c3216 = EMPTYLIST; X1 = EMPTYLIST; t5989 = STRINGTOSYMBOL( CSTRING_TSCP( "Y" ) ); X1 = CONS( t5989, X1 ); t5990 = STRINGTOSYMBOL( CSTRING_TSCP( "X" ) ); X1 = CONS( t5990, X1 ); c3216 = CONS( X1, c3216 ); t5991 = STRINGTOSYMBOL( CSTRING_TSCP( "LAMBDA" ) ); c3216 = CONS( t5991, c3216 ); CONSTANTEXP( ADR( c3216 ) ); c3178 = STRINGTOSYMBOL( CSTRING_TSCP( "REQVARS" ) ); CONSTANTEXP( ADR( c3178 ) ); c3165 = EMPTYLIST; c3165 = CONS( EMPTYLIST, c3165 ); c3165 = CONS( t5991, c3165 ); CONSTANTEXP( ADR( c3165 ) ); c2965 = STRINGTOSYMBOL( CSTRING_TSCP( "NOT" ) ); CONSTANTEXP( ADR( c2965 ) ); c2882 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAP" ) ); CONSTANTEXP( ADR( c2882 ) ); c2833 = STRINGTOSYMBOL( CSTRING_TSCP( "BOOLEAN" ) ); CONSTANTEXP( ADR( c2833 ) ); c2832 = STRINGTOSYMBOL( CSTRING_TSCP( "TYPE" ) ); CONSTANTEXP( ADR( c2832 ) ); c2603 = STRINGTOSYMBOL( CSTRING_TSCP( "IF1" ) ); CONSTANTEXP( ADR( c2603 ) ); c2358 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CDR!" ) ); CONSTANTEXP( ADR( c2358 ) ); c2126 = CSTRING_TSCP( t5992 ); CONSTANTEXP( ADR( c2126 ) ); c2125 = STRINGTOSYMBOL( CSTRING_TSCP( "SET-CAR!" ) ); CONSTANTEXP( ADR( c2125 ) ); c2115 = STRINGTOSYMBOL( CSTRING_TSCP( "$SET" ) ); CONSTANTEXP( ADR( c2115 ) ); c2099 = STRINGTOSYMBOL( CSTRING_TSCP( "$DEFINE" ) ); CONSTANTEXP( ADR( c2099 ) ); c2083 = STRINGTOSYMBOL( CSTRING_TSCP( "$IF" ) ); CONSTANTEXP( ADR( c2083 ) ); c2067 = STRINGTOSYMBOL( CSTRING_TSCP( "$LAMBDA" ) ); CONSTANTEXP( ADR( c2067 ) ); c2051 = STRINGTOSYMBOL( CSTRING_TSCP( "$CALL" ) ); CONSTANTEXP( ADR( c2051 ) ); } DEFTSCP( transform_transform_2dstack_v ); DEFCSTRING( t5993, "TRANSFORM-STACK" ); DEFTSCP( transform_transform_v ); DEFCSTRING( t5994, "TRANSFORM" ); EXTERNTSCPP( sc_cons, XAL2( TSCP, TSCP ) ); EXTERNTSCP( sc_cons_v ); EXTERNTSCPP( transform_transformx, XAL1( TSCP ) ); EXTERNTSCP( transform_transformx_v ); TSCP transform_transform( e2028 ) TSCP e2028; { TSCP X2, X1; PUSHSTACKTRACE( t5994 ); X1 = transform_transform_2dstack_v; transform_transform_2dstack_v = sc_cons( e2028, transform_transform_2dstack_v ); X2 = transform_transformx( e2028 ); transform_transform_2dstack_v = X1; POPSTACKTRACE( X2 ); } DEFTSCP( transform_transformx_v ); DEFCSTRING( t5998, "TRANSFORMX" ); EXTERNTSCPP( scrt1__24__car_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__car_2derror_v ); EXTERNTSCPP( scrt1_caddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_caddr_v ); EXTERNTSCPP( scrt1__24__cdr_2derror, XAL1( TSCP ) ); EXTERNTSCP( scrt1__24__cdr_2derror_v ); EXTERNTSCPP( scdebug_error, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( scdebug_error_v ); EXTERNTSCPP( scrt1_cdddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cdddr_v ); EXTERNTSCPP( transform_l_2dlambda_8f20e049, XAL1( TSCP ) ); EXTERNTSCP( transform_l_2dlambda_8f20e049_v ); EXTERNTSCPP( transform_transform_2dif1, XAL1( TSCP ) ); EXTERNTSCP( transform_transform_2dif1_v ); EXTERNTSCPP( scrt1_cadddr, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadddr_v ); EXTERNTSCPP( transform_transform_2dif2, XAL1( TSCP ) ); EXTERNTSCP( transform_transform_2dif2_v ); TSCP transform_transformx( e2035 ) TSCP e2035; { TSCP X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t5998 ); X1 = BOOLEAN( EQ( TSCPTAG( e2035 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L6060; if ( EQ( TSCPTAG( e2035 ), PAIRTAG ) ) goto L6007; scrt1__24__car_2derror( e2035 ); L6007: X2 = PAIR_CAR( e2035 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2051 ) ) ) goto L6060; X5 = PAIR_CAR( e2035 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X4 ) ) goto L6012; X3 = scrt1_caddr( e2035 ); goto L6013; L6012: X3 = X4; L6013: X2 = transform_transform( X3 ); X4 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6017; scrt1__24__cdr_2derror( X4 ); L6017: X3 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6020; scdebug_error( c2125, c2126, CONS( X3, EMPTYLIST ) ); L6020: SETGEN( PAIR_CAR( X3 ), X2 ); X5 = PAIR_CAR( e2035 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X4 ) ) goto L6024; X3 = scrt1_cdddr( e2035 ); goto L6025; L6024: X3 = X4; L6025: X4 = X3; X5 = EMPTYLIST; X6 = EMPTYLIST; L6028: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L6029; X2 = X5; goto L6036; L6029: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6032; scrt1__24__car_2derror( X4 ); L6032: X9 = PAIR_CAR( X4 ); X8 = transform_transform( X9 ); X7 = sc_cons( X8, EMPTYLIST ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L6035; X8 = PAIR_CDR( X4 ); X6 = X7; X5 = X7; X4 = X8; GOBACK( L6028 ); L6035: X8 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6040; scdebug_error( c2358, c2126, CONS( X6, EMPTYLIST ) ); L6040: X6 = SETGEN( PAIR_CDR( X6 ), X7 ); X4 = X8; GOBACK( L6028 ); L6036: X4 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6045; scrt1__24__cdr_2derror( X4 ); L6045: X3 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6048; scdebug_error( c2358, c2126, CONS( X3, EMPTYLIST ) ); L6048: SETGEN( PAIR_CDR( X3 ), X2 ); X4 = PAIR_CAR( e2035 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X3 ) ) goto L6052; X2 = scrt1_caddr( e2035 ); goto L6053; L6052: X2 = X3; L6053: if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6055; X3 = PAIR_CAR( X2 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2067 ) ) ) goto L6057; POPSTACKTRACE( transform_l_2dlambda_8f20e049( e2035 ) ); L6057: POPSTACKTRACE( e2035 ); L6055: POPSTACKTRACE( e2035 ); L6060: X1 = BOOLEAN( EQ( TSCPTAG( e2035 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L6108; if ( EQ( TSCPTAG( e2035 ), PAIRTAG ) ) goto L6068; scrt1__24__car_2derror( e2035 ); L6068: X2 = PAIR_CAR( e2035 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2067 ) ) ) goto L6108; X2 = SYMBOL_VALUE( current_2dlambda_2did_v ); X4 = PAIR_CAR( e2035 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2067 ) ) ); if ( FALSE( X3 ) ) goto L6073; X5 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6077; scrt1__24__car_2derror( X5 ); L6077: X4 = PAIR_CAR( X5 ); goto L6074; L6073: X4 = X3; L6074: SETGENTL( SYMBOL_VALUE( current_2dlambda_2did_v ), X4 ); X6 = PAIR_CAR( e2035 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2067 ) ) ); if ( FALSE( X5 ) ) goto L6081; X6 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6085; scrt1__24__cdr_2derror( X6 ); L6085: X4 = PAIR_CDR( X6 ); goto L6082; L6081: X4 = X5; L6082: X5 = X4; X6 = EMPTYLIST; X7 = EMPTYLIST; L6089: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L6090; X3 = X6; goto L6097; L6090: if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6093; scrt1__24__car_2derror( X5 ); L6093: X10 = PAIR_CAR( X5 ); X9 = transform_transform( X10 ); X8 = sc_cons( X9, EMPTYLIST ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L6096; X9 = PAIR_CDR( X5 ); X7 = X8; X6 = X8; X5 = X9; GOBACK( L6089 ); L6096: X9 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6101; scdebug_error( c2358, c2126, CONS( X7, EMPTYLIST ) ); L6101: X7 = SETGEN( PAIR_CDR( X7 ), X8 ); X5 = X9; GOBACK( L6089 ); L6097: X4 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6106; scdebug_error( c2358, c2126, CONS( X4, EMPTYLIST ) ); L6106: SETGEN( PAIR_CDR( X4 ), X3 ); SETGENTL( SYMBOL_VALUE( current_2dlambda_2did_v ), X2 ); POPSTACKTRACE( e2035 ); L6108: X1 = BOOLEAN( EQ( TSCPTAG( e2035 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L6155; if ( EQ( TSCPTAG( e2035 ), PAIRTAG ) ) goto L6116; scrt1__24__car_2derror( e2035 ); L6116: X2 = PAIR_CAR( e2035 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2083 ) ) ) goto L6155; X2 = transform_transform_2dif1( e2035 ); if ( TRUE( X2 ) ) goto L6119; X6 = PAIR_CAR( e2035 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X5 ) ) goto L6124; X6 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6128; scrt1__24__car_2derror( X6 ); L6128: X4 = PAIR_CAR( X6 ); goto L6125; L6124: X4 = X5; L6125: X3 = transform_transform( X4 ); X4 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6133; scdebug_error( c2125, c2126, CONS( X4, EMPTYLIST ) ); L6133: SETGEN( PAIR_CAR( X4 ), X3 ); X6 = PAIR_CAR( e2035 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X5 ) ) goto L6137; X4 = scrt1_caddr( e2035 ); goto L6138; L6137: X4 = X5; L6138: X3 = transform_transform( X4 ); X5 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6142; scrt1__24__cdr_2derror( X5 ); L6142: X4 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6145; scdebug_error( c2125, c2126, CONS( X4, EMPTYLIST ) ); L6145: SETGEN( PAIR_CAR( X4 ), X3 ); X6 = PAIR_CAR( e2035 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X5 ) ) goto L6149; X4 = scrt1_cadddr( e2035 ); goto L6150; L6149: X4 = X5; L6150: X3 = transform_transform( X4 ); X4 = scrt1_cdddr( e2035 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6153; scdebug_error( c2125, c2126, CONS( X4, EMPTYLIST ) ); L6153: SETGEN( PAIR_CAR( X4 ), X3 ); POPSTACKTRACE( transform_transform_2dif2( e2035 ) ); L6119: POPSTACKTRACE( X2 ); L6155: X1 = BOOLEAN( EQ( TSCPTAG( e2035 ), PAIRTAG ) ); if ( FALSE( X1 ) ) goto L6178; if ( EQ( TSCPTAG( e2035 ), PAIRTAG ) ) goto L6163; scrt1__24__car_2derror( e2035 ); L6163: X2 = PAIR_CAR( e2035 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2099 ) ) ) goto L6178; X5 = PAIR_CAR( e2035 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2099 ) ) ); if ( FALSE( X4 ) ) goto L6168; X3 = scrt1_caddr( e2035 ); goto L6169; L6168: X3 = X4; L6169: X2 = transform_transform( X3 ); X4 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6173; scrt1__24__cdr_2derror( X4 ); L6173: X3 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6176; scdebug_error( c2125, c2126, CONS( X3, EMPTYLIST ) ); L6176: SETGEN( PAIR_CAR( X3 ), X2 ); POPSTACKTRACE( e2035 ); L6178: if ( NEQ( TSCPTAG( e2035 ), PAIRTAG ) ) goto L6179; X1 = PAIR_CAR( e2035 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2115 ) ) ) goto L6181; X4 = PAIR_CAR( e2035 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2115 ) ) ); if ( FALSE( X3 ) ) goto L6187; X2 = scrt1_caddr( e2035 ); goto L6188; L6187: X2 = X3; L6188: X1 = transform_transform( X2 ); X3 = PAIR_CDR( e2035 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6192; scrt1__24__cdr_2derror( X3 ); L6192: X2 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6195; scdebug_error( c2125, c2126, CONS( X2, EMPTYLIST ) ); L6195: SETGEN( PAIR_CAR( X2 ), X1 ); POPSTACKTRACE( e2035 ); L6181: POPSTACKTRACE( e2035 ); L6179: POPSTACKTRACE( e2035 ); } DEFTSCP( transform_transform_2dif1_v ); DEFCSTRING( t6197, "TRANSFORM-IF1" ); EXTERNTSCPP( transform_log_2dbefore, XAL1( TSCP ) ); EXTERNTSCP( transform_log_2dbefore_v ); EXTERNTSCPP( scrt1_last_2dpair, XAL1( TSCP ) ); EXTERNTSCP( scrt1_last_2dpair_v ); EXTERNTSCPP( scrt1_cons_2a, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_cons_2a_v ); EXTERNTSCPP( transform_log_2dafter, XAL1( TSCP ) ); EXTERNTSCP( transform_log_2dafter_v ); EXTERNTSCPP( plist_get, XAL2( TSCP, TSCP ) ); EXTERNTSCP( plist_get_v ); EXTERNTSCPP( scrt1_cadar, XAL1( TSCP ) ); EXTERNTSCP( scrt1_cadar_v ); TSCP transform_transform_2dif1( e2596 ) TSCP e2596; { TSCP X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6197 ); if ( NEQ( TSCPTAG( e2596 ), PAIRTAG ) ) goto L6199; X5 = PAIR_CAR( e2596 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ); goto L6200; L6199: X4 = FALSEVALUE; L6200: if ( FALSE( X4 ) ) goto L6203; X1 = scrt1_cadddr( e2596 ); goto L6204; L6203: X1 = X4; L6204: if ( NEQ( TSCPTAG( e2596 ), PAIRTAG ) ) goto L6205; X5 = PAIR_CAR( e2596 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ); goto L6206; L6205: X4 = FALSEVALUE; L6206: if ( FALSE( X4 ) ) goto L6209; X2 = scrt1_caddr( e2596 ); goto L6210; L6209: X2 = X4; L6210: if ( NEQ( TSCPTAG( e2596 ), PAIRTAG ) ) goto L6211; X5 = PAIR_CAR( e2596 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ); goto L6212; L6211: X4 = FALSEVALUE; L6212: if ( FALSE( X4 ) ) goto L6215; if ( EQ( TSCPTAG( e2596 ), PAIRTAG ) ) goto L6218; scrt1__24__cdr_2derror( e2596 ); L6218: X5 = PAIR_CDR( e2596 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6221; scrt1__24__car_2derror( X5 ); L6221: X3 = PAIR_CAR( X5 ); goto L6216; L6215: X3 = X4; L6216: X6 = sc_cons( e2596, EMPTYLIST ); X5 = sc_cons( c2603, X6 ); X4 = X5; transform_transform_2dstack_v = sc_cons( X4, transform_transform_2dstack_v ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6225; X5 = PAIR_CAR( X3 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2051 ) ) ); goto L6226; L6225: X4 = FALSEVALUE; L6226: if ( FALSE( X4 ) ) goto L6271; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6232; X7 = PAIR_CAR( X3 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2051 ) ) ); goto L6233; L6232: X6 = FALSEVALUE; L6233: if ( FALSE( X6 ) ) goto L6236; X5 = scrt1_caddr( X3 ); goto L6237; L6236: X5 = X6; L6237: if ( NEQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6271; X6 = PAIR_CAR( X5 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( c2067 ) ) ) goto L6271; transform_log_2dbefore( e2596 ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6246; X10 = PAIR_CAR( X3 ); X9 = BOOLEAN( EQ( _S2CUINT( X10 ), _S2CUINT( c2051 ) ) ); goto L6247; L6246: X9 = FALSEVALUE; L6247: if ( FALSE( X9 ) ) goto L6250; X8 = scrt1_caddr( X3 ); goto L6251; L6250: X8 = X9; L6251: if ( NEQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L6253; X10 = PAIR_CAR( X8 ); X9 = BOOLEAN( EQ( _S2CUINT( X10 ), _S2CUINT( c2067 ) ) ); goto L6254; L6253: X9 = FALSEVALUE; L6254: if ( FALSE( X9 ) ) goto L6257; if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L6260; scrt1__24__cdr_2derror( X8 ); L6260: X10 = PAIR_CDR( X8 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L6263; scrt1__24__cdr_2derror( X10 ); L6263: X7 = PAIR_CDR( X10 ); goto L6258; L6257: X7 = X9; L6258: X6 = scrt1_last_2dpair( X7 ); X8 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( X1, X8 ); X8 = CONS( X2, X8 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6267; scrt1__24__car_2derror( X6 ); L6267: X7 = scrt1_cons_2a( c2083, CONS( PAIR_CAR( X6 ), X8 ) ); SETGEN( PAIR_CAR( X6 ), X7 ); X7 = transform_log_2dafter( X3 ); POPSTACKTRACE( transform_transform( X7 ) ); L6271: if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6272; X5 = PAIR_CAR( X3 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ); goto L6273; L6272: X4 = FALSEVALUE; L6273: if ( FALSE( X4 ) ) goto L6317; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6282; X7 = PAIR_CAR( X3 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2083 ) ) ); goto L6283; L6282: X6 = FALSEVALUE; L6283: if ( FALSE( X6 ) ) goto L6286; X5 = scrt1_caddr( X3 ); goto L6287; L6286: X5 = X6; L6287: X6 = SYMBOL_VALUE( true_2dalpha_v ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( X6 ) ) ) goto L6317; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6290; X7 = PAIR_CAR( X3 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2083 ) ) ); goto L6291; L6290: X6 = FALSEVALUE; L6291: if ( FALSE( X6 ) ) goto L6294; X5 = scrt1_cadddr( X3 ); goto L6295; L6294: X5 = X6; L6295: X6 = SYMBOL_VALUE( false_2dalpha_v ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( X6 ) ) ) goto L6317; transform_log_2dbefore( e2596 ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6297; X7 = PAIR_CAR( X3 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2083 ) ) ); goto L6298; L6297: X6 = FALSEVALUE; L6298: if ( FALSE( X6 ) ) goto L6301; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6304; scrt1__24__cdr_2derror( X3 ); L6304: X7 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6307; scrt1__24__car_2derror( X7 ); L6307: X5 = PAIR_CAR( X7 ); goto L6302; L6301: X5 = X6; L6302: if ( EQ( TSCPTAG( e2596 ), PAIRTAG ) ) goto L6311; scrt1__24__cdr_2derror( e2596 ); L6311: X6 = PAIR_CDR( e2596 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6314; scdebug_error( c2125, c2126, CONS( X6, EMPTYLIST ) ); L6314: SETGEN( PAIR_CAR( X6 ), X5 ); X5 = transform_log_2dafter( e2596 ); POPSTACKTRACE( transform_transform( X5 ) ); L6317: if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6318; X5 = PAIR_CAR( X3 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ); goto L6319; L6318: X4 = FALSEVALUE; L6319: if ( FALSE( X4 ) ) goto L6373; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6328; X7 = PAIR_CAR( X3 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2083 ) ) ); goto L6329; L6328: X6 = FALSEVALUE; L6329: if ( FALSE( X6 ) ) goto L6332; X5 = scrt1_caddr( X3 ); goto L6333; L6332: X5 = X6; L6333: X6 = SYMBOL_VALUE( false_2dalpha_v ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( X6 ) ) ) goto L6373; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6336; X7 = PAIR_CAR( X3 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2083 ) ) ); goto L6337; L6336: X6 = FALSEVALUE; L6337: if ( FALSE( X6 ) ) goto L6340; X5 = scrt1_cadddr( X3 ); goto L6341; L6340: X5 = X6; L6341: X6 = SYMBOL_VALUE( true_2dalpha_v ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( X6 ) ) ) goto L6373; transform_log_2dbefore( e2596 ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6343; X7 = PAIR_CAR( X3 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2083 ) ) ); goto L6344; L6343: X6 = FALSEVALUE; L6344: if ( FALSE( X6 ) ) goto L6347; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6350; scrt1__24__cdr_2derror( X3 ); L6350: X7 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6353; scrt1__24__car_2derror( X7 ); L6353: X5 = PAIR_CAR( X7 ); goto L6348; L6347: X5 = X6; L6348: if ( EQ( TSCPTAG( e2596 ), PAIRTAG ) ) goto L6357; scrt1__24__cdr_2derror( e2596 ); L6357: X6 = PAIR_CDR( e2596 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6360; scdebug_error( c2125, c2126, CONS( X6, EMPTYLIST ) ); L6360: SETGEN( PAIR_CAR( X6 ), X5 ); X6 = PAIR_CDR( e2596 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6364; scrt1__24__cdr_2derror( X6 ); L6364: X5 = PAIR_CDR( X6 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6367; scdebug_error( c2125, c2126, CONS( X5, EMPTYLIST ) ); L6367: SETGEN( PAIR_CAR( X5 ), X1 ); X5 = scrt1_cdddr( e2596 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6370; scdebug_error( c2125, c2126, CONS( X5, EMPTYLIST ) ); L6370: SETGEN( PAIR_CAR( X5 ), X2 ); X5 = transform_log_2dafter( e2596 ); POPSTACKTRACE( transform_transform( X5 ) ); L6373: X4 = BOOLEAN( EQ( TSCPTAG( X3 ), PAIRTAG ) ); if ( FALSE( X4 ) ) goto L6451; if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6381; scrt1__24__car_2derror( X3 ); L6381: X5 = PAIR_CAR( X3 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ) goto L6451; transform_log_2dbefore( e2596 ); X6 = SYMBOL_VALUE( lambda_2dexp_v ); X6 = UNKNOWNCALL( X6, 2 ); X5 = VIA( PROCEDURE_CODE( X6 ) )( c3216, EMPTYLIST, PROCEDURE_CLOSURE( X6 ) ); if ( NEQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6385; X8 = PAIR_CAR( X5 ); X7 = BOOLEAN( EQ( _S2CUINT( X8 ), _S2CUINT( c2067 ) ) ); goto L6386; L6385: X7 = FALSEVALUE; L6386: if ( FALSE( X7 ) ) goto L6389; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6392; scrt1__24__cdr_2derror( X5 ); L6392: X8 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L6395; scrt1__24__car_2derror( X8 ); L6395: X6 = PAIR_CAR( X8 ); goto L6390; L6389: X6 = X7; L6390: X8 = plist_get( X6, c3178 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L6399; scrt1__24__car_2derror( X8 ); L6399: X7 = PAIR_CAR( X8 ); X9 = plist_get( X6, c3178 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L6404; scrt1__24__cdr_2derror( X9 ); L6404: X10 = PAIR_CDR( X9 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L6407; scrt1__24__car_2derror( X10 ); L6407: X8 = PAIR_CAR( X10 ); X10 = SYMBOL_VALUE( lambda_2dexp_v ); X10 = UNKNOWNCALL( X10, 2 ); X9 = VIA( PROCEDURE_CODE( X10 ) )( c3165, EMPTYLIST, PROCEDURE_CLOSURE( X10 ) ); X11 = SYMBOL_VALUE( lambda_2dexp_v ); X11 = UNKNOWNCALL( X11, 2 ); X10 = VIA( PROCEDURE_CODE( X11 ) )( c3165, EMPTYLIST, PROCEDURE_CLOSURE( X11 ) ); X12 = sc_cons( X2, EMPTYLIST ); X11 = X12; if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L6415; scrt1__24__cdr_2derror( X9 ); L6415: X12 = PAIR_CDR( X9 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L6418; scdebug_error( c2358, c2126, CONS( X12, EMPTYLIST ) ); L6418: SETGEN( PAIR_CDR( X12 ), X11 ); X12 = sc_cons( X1, EMPTYLIST ); X11 = X12; if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L6423; scrt1__24__cdr_2derror( X10 ); L6423: X12 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L6426; scdebug_error( c2358, c2126, CONS( X12, EMPTYLIST ) ); L6426: SETGEN( PAIR_CDR( X12 ), X11 ); X13 = CONS( EMPTYLIST, EMPTYLIST ); X14 = CONS( EMPTYLIST, EMPTYLIST ); X15 = CONS( EMPTYLIST, EMPTYLIST ); X15 = CONS( X8, X15 ); X14 = CONS( scrt1_cons_2a( c2051, CONS( EMPTYLIST, X15 ) ), X14 ); X15 = CONS( EMPTYLIST, EMPTYLIST ); X15 = CONS( X7, X15 ); X14 = CONS( scrt1_cons_2a( c2051, CONS( EMPTYLIST, X15 ) ), X14 ); X16 = PAIR_CAR( X3 ); X15 = BOOLEAN( EQ( _S2CUINT( X16 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X15 ) ) goto L6430; X16 = scrt1_cadddr( X3 ); goto L6431; L6430: X16 = X15; L6431: X13 = CONS( scrt1_cons_2a( c2083, CONS( X16, X14 ) ), X13 ); X14 = CONS( EMPTYLIST, EMPTYLIST ); X15 = CONS( EMPTYLIST, EMPTYLIST ); X15 = CONS( X8, X15 ); X14 = CONS( scrt1_cons_2a( c2051, CONS( EMPTYLIST, X15 ) ), X14 ); X15 = CONS( EMPTYLIST, EMPTYLIST ); X15 = CONS( X7, X15 ); X14 = CONS( scrt1_cons_2a( c2051, CONS( EMPTYLIST, X15 ) ), X14 ); X16 = PAIR_CAR( X3 ); X15 = BOOLEAN( EQ( _S2CUINT( X16 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X15 ) ) goto L6434; X16 = scrt1_caddr( X3 ); goto L6435; L6434: X16 = X15; L6435: X13 = CONS( scrt1_cons_2a( c2083, CONS( X16, X14 ) ), X13 ); X15 = PAIR_CAR( X3 ); X14 = BOOLEAN( EQ( _S2CUINT( X15 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X14 ) ) goto L6438; X16 = PAIR_CDR( X3 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L6442; scrt1__24__car_2derror( X16 ); L6442: X15 = PAIR_CAR( X16 ); goto L6439; L6438: X15 = X14; L6439: X12 = scrt1_cons_2a( c2083, CONS( X15, X13 ) ); X11 = scrt1_cons_2a( X12, CONS( EMPTYLIST, EMPTYLIST ) ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6446; scrt1__24__cdr_2derror( X5 ); L6446: X12 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L6449; scdebug_error( c2358, c2126, CONS( X12, EMPTYLIST ) ); L6449: SETGEN( PAIR_CDR( X12 ), X11 ); X11 = SYMBOL_VALUE( name_2da_2dlambda_v ); X11 = UNKNOWNCALL( X11, 2 ); VIA( PROCEDURE_CODE( X11 ) )( X7, X9, PROCEDURE_CLOSURE( X11 ) ); X11 = SYMBOL_VALUE( name_2da_2dlambda_v ); X11 = UNKNOWNCALL( X11, 2 ); VIA( PROCEDURE_CODE( X11 ) )( X8, X10, PROCEDURE_CLOSURE( X11 ) ); X13 = CONS( EMPTYLIST, EMPTYLIST ); X13 = CONS( X10, X13 ); X13 = CONS( X9, X13 ); X13 = CONS( X5, X13 ); X12 = scrt1_cons_2a( c2051, CONS( EMPTYLIST, X13 ) ); X11 = transform_log_2dafter( X12 ); POPSTACKTRACE( transform_transform( X11 ) ); L6451: X4 = BOOLEAN( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ); if ( FALSE( X4 ) ) goto L6473; X5 = plist_get( X3, c2832 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2833 ) ) ) goto L6473; if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X3 ) ) ) goto L6473; transform_log_2dbefore( e2596 ); X5 = SYMBOL_VALUE( true_2dalpha_v ); if ( EQ( TSCPTAG( e2596 ), PAIRTAG ) ) goto L6464; scrt1__24__cdr_2derror( e2596 ); L6464: X7 = PAIR_CDR( e2596 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6467; scrt1__24__cdr_2derror( X7 ); L6467: X6 = PAIR_CDR( X7 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6470; scdebug_error( c2125, c2126, CONS( X6, EMPTYLIST ) ); L6470: SETGEN( PAIR_CAR( X6 ), X5 ); X5 = transform_log_2dafter( e2596 ); POPSTACKTRACE( transform_transform( X5 ) ); L6473: X4 = BOOLEAN( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ); if ( FALSE( X4 ) ) goto L6489; X5 = plist_get( X3, c2832 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2833 ) ) ) goto L6489; if ( NEQ( _S2CUINT( X1 ), _S2CUINT( X3 ) ) ) goto L6489; transform_log_2dbefore( e2596 ); X5 = SYMBOL_VALUE( false_2dalpha_v ); X6 = scrt1_cdddr( e2596 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6486; scdebug_error( c2125, c2126, CONS( X6, EMPTYLIST ) ); L6486: SETGEN( PAIR_CAR( X6 ), X5 ); X5 = transform_log_2dafter( e2596 ); POPSTACKTRACE( transform_transform( X5 ) ); L6489: if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6492; X7 = PAIR_CAR( X3 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2051 ) ) ); goto L6493; L6492: X6 = FALSEVALUE; L6493: if ( FALSE( X6 ) ) goto L6496; X5 = scrt1_caddr( X3 ); goto L6497; L6496: X5 = X6; L6497: if ( NEQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6499; X7 = PAIR_CAR( X5 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2882 ) ) ); goto L6500; L6499: X6 = FALSEVALUE; L6500: if ( FALSE( X6 ) ) goto L6503; if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6506; scrt1__24__cdr_2derror( X5 ); L6506: X7 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6509; scrt1__24__car_2derror( X7 ); L6509: X4 = PAIR_CAR( X7 ); goto L6504; L6503: X4 = X6; L6504: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2833 ) ) ) goto L6490; X5 = SYMBOL_VALUE( true_2dalpha_v ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X5 ) ) ) goto L6511; X5 = SYMBOL_VALUE( false_2dalpha_v ); X4 = BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( X5 ) ) ); goto L6512; L6511: X4 = FALSEVALUE; L6512: if ( TRUE( X4 ) ) goto L6517; X5 = SYMBOL_VALUE( false_2dalpha_v ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( X5 ) ) ) goto L6518; X5 = SYMBOL_VALUE( true_2dalpha_v ); if ( EQ( _S2CUINT( X1 ), _S2CUINT( X5 ) ) ) goto L6517; POPSTACKTRACE( FALSEVALUE ); L6518: POPSTACKTRACE( FALSEVALUE ); L6490: POPSTACKTRACE( FALSEVALUE ); L6517: transform_log_2dbefore( e2596 ); X4 = SYMBOL_VALUE( true_2dalpha_v ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( X4 ) ) ) goto L6523; if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6525; X6 = PAIR_CAR( X3 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2051 ) ) ); goto L6526; L6525: X5 = FALSEVALUE; L6526: if ( FALSE( X5 ) ) goto L6529; X4 = scrt1_caddr( X3 ); goto L6530; L6529: X4 = X5; L6530: X7 = CONS( EMPTYLIST, EMPTYLIST ); X8 = CONS( EMPTYLIST, EMPTYLIST ); if ( NEQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6532; X11 = PAIR_CAR( X4 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2882 ) ) ); goto L6533; L6532: X10 = FALSEVALUE; L6533: if ( FALSE( X10 ) ) goto L6536; X9 = scrt1_cdddr( X4 ); goto L6537; L6536: X9 = X10; L6537: X6 = scrt1_cons_2a( c2833, CONS( scrt1_cons_2a( c2965, CONS( scrt1_cadar( X9 ), X8 ) ), X7 ) ); X5 = scrt1_cons_2a( X6, CONS( EMPTYLIST, EMPTYLIST ) ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6540; scrt1__24__cdr_2derror( X4 ); L6540: X7 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6543; scrt1__24__cdr_2derror( X7 ); L6543: X6 = PAIR_CDR( X7 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6546; scdebug_error( c2358, c2126, CONS( X6, EMPTYLIST ) ); L6546: SETGEN( PAIR_CDR( X6 ), X5 ); L6523: X4 = transform_log_2dafter( X3 ); POPSTACKTRACE( transform_transform( X4 ) ); } DEFTSCP( transform_transform_2dif2_v ); DEFCSTRING( t6548, "TRANSFORM-IF2" ); TSCP transform_transform_2dif2( e3469 ) TSCP e3469; { TSCP X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6548 ); L6549: if ( NEQ( TSCPTAG( e3469 ), PAIRTAG ) ) goto L6550; X5 = PAIR_CAR( e3469 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ); goto L6551; L6550: X4 = FALSEVALUE; L6551: if ( FALSE( X4 ) ) goto L6554; X1 = scrt1_cadddr( e3469 ); goto L6555; L6554: X1 = X4; L6555: if ( NEQ( TSCPTAG( e3469 ), PAIRTAG ) ) goto L6556; X5 = PAIR_CAR( e3469 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ); goto L6557; L6556: X4 = FALSEVALUE; L6557: if ( FALSE( X4 ) ) goto L6560; X2 = scrt1_caddr( e3469 ); goto L6561; L6560: X2 = X4; L6561: if ( NEQ( TSCPTAG( e3469 ), PAIRTAG ) ) goto L6562; X5 = PAIR_CAR( e3469 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2083 ) ) ); goto L6563; L6562: X4 = FALSEVALUE; L6563: if ( FALSE( X4 ) ) goto L6566; if ( EQ( TSCPTAG( e3469 ), PAIRTAG ) ) goto L6569; scrt1__24__cdr_2derror( e3469 ); L6569: X5 = PAIR_CDR( e3469 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6572; scrt1__24__car_2derror( X5 ); L6572: X3 = PAIR_CAR( X5 ); goto L6567; L6566: X3 = X4; L6567: X6 = sc_cons( e3469, EMPTYLIST ); X5 = sc_cons( c3476, X6 ); X4 = X5; transform_transform_2dstack_v = sc_cons( X4, transform_transform_2dstack_v ); if ( NEQ( TSCPTAG( e3469 ), PAIRTAG ) ) goto L6576; X4 = PAIR_CAR( e3469 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2083 ) ) ) goto L6578; X4 = BOOLEAN( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ); if ( FALSE( X4 ) ) goto L6590; X5 = plist_get( X3, c3503 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c3504 ) ) ) goto L6590; transform_log_2dbefore( e3469 ); if ( FALSE( plist_get( X3, c3710 ) ) ) goto L6588; X5 = X2; goto L6589; L6588: X5 = X1; L6589: e3469 = transform_log_2dafter( X5 ); GOBACK( L6549 ); L6578: POPSTACKTRACE( e3469 ); L6576: POPSTACKTRACE( e3469 ); L6590: X5 = SYMBOL_VALUE( true_2dalpha_v ); X4 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( X5 ) ) ); if ( TRUE( X4 ) ) goto L6595; X5 = SYMBOL_VALUE( false_2dalpha_v ); if ( EQ( _S2CUINT( X3 ), _S2CUINT( X5 ) ) ) goto L6595; X5 = BOOLEAN( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ); if ( FALSE( X5 ) ) goto L6639; if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6602; X7 = PAIR_CAR( X2 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2083 ) ) ); goto L6603; L6602: X6 = FALSEVALUE; L6603: if ( FALSE( X6 ) ) goto L6639; if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6611; X9 = PAIR_CAR( X2 ); X8 = BOOLEAN( EQ( _S2CUINT( X9 ), _S2CUINT( c2083 ) ) ); goto L6612; L6611: X8 = FALSEVALUE; L6612: if ( FALSE( X8 ) ) goto L6615; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6618; scrt1__24__cdr_2derror( X2 ); L6618: X9 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L6621; scrt1__24__car_2derror( X9 ); L6621: X7 = PAIR_CAR( X9 ); goto L6616; L6615: X7 = X8; L6616: if ( NEQ( _S2CUINT( X7 ), _S2CUINT( X3 ) ) ) goto L6639; transform_log_2dbefore( e3469 ); if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6624; X9 = PAIR_CAR( X2 ); X8 = BOOLEAN( EQ( _S2CUINT( X9 ), _S2CUINT( c2083 ) ) ); goto L6625; L6624: X8 = FALSEVALUE; L6625: if ( FALSE( X8 ) ) goto L6628; X7 = scrt1_caddr( X2 ); goto L6629; L6628: X7 = X8; L6629: X9 = PAIR_CDR( e3469 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L6633; scrt1__24__cdr_2derror( X9 ); L6633: X8 = PAIR_CDR( X9 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L6636; scdebug_error( c2125, c2126, CONS( X8, EMPTYLIST ) ); L6636: SETGEN( PAIR_CAR( X8 ), X7 ); e3469 = transform_log_2dafter( e3469 ); GOBACK( L6549 ); L6595: transform_log_2dbefore( e3469 ); X5 = SYMBOL_VALUE( true_2dalpha_v ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( X5 ) ) ) goto L6641; X4 = X2; goto L6642; L6641: X4 = X1; L6642: e3469 = transform_log_2dafter( X4 ); GOBACK( L6549 ); L6639: if ( NOT( AND( EQ( TSCPTAG( X3 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X3 ), SYMBOLTAG ) ) ) ) goto L6643; if ( NEQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L6645; X4 = PAIR_CAR( X1 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2083 ) ) ) goto L6647; X6 = PAIR_CAR( X1 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X5 ) ) goto L6654; X6 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6658; scrt1__24__car_2derror( X6 ); L6658: X4 = PAIR_CAR( X6 ); goto L6655; L6654: X4 = X5; L6655: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( X3 ) ) ) goto L6650; transform_log_2dbefore( e3469 ); X6 = PAIR_CAR( X1 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X5 ) ) goto L6663; X4 = scrt1_cadddr( X1 ); goto L6664; L6663: X4 = X5; L6664: X5 = scrt1_cdddr( e3469 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6667; scdebug_error( c2125, c2126, CONS( X5, EMPTYLIST ) ); L6667: SETGEN( PAIR_CAR( X5 ), X4 ); e3469 = transform_log_2dafter( e3469 ); GOBACK( L6549 ); L6650: POPSTACKTRACE( e3469 ); L6647: POPSTACKTRACE( e3469 ); L6645: POPSTACKTRACE( e3469 ); L6643: POPSTACKTRACE( e3469 ); } DEFTSCP( transform_log_2dbefore_v ); DEFCSTRING( t6669, "LOG-BEFORE" ); EXTERNTSCPP( scrt6_format, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt6_format_v ); TSCP transform_log_2dbefore( e3785 ) TSCP e3785; { TSCP X2, X1; PUSHSTACKTRACE( t6669 ); X1 = SYMBOL_VALUE( log_3f_v ); X1 = UNKNOWNCALL( X1, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( c3787, PROCEDURE_CLOSURE( X1 ) ) ) ) goto L6671; X2 = SYMBOL_VALUE( sc_2dicode_v ); X1 = SYMBOL_VALUE( pretty_2dprint_2d_24tree_v ); X1 = UNKNOWNCALL( X1, 2 ); VIA( PROCEDURE_CODE( X1 ) )( e3785, X2, PROCEDURE_CLOSURE( X1 ) ); X1 = SYMBOL_VALUE( sc_2dicode_v ); POPSTACKTRACE( scrt6_format( X1, CONS( c3791, EMPTYLIST ) ) ); L6671: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( transform_log_2dafter_v ); DEFCSTRING( t6674, "LOG-AFTER" ); TSCP transform_log_2dafter( e3793 ) TSCP e3793; { TSCP X2, X1; PUSHSTACKTRACE( t6674 ); X1 = SYMBOL_VALUE( log_3f_v ); X1 = UNKNOWNCALL( X1, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( c3787, PROCEDURE_CLOSURE( X1 ) ) ) ) goto L6676; X2 = SYMBOL_VALUE( sc_2dicode_v ); X1 = SYMBOL_VALUE( pretty_2dprint_2d_24tree_v ); X1 = UNKNOWNCALL( X1, 2 ); VIA( PROCEDURE_CODE( X1 ) )( e3793, X2, PROCEDURE_CLOSURE( X1 ) ); X1 = SYMBOL_VALUE( sc_2dicode_v ); scrt6_format( X1, CONS( c3795, EMPTYLIST ) ); L6676: POPSTACKTRACE( e3793 ); } DEFTSCP( transform_l_2dlambda_8f20e049_v ); DEFCSTRING( t6679, "TRANSFORM-CALL-LAMBDA" ); EXTERNTSCPP( transform_bda_2dbind_8a6984c8, XAL2( TSCP, TSCP ) ); EXTERNTSCP( transform_bda_2dbind_8a6984c8_v ); EXTERNTSCPP( plist_put, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( plist_put_v ); EXTERNTSCPP( transform_var_2duses_93ec09fc, XAL2( TSCP, TSCP ) ); EXTERNTSCP( transform_var_2duses_93ec09fc_v ); EXTERNTSCPP( transform_mbda_2dvar_cbbaf994, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( transform_mbda_2dvar_cbbaf994_v ); EXTERNTSCPP( transform_to_2dvalue_e947c03, XAL3( TSCP, TSCP, TSCP ) ); EXTERNTSCP( transform_to_2dvalue_e947c03_v ); EXTERNTSCPP( scrt1_length, XAL1( TSCP ) ); EXTERNTSCP( scrt1_length_v ); EXTERNTSCPP( scrt2__3d_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__3d_2dtwo_v ); TSCP transform_l_2dlambda_8f20e049( e3797 ) TSCP e3797; { TSCP X16, X15, X14, X13, X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6679 ); e3797 = CONS( e3797, EMPTYLIST ); X3 = PAIR_CAR( e3797 ); if ( NEQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L6682; X5 = PAIR_CAR( X3 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2051 ) ) ); goto L6683; L6682: X4 = FALSEVALUE; L6683: if ( FALSE( X4 ) ) goto L6686; X2 = scrt1_caddr( X3 ); goto L6687; L6686: X2 = X4; L6687: if ( NEQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6689; X4 = PAIR_CAR( X2 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2067 ) ) ); goto L6690; L6689: X3 = FALSEVALUE; L6690: if ( FALSE( X3 ) ) goto L6693; if ( EQ( TSCPTAG( X2 ), PAIRTAG ) ) goto L6696; scrt1__24__cdr_2derror( X2 ); L6696: X4 = PAIR_CDR( X2 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6699; scrt1__24__car_2derror( X4 ); L6699: X1 = PAIR_CAR( X4 ); goto L6694; L6693: X1 = X3; L6694: X3 = plist_get( X1, c3178 ); X5 = PAIR_CAR( e3797 ); if ( NEQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6703; X7 = PAIR_CAR( X5 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2051 ) ) ); goto L6704; L6703: X6 = FALSEVALUE; L6704: if ( FALSE( X6 ) ) goto L6707; X4 = scrt1_cdddr( X5 ); goto L6708; L6707: X4 = X6; L6708: X2 = transform_bda_2dbind_8a6984c8( X3, X4 ); X4 = X2; X5 = EMPTYLIST; X6 = EMPTYLIST; L6711: if ( NEQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L6712; X3 = X5; goto L6723; L6712: if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6715; scrt1__24__car_2derror( X4 ); L6715: X9 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L6719; scrt1__24__car_2derror( X9 ); L6719: X8 = PAIR_CAR( X9 ); X7 = sc_cons( X8, EMPTYLIST ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L6722; X8 = PAIR_CDR( X4 ); X6 = X7; X5 = X7; X4 = X8; GOBACK( L6711 ); L6722: X8 = PAIR_CDR( X4 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6727; scdebug_error( c2358, c2126, CONS( X6, EMPTYLIST ) ); L6727: X6 = SETGEN( PAIR_CDR( X6 ), X7 ); X4 = X8; GOBACK( L6711 ); L6723: X5 = X2; X6 = EMPTYLIST; X7 = EMPTYLIST; L6731: if ( NEQ( _S2CUINT( X5 ), _S2CUINT( EMPTYLIST ) ) ) goto L6732; X4 = X6; goto L6746; L6732: if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6735; scrt1__24__car_2derror( X5 ); L6735: X10 = PAIR_CAR( X5 ); if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L6739; scrt1__24__cdr_2derror( X10 ); L6739: X11 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L6742; scrt1__24__car_2derror( X11 ); L6742: X9 = PAIR_CAR( X11 ); X8 = sc_cons( X9, EMPTYLIST ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( EMPTYLIST ) ) ) goto L6745; X9 = PAIR_CDR( X5 ); X7 = X8; X6 = X8; X5 = X9; GOBACK( L6731 ); L6745: X9 = PAIR_CDR( X5 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6750; scdebug_error( c2358, c2126, CONS( X7, EMPTYLIST ) ); L6750: X7 = SETGEN( PAIR_CDR( X7 ), X8 ); X5 = X9; GOBACK( L6731 ); L6746: X4 = CONS( X4, EMPTYLIST ); X7 = PAIR_CAR( e3797 ); if ( NEQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L6754; X9 = PAIR_CAR( X7 ); X8 = BOOLEAN( EQ( _S2CUINT( X9 ), _S2CUINT( c2051 ) ) ); goto L6755; L6754: X8 = FALSEVALUE; L6755: if ( FALSE( X8 ) ) goto L6758; X6 = scrt1_caddr( X7 ); goto L6759; L6758: X6 = X8; L6759: if ( NEQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6761; X8 = PAIR_CAR( X6 ); X7 = BOOLEAN( EQ( _S2CUINT( X8 ), _S2CUINT( c2067 ) ) ); goto L6762; L6761: X7 = FALSEVALUE; L6762: if ( FALSE( X7 ) ) goto L6765; if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L6768; scrt1__24__cdr_2derror( X6 ); L6768: X8 = PAIR_CDR( X6 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L6771; scrt1__24__cdr_2derror( X8 ); L6771: X5 = PAIR_CDR( X8 ); goto L6766; L6765: X5 = X7; L6766: X5 = CONS( X5, EMPTYLIST ); X6 = FALSEVALUE; X6 = CONS( X6, EMPTYLIST ); X7 = EMPTYLIST; X7 = CONS( X7, EMPTYLIST ); X8 = EMPTYLIST; X8 = CONS( X8, EMPTYLIST ); X9 = EMPTYLIST; X9 = CONS( X9, EMPTYLIST ); X12 = sc_cons( PAIR_CAR( e3797 ), EMPTYLIST ); X11 = sc_cons( c3818, X12 ); X10 = X11; transform_transform_2dstack_v = sc_cons( X10, transform_transform_2dstack_v ); X10 = X2; L6780: if ( EQ( _S2CUINT( X10 ), _S2CUINT( EMPTYLIST ) ) ) goto L6781; if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L6785; scrt1__24__car_2derror( X10 ); L6785: X11 = PAIR_CAR( X10 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L6789; scrt1__24__car_2derror( X11 ); L6789: X12 = PAIR_CAR( X11 ); plist_put( X12, c3847, _TSCP( 0 ) ); plist_put( X12, c3851, _TSCP( 0 ) ); X10 = PAIR_CDR( X10 ); GOBACK( L6780 ); L6781: if ( FALSE( X3 ) ) goto L6798; X10 = PAIR_CAR( X5 ); X11 = X10; L6797: if ( EQ( _S2CUINT( X11 ), _S2CUINT( EMPTYLIST ) ) ) goto L6798; if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L6802; scrt1__24__car_2derror( X11 ); L6802: X12 = PAIR_CAR( X11 ); transform_var_2duses_93ec09fc( X3, X12 ); X11 = PAIR_CDR( X11 ); GOBACK( L6797 ); L6798: X10 = X3; L6806: if ( EQ( _S2CUINT( X10 ), _S2CUINT( EMPTYLIST ) ) ) goto L6807; if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L6811; scrt1__24__car_2derror( X10 ); L6811: X11 = PAIR_CAR( X10 ); X11 = CONS( X11, EMPTYLIST ); X13 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L6815; scrt1__24__car_2derror( X13 ); L6815: X12 = PAIR_CAR( X13 ); X12 = CONS( X12, EMPTYLIST ); X13 = transform_mbda_2dvar_cbbaf994( PAIR_CAR( X11 ), PAIR_CAR( X12 ), PAIR_CAR( X5 ) ); if ( NEQ( _S2CUINT( X13 ), _S2CUINT( c3910 ) ) ) goto L6819; X14 = X13; SETGEN( PAIR_CAR( X12 ), X14 ); goto L6826; L6819: if ( EQ( _S2CUINT( X13 ), _S2CUINT( c3917 ) ) ) goto L6826; if ( NEQ( _S2CUINT( X13 ), _S2CUINT( c2833 ) ) ) goto L6823; X14 = TRUEVALUE; SETGEN( PAIR_CAR( X6 ), X14 ); goto L6826; L6823: if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L6828; scrt1__24__car_2derror( X13 ); L6828: X14 = PAIR_CAR( X13 ); if ( NEQ( _S2CUINT( X14 ), _S2CUINT( c3929 ) ) ) goto L6825; X15 = PAIR_CDR( X13 ); if ( EQ( TSCPTAG( X15 ), PAIRTAG ) ) goto L6833; scrt1__24__car_2derror( X15 ); L6833: X14 = PAIR_CAR( X15 ); SETGEN( PAIR_CAR( X12 ), X14 ); X16 = PAIR_CDR( X13 ); if ( EQ( TSCPTAG( X16 ), PAIRTAG ) ) goto L6837; scrt1__24__cdr_2derror( X16 ); L6837: X15 = PAIR_CDR( X16 ); X14 = sc_cons( X15, PAIR_CAR( X9 ) ); SETGEN( PAIR_CAR( X9 ), X14 ); goto L6826; L6825: X14 = sc_cons( X13, PAIR_CAR( X9 ) ); SETGEN( PAIR_CAR( X9 ), X14 ); X14 = EMPTYLIST; SETGEN( PAIR_CAR( X11 ), X14 ); L6826: if ( FALSE( PAIR_CAR( X11 ) ) ) goto L6840; X14 = sc_cons( PAIR_CAR( X11 ), PAIR_CAR( X7 ) ); SETGEN( PAIR_CAR( X7 ), X14 ); X14 = sc_cons( PAIR_CAR( X12 ), PAIR_CAR( X8 ) ); SETGEN( PAIR_CAR( X8 ), X14 ); L6840: X15 = PAIR_CAR( X4 ); if ( EQ( TSCPTAG( X15 ), PAIRTAG ) ) goto L6844; scrt1__24__cdr_2derror( X15 ); L6844: X14 = PAIR_CDR( X15 ); SETGEN( PAIR_CAR( X4 ), X14 ); X10 = PAIR_CDR( X10 ); GOBACK( L6806 ); L6807: if ( FALSE( PAIR_CAR( X9 ) ) ) goto L6847; X10 = transform_to_2dvalue_e947c03( X1, PAIR_CAR( X5 ), PAIR_CAR( X9 ) ); SETGEN( PAIR_CAR( X5 ), X10 ); L6847: X10 = BOOLEAN( EQ( _S2CUINT( PAIR_CAR( X7 ) ), _S2CUINT( EMPTYLIST ) ) ); if ( FALSE( X10 ) ) goto L6863; X11 = scrt1_length( PAIR_CAR( X5 ) ); if ( BITAND( BITOR( _S2CINT( X11 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L6855; if ( EQ( _S2CUINT( X11 ), _S2CUINT( _TSCP( 4 ) ) ) ) goto L6859; goto L6863; L6855: if ( FALSE( scrt2__3d_2dtwo( X11, _TSCP( 4 ) ) ) ) goto L6863; L6859: X11 = SYMBOL_VALUE( log_3f_v ); X11 = UNKNOWNCALL( X11, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X11 ) )( c3787, PROCEDURE_CLOSURE( X11 ) ) ) ) goto L6866; X11 = SYMBOL_VALUE( sc_2dicode_v ); X12 = CONS( X1, EMPTYLIST ); scrt6_format( X11, CONS( c4005, X12 ) ); L6866: plist_put( X1, c4009, c4010 ); X12 = PAIR_CAR( X5 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L6869; scrt1__24__car_2derror( X12 ); L6869: X11 = PAIR_CAR( X12 ); SETGEN( PAIR_CAR( e3797 ), X11 ); goto L6864; L6863: plist_put( X1, c3178, PAIR_CAR( X7 ) ); X11 = PAIR_CAR( X8 ); X12 = PAIR_CAR( e3797 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L6874; scrt1__24__cdr_2derror( X12 ); L6874: X14 = PAIR_CDR( X12 ); if ( EQ( TSCPTAG( X14 ), PAIRTAG ) ) goto L6877; scrt1__24__cdr_2derror( X14 ); L6877: X13 = PAIR_CDR( X14 ); if ( EQ( TSCPTAG( X13 ), PAIRTAG ) ) goto L6880; scdebug_error( c2358, c2126, CONS( X13, EMPTYLIST ) ); L6880: SETGEN( PAIR_CDR( X13 ), X11 ); L6864: X10 = PAIR_CAR( X9 ); if ( TRUE( X10 ) ) goto L6886; if ( TRUE( PAIR_CAR( X6 ) ) ) goto L6886; POPSTACKTRACE( PAIR_CAR( e3797 ) ); L6886: POPSTACKTRACE( transform_transform( PAIR_CAR( e3797 ) ) ); } DEFTSCP( transform_bda_2dbind_8a6984c8_v ); DEFCSTRING( t6889, "TRANSFORM-LAMBDA-BIND" ); TSCP transform_bda_2dbind_8a6984c8( v4250, v4251 ) TSCP v4250, v4251; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6889 ); if ( EQ( _S2CUINT( v4250 ), _S2CUINT( EMPTYLIST ) ) ) goto L6891; if ( NEQ( TSCPTAG( v4250 ), PAIRTAG ) ) goto L6893; X3 = PAIR_CAR( v4250 ); if ( EQ( TSCPTAG( v4251 ), PAIRTAG ) ) goto L6897; scrt1__24__car_2derror( v4251 ); L6897: X5 = PAIR_CAR( v4251 ); X4 = sc_cons( X5, EMPTYLIST ); X2 = sc_cons( X3, X4 ); X1 = X2; X3 = PAIR_CDR( v4250 ); X4 = PAIR_CDR( v4251 ); X2 = transform_bda_2dbind_8a6984c8( X3, X4 ); POPSTACKTRACE( sc_cons( X1, X2 ) ); L6893: POPSTACKTRACE( FALSEVALUE ); L6891: POPSTACKTRACE( EMPTYLIST ); } DEFTSCP( transform_var_2duses_93ec09fc_v ); DEFCSTRING( t6902, "COUNT-LAMBDA-VAR-USES" ); EXTERNTSCPP( scrt1_memq, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_memq_v ); EXTERNTSCPP( scrt2__2b_2dtwo, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt2__2b_2dtwo_v ); TSCP transform_var_2duses_93ec09fc( v4278, e4279 ) TSCP v4278, e4279; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( t6902 ); L6903: if ( NOT( AND( EQ( TSCPTAG( e4279 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( e4279 ), SYMBOLTAG ) ) ) ) goto L6904; if ( FALSE( scrt1_memq( e4279, v4278 ) ) ) goto L6906; X3 = plist_get( e4279, c3847 ); if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X3 ) ), 3 ) ) goto L6909; X2 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X3 ) ) ); goto L6910; L6909: X2 = scrt2__2b_2dtwo( _TSCP( 4 ), X3 ); L6910: POPSTACKTRACE( plist_put( e4279, c3847, X2 ) ); L6906: POPSTACKTRACE( FALSEVALUE ); L6904: X2 = BOOLEAN( EQ( TSCPTAG( e4279 ), PAIRTAG ) ); if ( FALSE( X2 ) ) goto L6924; if ( EQ( TSCPTAG( e4279 ), PAIRTAG ) ) goto L6918; scrt1__24__car_2derror( e4279 ); L6918: X3 = PAIR_CAR( e4279 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2099 ) ) ) goto L6924; X4 = PAIR_CAR( e4279 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2099 ) ) ); if ( FALSE( X3 ) ) goto L6922; e4279 = scrt1_caddr( e4279 ); GOBACK( L6903 ); L6922: e4279 = X3; GOBACK( L6903 ); L6924: X2 = BOOLEAN( EQ( TSCPTAG( e4279 ), PAIRTAG ) ); if ( FALSE( X2 ) ) goto L6967; if ( EQ( TSCPTAG( e4279 ), PAIRTAG ) ) goto L6932; scrt1__24__car_2derror( e4279 ); L6932: X3 = PAIR_CAR( e4279 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2051 ) ) ) goto L6967; X4 = PAIR_CAR( e4279 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X3 ) ) goto L6936; X1 = scrt1_caddr( e4279 ); goto L6937; L6936: X1 = X3; L6937: X5 = PAIR_CAR( e4279 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X4 ) ) goto L6941; X3 = scrt1_cdddr( e4279 ); goto L6942; L6941: X3 = X4; L6942: X4 = X3; L6945: if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L6946; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L6950; scrt1__24__car_2derror( X4 ); L6950: X5 = PAIR_CAR( X4 ); transform_var_2duses_93ec09fc( v4278, X5 ); X4 = PAIR_CDR( X4 ); GOBACK( L6945 ); L6946: X3 = BOOLEAN( EQ( TSCPTAG( X1 ), PAIRTAG ) ); if ( FALSE( X3 ) ) goto L6966; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L6960; scrt1__24__car_2derror( X1 ); L6960: X4 = PAIR_CAR( X1 ); if ( NEQ( _S2CUINT( X4 ), _S2CUINT( c2067 ) ) ) goto L6966; X5 = PAIR_CAR( e4279 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X4 ) ) goto L6964; e4279 = scrt1_caddr( e4279 ); GOBACK( L6903 ); L6964: e4279 = X4; GOBACK( L6903 ); L6967: X2 = BOOLEAN( EQ( TSCPTAG( e4279 ), PAIRTAG ) ); if ( FALSE( X2 ) ) goto L6981; if ( EQ( TSCPTAG( e4279 ), PAIRTAG ) ) goto L6975; scrt1__24__car_2derror( e4279 ); L6975: X3 = PAIR_CAR( e4279 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2115 ) ) ) goto L6981; X4 = PAIR_CAR( e4279 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2115 ) ) ); if ( FALSE( X3 ) ) goto L6979; e4279 = scrt1_caddr( e4279 ); GOBACK( L6903 ); L6979: e4279 = X3; GOBACK( L6903 ); L6981: X2 = BOOLEAN( EQ( TSCPTAG( e4279 ), PAIRTAG ) ); if ( FALSE( X2 ) ) goto L7009; if ( EQ( TSCPTAG( e4279 ), PAIRTAG ) ) goto L6989; scrt1__24__car_2derror( e4279 ); L6989: X3 = PAIR_CAR( e4279 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2067 ) ) ) goto L7009; X5 = PAIR_CAR( e4279 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2067 ) ) ); if ( FALSE( X4 ) ) goto L6993; X5 = PAIR_CDR( e4279 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L6997; scrt1__24__cdr_2derror( X5 ); L6997: X3 = PAIR_CDR( X5 ); goto L6994; L6993: X3 = X4; L6994: X4 = X3; L7001: if ( EQ( _S2CUINT( X4 ), _S2CUINT( EMPTYLIST ) ) ) goto L7002; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L7006; scrt1__24__car_2derror( X4 ); L7006: X5 = PAIR_CAR( X4 ); transform_var_2duses_93ec09fc( v4278, X5 ); X4 = PAIR_CDR( X4 ); GOBACK( L7001 ); L7002: POPSTACKTRACE( FALSEVALUE ); L7009: if ( NEQ( TSCPTAG( e4279 ), PAIRTAG ) ) goto L7010; X2 = PAIR_CAR( e4279 ); if ( NEQ( _S2CUINT( X2 ), _S2CUINT( c2083 ) ) ) goto L7012; X4 = PAIR_CAR( e4279 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X3 ) ) goto L7018; X4 = PAIR_CDR( e4279 ); if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L7022; scrt1__24__car_2derror( X4 ); L7022: X2 = PAIR_CAR( X4 ); goto L7019; L7018: X2 = X3; L7019: transform_var_2duses_93ec09fc( v4278, X2 ); X4 = PAIR_CAR( e4279 ); X3 = BOOLEAN( EQ( _S2CUINT( X4 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X3 ) ) goto L7026; X2 = scrt1_caddr( e4279 ); goto L7027; L7026: X2 = X3; L7027: transform_var_2duses_93ec09fc( v4278, X2 ); X3 = PAIR_CAR( e4279 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2083 ) ) ); if ( FALSE( X2 ) ) goto L7030; e4279 = scrt1_cadddr( e4279 ); GOBACK( L6903 ); L7030: e4279 = X2; GOBACK( L6903 ); L7012: POPSTACKTRACE( FALSEVALUE ); L7010: POPSTACKTRACE( FALSEVALUE ); L6966: if ( FALSE( scrt1_memq( X1, v4278 ) ) ) goto L7032; X3 = plist_get( X1, c3851 ); if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X3 ) ), 3 ) ) goto L7035; X2 = _TSCP( IPLUS( _S2CINT( _TSCP( 4 ) ), _S2CINT( X3 ) ) ); goto L7036; L7035: X2 = scrt2__2b_2dtwo( _TSCP( 4 ), X3 ); L7036: POPSTACKTRACE( plist_put( X1, c3851, X2 ) ); L7032: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( transform_mbda_2dvar_cbbaf994_v ); DEFCSTRING( t7037, "TRANSFORM-LAMBDA-VAR" ); TSCP transform_m4661( v5319, s5320 ) TSCP v5319, s5320; { TSCP X5, X4, X3, X2, X1; PUSHSTACKTRACE( "MEMVARLIST [inside TRANSFORM-LAMBDA-VAR]" ); X1 = s5320; X2 = FALSEVALUE; L7041: if ( FALSE( X1 ) ) goto L7042; X3 = FALSEVALUE; goto L7043; L7042: X3 = TRUEVALUE; L7043: if ( TRUE( X3 ) ) goto L7048; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L7052; scrt1__24__car_2derror( X1 ); L7052: X4 = PAIR_CAR( X1 ); if ( NOT( AND( EQ( TSCPTAG( X4 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X4 ), SYMBOLTAG ) ) ) ) goto L7048; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L7055; scrt1__24__cdr_2derror( X1 ); L7055: X4 = PAIR_CDR( X1 ); if ( TRUE( X2 ) ) goto L7058; X5 = PAIR_CAR( X1 ); X2 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( v5319 ) ) ); L7058: X1 = X4; GOBACK( L7041 ); L7048: if ( FALSE( X2 ) ) goto L7060; POPSTACKTRACE( BOOLEAN( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) ); L7060: POPSTACKTRACE( X2 ); } EXTERNTSCPP( scrt2_zero_3f, XAL1( TSCP ) ); EXTERNTSCP( scrt2_zero_3f_v ); EXTERNTSCPP( transform_log_2dtransform, XAL1( TSCP ) ); EXTERNTSCP( transform_log_2dtransform_v ); TSCP transform_mbda_2dvar_cbbaf994( v4653, v4654, e4655 ) TSCP v4653, v4654, e4655; { TSCP X12, X11, X10, X9, X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t7037 ); if ( NEQ( TSCPTAG( v4654 ), PAIRTAG ) ) goto L7062; X6 = PAIR_CAR( v4654 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2067 ) ) ); goto L7063; L7062: X5 = FALSEVALUE; L7063: if ( FALSE( X5 ) ) goto L7066; if ( EQ( TSCPTAG( v4654 ), PAIRTAG ) ) goto L7069; scrt1__24__cdr_2derror( v4654 ); L7069: X6 = PAIR_CDR( v4654 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L7072; scrt1__24__cdr_2derror( X6 ); L7072: X4 = PAIR_CDR( X6 ); goto L7067; L7066: X4 = X5; L7067: if ( NEQ( TSCPTAG( v4654 ), PAIRTAG ) ) goto L7074; X6 = PAIR_CAR( v4654 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2067 ) ) ); goto L7075; L7074: X5 = FALSEVALUE; L7075: if ( FALSE( X5 ) ) goto L7078; if ( EQ( TSCPTAG( v4654 ), PAIRTAG ) ) goto L7081; scrt1__24__cdr_2derror( v4654 ); L7081: X6 = PAIR_CDR( v4654 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L7084; scrt1__24__car_2derror( X6 ); L7084: X1 = PAIR_CAR( X6 ); goto L7079; L7078: X1 = X5; L7079: X2 = plist_get( v4653, c3851 ); X3 = plist_get( v4653, c3847 ); if ( TRUE( plist_get( v4653, c4667 ) ) ) goto L7087; if ( TRUE( plist_get( v4653, c4671 ) ) ) goto L7089; if ( NEQ( TSCPTAG( v4654 ), PAIRTAG ) ) goto L7091; X6 = PAIR_CAR( v4654 ); X5 = BOOLEAN( EQ( _S2CUINT( X6 ), _S2CUINT( c2067 ) ) ); goto L7092; L7091: X5 = FALSEVALUE; L7092: if ( FALSE( X5 ) ) goto L7114; if ( BITAND( BITOR( _S2CINT( X2 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L7098; X6 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 4 ) ) ) ); goto L7099; L7098: X6 = scrt2__3d_2dtwo( X2, _TSCP( 4 ) ); L7099: if ( FALSE( X6 ) ) goto L7114; if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L7105; if ( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ) goto L7109; goto L7114; L7105: if ( TRUE( scrt2_zero_3f( X3 ) ) ) goto L7109; goto L7114; L7089: POPSTACKTRACE( c3917 ); L7087: POPSTACKTRACE( c3917 ); L7109: X5 = CONS( X1, EMPTYLIST ); X5 = CONS( c5249, X5 ); transform_log_2dtransform( CONS( v4653, X5 ) ); X6 = sc_cons( v4654, EMPTYLIST ); X5 = sc_cons( v4653, X6 ); POPSTACKTRACE( X5 ); L7114: if ( FALSE( X4 ) ) goto L7160; if ( NEQ( TSCPTAG( X3 ), FIXNUMTAG ) ) goto L7120; X5 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 0 ) ) ) ); goto L7121; L7120: X5 = scrt2_zero_3f( X3 ); L7121: if ( FALSE( X5 ) ) goto L7160; X7 = scrt1_length( X4 ); if ( BITAND( BITOR( _S2CINT( _TSCP( 4 ) ), _S2CINT( X7 ) ), 3 ) ) goto L7127; X6 = BOOLEAN( EQ( _S2CUINT( _TSCP( 4 ) ), _S2CUINT( X7 ) ) ); goto L7128; L7127: X6 = scrt2__3d_2dtwo( _TSCP( 4 ), X7 ); L7128: if ( FALSE( X6 ) ) goto L7160; if ( EQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L7137; scrt1__24__car_2derror( X4 ); L7137: X7 = PAIR_CAR( X4 ); if ( NOT( AND( EQ( TSCPTAG( X7 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( X7 ), SYMBOLTAG ) ) ) ) goto L7160; X8 = PAIR_CAR( X4 ); if ( FALSE( plist_get( X8, c4671 ) ) ) goto L7139; X7 = FALSEVALUE; goto L7140; L7139: X7 = TRUEVALUE; L7140: if ( FALSE( X7 ) ) goto L7160; X8 = plist_get( X1, c3178 ); if ( NEQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L7160; X8 = plist_get( X1, c4781 ); if ( NEQ( _S2CUINT( X8 ), _S2CUINT( EMPTYLIST ) ) ) goto L7160; X8 = CONS( PAIR_CAR( X4 ), EMPTYLIST ); X8 = CONS( c5228, X8 ); X9 = CONS( EMPTYLIST, EMPTYLIST ); X9 = CONS( v4653, X9 ); transform_log_2dtransform( CONS( scrt1_cons_2a( c2051, CONS( EMPTYLIST, X9 ) ), X8 ) ); X10 = CONS( EMPTYLIST, EMPTYLIST ); X10 = CONS( v4653, X10 ); X9 = scrt1_cons_2a( c2051, CONS( EMPTYLIST, X10 ) ); X11 = PAIR_CAR( X4 ); X10 = sc_cons( X11, EMPTYLIST ); X8 = sc_cons( X9, X10 ); POPSTACKTRACE( X8 ); L7160: X5 = BOOLEAN( AND( EQ( TSCPTAG( v4654 ), EXTENDEDTAG ), EQ( TSCP_EXTENDEDTAG( v4654 ), SYMBOLTAG ) ) ); if ( FALSE( X5 ) ) goto L7190; X6 = SYMBOL_VALUE( true_2dalpha_v ); if ( EQ( _S2CUINT( v4654 ), _S2CUINT( X6 ) ) ) goto L7168; X6 = SYMBOL_VALUE( false_2dalpha_v ); if ( EQ( _S2CUINT( v4654 ), _S2CUINT( X6 ) ) ) goto L7168; X6 = plist_get( v4654, c3503 ); if ( EQ( _S2CUINT( X6 ), _S2CUINT( c3504 ) ) ) goto L7168; X6 = plist_get( v4654, c3503 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( c4819 ) ) ) goto L7190; if ( FALSE( plist_get( v4654, c4671 ) ) ) goto L7180; X6 = FALSEVALUE; goto L7181; L7180: X6 = TRUEVALUE; L7181: if ( FALSE( X6 ) ) goto L7190; if ( TRUE( plist_get( v4654, c4667 ) ) ) goto L7190; L7168: X5 = CONS( v4654, EMPTYLIST ); X5 = CONS( c5228, X5 ); transform_log_2dtransform( CONS( v4653, X5 ) ); X6 = sc_cons( v4654, EMPTYLIST ); X5 = sc_cons( v4653, X6 ); POPSTACKTRACE( X5 ); L7190: if ( EQ( TSCPTAG( e4655 ), PAIRTAG ) ) goto L7194; scrt1__24__car_2derror( e4655 ); L7194: X6 = PAIR_CAR( e4655 ); if ( NEQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L7197; X7 = PAIR_CAR( X6 ); X5 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2083 ) ) ); goto L7198; L7197: X5 = FALSEVALUE; L7198: if ( FALSE( X5 ) ) goto L7259; if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L7204; X6 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 4 ) ) ) ); goto L7205; L7204: X6 = scrt2__3d_2dtwo( X3, _TSCP( 4 ) ); L7205: if ( FALSE( X6 ) ) goto L7259; if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L7210; X7 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ); goto L7211; L7210: X7 = scrt2_zero_3f( X2 ); L7211: if ( FALSE( X7 ) ) goto L7259; X9 = PAIR_CAR( e4655 ); if ( NEQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L7221; X11 = PAIR_CAR( X9 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2083 ) ) ); goto L7222; L7221: X10 = FALSEVALUE; L7222: if ( FALSE( X10 ) ) goto L7225; if ( EQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L7228; scrt1__24__cdr_2derror( X9 ); L7228: X11 = PAIR_CDR( X9 ); if ( EQ( TSCPTAG( X11 ), PAIRTAG ) ) goto L7231; scrt1__24__car_2derror( X11 ); L7231: X8 = PAIR_CAR( X11 ); goto L7226; L7225: X8 = X10; L7226: if ( EQ( _S2CUINT( X8 ), _S2CUINT( v4653 ) ) ) goto L7233; X10 = PAIR_CAR( e4655 ); if ( NEQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L7238; X12 = PAIR_CAR( X10 ); X11 = BOOLEAN( EQ( _S2CUINT( X12 ), _S2CUINT( c2083 ) ) ); goto L7239; L7238: X11 = FALSEVALUE; L7239: if ( FALSE( X11 ) ) goto L7242; if ( EQ( TSCPTAG( X10 ), PAIRTAG ) ) goto L7245; scrt1__24__cdr_2derror( X10 ); L7245: X12 = PAIR_CDR( X10 ); if ( EQ( TSCPTAG( X12 ), PAIRTAG ) ) goto L7248; scrt1__24__car_2derror( X12 ); L7248: X9 = PAIR_CAR( X12 ); goto L7243; L7242: X9 = X11; L7243: if ( NEQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L7251; X11 = PAIR_CAR( X9 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2051 ) ) ); goto L7252; L7251: X10 = FALSEVALUE; L7252: if ( FALSE( X10 ) ) goto L7255; X8 = scrt1_cdddr( X9 ); goto L7256; L7255: X8 = X10; L7256: if ( FALSE( transform_m4661( v4653, X8 ) ) ) goto L7259; L7233: X5 = CONS( v4654, EMPTYLIST ); X5 = CONS( c5228, X5 ); transform_log_2dtransform( CONS( v4653, X5 ) ); X6 = sc_cons( v4654, EMPTYLIST ); X5 = sc_cons( v4653, X6 ); POPSTACKTRACE( X5 ); L7259: X6 = PAIR_CAR( e4655 ); if ( NEQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L7264; X7 = PAIR_CAR( X6 ); X5 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2051 ) ) ); goto L7265; L7264: X5 = FALSEVALUE; L7265: if ( FALSE( X5 ) ) goto L7297; if ( BITAND( BITOR( _S2CINT( X3 ), _S2CINT( _TSCP( 4 ) ) ), 3 ) ) goto L7271; X6 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( _TSCP( 4 ) ) ) ); goto L7272; L7271: X6 = scrt2__3d_2dtwo( X3, _TSCP( 4 ) ); L7272: if ( FALSE( X6 ) ) goto L7297; if ( NEQ( TSCPTAG( X2 ), FIXNUMTAG ) ) goto L7277; X7 = BOOLEAN( EQ( _S2CUINT( X2 ), _S2CUINT( _TSCP( 0 ) ) ) ); goto L7278; L7277: X7 = scrt2_zero_3f( X2 ); L7278: if ( FALSE( X7 ) ) goto L7297; X9 = PAIR_CAR( e4655 ); if ( NEQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L7287; X11 = PAIR_CAR( X9 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2051 ) ) ); goto L7288; L7287: X10 = FALSEVALUE; L7288: if ( FALSE( X10 ) ) goto L7291; X8 = scrt1_cdddr( X9 ); goto L7292; L7291: X8 = X10; L7292: if ( FALSE( transform_m4661( v4653, X8 ) ) ) goto L7297; X8 = CONS( v4654, EMPTYLIST ); X8 = CONS( c5228, X8 ); transform_log_2dtransform( CONS( v4653, X8 ) ); X9 = sc_cons( v4654, EMPTYLIST ); X8 = sc_cons( v4653, X9 ); POPSTACKTRACE( X8 ); L7297: if ( NEQ( TSCPTAG( v4654 ), PAIRTAG ) ) goto L7298; X5 = PAIR_CAR( v4654 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2051 ) ) ) goto L7300; X7 = PAIR_CAR( v4654 ); X6 = BOOLEAN( EQ( _S2CUINT( X7 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X6 ) ) goto L7305; X5 = scrt1_caddr( v4654 ); goto L7306; L7305: X5 = X6; L7306: if ( NEQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L7308; X6 = PAIR_CAR( X5 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( c2882 ) ) ) goto L7310; if ( TRUE( plist_get( v4653, c2832 ) ) ) goto L7313; X11 = PAIR_CAR( v4654 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X10 ) ) goto L7319; X9 = scrt1_caddr( v4654 ); goto L7320; L7319: X9 = X10; L7320: if ( NEQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L7322; X11 = PAIR_CAR( X9 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2882 ) ) ); goto L7323; L7322: X10 = FALSEVALUE; L7323: if ( FALSE( X10 ) ) goto L7326; X8 = scrt1_cdddr( X9 ); goto L7327; L7326: X8 = X10; L7327: X7 = scrt1_last_2dpair( X8 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L7329; scrt1__24__car_2derror( X7 ); L7329: X6 = PAIR_CAR( X7 ); if ( NEQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L7315; X11 = PAIR_CAR( v4654 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X10 ) ) goto L7335; X9 = scrt1_caddr( v4654 ); goto L7336; L7335: X9 = X10; L7336: if ( NEQ( TSCPTAG( X9 ), PAIRTAG ) ) goto L7338; X11 = PAIR_CAR( X9 ); X10 = BOOLEAN( EQ( _S2CUINT( X11 ), _S2CUINT( c2882 ) ) ); goto L7339; L7338: X10 = FALSEVALUE; L7339: if ( FALSE( X10 ) ) goto L7342; X8 = scrt1_cdddr( X9 ); goto L7343; L7342: X8 = X10; L7343: X7 = scrt1_last_2dpair( X8 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L7346; scrt1__24__car_2derror( X7 ); L7346: X8 = PAIR_CAR( X7 ); if ( EQ( TSCPTAG( X8 ), PAIRTAG ) ) goto L7349; scrt1__24__car_2derror( X8 ); L7349: X6 = PAIR_CAR( X8 ); if ( NEQ( _S2CUINT( X6 ), _S2CUINT( c2833 ) ) ) goto L7331; plist_put( v4653, c2832, c2833 ); POPSTACKTRACE( c2833 ); L7331: POPSTACKTRACE( c3917 ); L7315: POPSTACKTRACE( c3917 ); L7313: POPSTACKTRACE( c3917 ); L7310: POPSTACKTRACE( c3917 ); L7308: POPSTACKTRACE( c3917 ); L7300: POPSTACKTRACE( c3917 ); L7298: POPSTACKTRACE( c3917 ); } DEFTSCP( transform_log_2dtransform_v ); DEFCSTRING( t7352, "LOG-TRANSFORM" ); EXTERNTSCPP( scrt6_newline, XAL1( TSCP ) ); EXTERNTSCP( scrt6_newline_v ); TSCP transform_log_2dtransform( e5361 ) TSCP e5361; { TSCP X3, X2, X1; PUSHSTACKTRACE( t7352 ); X1 = SYMBOL_VALUE( log_3f_v ); X1 = UNKNOWNCALL( X1, 1 ); if ( FALSE( VIA( PROCEDURE_CODE( X1 ) )( c3787, PROCEDURE_CLOSURE( X1 ) ) ) ) goto L7354; X1 = e5361; L7358: if ( EQ( _S2CUINT( X1 ), _S2CUINT( EMPTYLIST ) ) ) goto L7359; X2 = SYMBOL_VALUE( sc_2dicode_v ); if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L7363; scrt1__24__car_2derror( X1 ); L7363: X3 = CONS( PAIR_CAR( X1 ), EMPTYLIST ); scrt6_format( X2, CONS( c5386, X3 ) ); X1 = PAIR_CDR( X1 ); GOBACK( L7358 ); L7359: POPSTACKTRACE( scrt6_newline( CONS( SYMBOL_VALUE( sc_2dicode_v ), EMPTYLIST ) ) ); L7354: POPSTACKTRACE( FALSEVALUE ); } DEFTSCP( transform_to_2dvalue_e947c03_v ); DEFCSTRING( t7366, "TRANSFORM-VAR-TO-VALUE" ); EXTERNTSCPP( scrt1_assoc, XAL2( TSCP, TSCP ) ); EXTERNTSCP( scrt1_assoc_v ); TSCP transform_to_2dvalue_e947c03( l5388, e5389, s5390 ) TSCP l5388, e5389, s5390; { TSCP X8, X7, X6, X5, X4, X3, X2, X1; PUSHSTACKTRACE( t7366 ); L7367: l5388 = CONS( l5388, EMPTYLIST ); X1 = scrt1_assoc( e5389, s5390 ); if ( FALSE( X1 ) ) goto L7369; if ( EQ( TSCPTAG( X1 ), PAIRTAG ) ) goto L7372; scrt1__24__cdr_2derror( X1 ); L7372: X3 = PAIR_CDR( X1 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L7375; scrt1__24__car_2derror( X3 ); L7375: X2 = PAIR_CAR( X3 ); e5389 = X2; l5388 = PAIR_CAR( l5388 ); GOBACK( L7367 ); L7369: X2 = BOOLEAN( EQ( TSCPTAG( e5389 ), PAIRTAG ) ); if ( FALSE( X2 ) ) goto L7418; if ( EQ( TSCPTAG( e5389 ), PAIRTAG ) ) goto L7384; scrt1__24__car_2derror( e5389 ); L7384: X3 = PAIR_CAR( e5389 ); if ( NEQ( _S2CUINT( X3 ), _S2CUINT( c2051 ) ) ) goto L7418; X5 = PAIR_CAR( e5389 ); X4 = BOOLEAN( EQ( _S2CUINT( X5 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X4 ) ) goto L7388; X3 = scrt1_caddr( e5389 ); goto L7389; L7388: X3 = X4; L7389: X4 = transform_to_2dvalue_e947c03( PAIR_CAR( l5388 ), X3, s5390 ); X6 = PAIR_CDR( e5389 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L7394; scrt1__24__cdr_2derror( X6 ); L7394: X5 = PAIR_CDR( X6 ); if ( EQ( TSCPTAG( X5 ), PAIRTAG ) ) goto L7397; scdebug_error( c2125, c2126, CONS( X5, EMPTYLIST ) ); L7397: SETGEN( PAIR_CAR( X5 ), X4 ); X8 = PAIR_CAR( e5389 ); X7 = BOOLEAN( EQ( _S2CUINT( X8 ), _S2CUINT( c2051 ) ) ); if ( FALSE( X7 ) ) goto L7401; X6 = scrt1_cdddr( e5389 ); goto L7402; L7401: X6 = X7; L7402: X5 = transform_to_2dvalue_e947c03( PAIR_CAR( l5388 ), X6, s5390 ); X7 = PAIR_CDR( e5389 ); if ( EQ( TSCPTAG( X7 ), PAIRTAG ) ) goto L7406; scrt1__24__cdr_2derror( X7 ); L7406: X6 = PAIR_CDR( X7 ); if ( EQ( TSCPTAG( X6 ), PAIRTAG ) ) goto L7409; scdebug_error( c2358, c2126, CONS( X6, EMPTYLIST ) ); L7409: SETGEN( PAIR_CDR( X6 ), X5 ); if ( EQ( _S2CUINT( X3 ), _S2CUINT( X4 ) ) ) goto L7411; if ( NEQ( TSCPTAG( X4 ), PAIRTAG ) ) goto L7413; X5 = PAIR_CAR( X4 ); if ( NEQ( _S2CUINT( X5 ), _S2CUINT( c2067 ) ) ) goto L7415; POPSTACKTRACE( transform_l_2dlambda_8f20e049( e5389 ) ); L7415: POPSTACKTRACE( e5389 ); L7413: POPSTACKTRACE( e5389 ); L7411: POPSTACKTRACE( e5389 ); L7418: if ( NEQ( TSCPTAG( e5389 ), PAIRTAG ) ) goto L7419; X1 = PAIR_CAR( e5389 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2882 ) ) ) goto L7425; POPSTACKTRACE( e5389 ); L7419: POPSTACKTRACE( e5389 ); L7425: X1 = PAIR_CAR( e5389 ); if ( NEQ( _S2CUINT( X1 ), _S2CUINT( c2067 ) ) ) goto L7427; X3 = PAIR_CAR( e5389 ); X2 = BOOLEAN( EQ( _S2CUINT( X3 ), _S2CUINT( c2067 ) ) ); if ( FALSE( X2 ) ) goto L7432; X3 = PAIR_CDR( e5389 ); if ( EQ( TSCPTAG( X3 ), PAIRTAG ) ) goto L7436; scrt1__24__car_2derror( X3 ); L7436: X1 = PAIR_CAR( X3 ); goto L7433; L7432: X1 = X2; L7433: SETGEN( PAIR_CAR( l5388 ), X1 ); L7427: X2 = PAIR_CAR( e5389 ); X1 = transform_to_2dvalue_e947c03( PAIR_CAR( l5388 ), X2, s5390 ); SETGEN( PAIR_CAR( e5389 ), X1 ); X2 = PAIR_CDR( e5389 ); X1 = transform_to_2dvalue_e947c03( PAIR_CAR( l5388 ), X2, s5390 ); SETGEN( PAIR_CDR( e5389 ), X1 ); POPSTACKTRACE( e5389 ); } void scrt2__init(); void scrt6__init(); void plist__init(); void scdebug__init(); void scrt1__init(); static void init_modules( compiler_version ) char *compiler_version; { scrt2__init(); scrt6__init(); plist__init(); scdebug__init(); scrt1__init(); MAXDISPLAY( 0 ); } void transform__init() { static int init = 0; if (init) return; init = 1; INITHEAP( 0, 0, 0, 0 ); init_constants(); init_modules( "(transform SCHEME->C COMPILER 15mar93jfb)" ); sc_segv__handlers(); INITIALIZEVAR( t5993, ADR( transform_transform_2dstack_v ), EMPTYLIST ); INITIALIZEVAR( t5994, ADR( transform_transform_v ), MAKEPROCEDURE( 1, 0, transform_transform, EMPTYLIST ) ); INITIALIZEVAR( t5998, ADR( transform_transformx_v ), MAKEPROCEDURE( 1, 0, transform_transformx, EMPTYLIST ) ); INITIALIZEVAR( t6197, ADR( transform_transform_2dif1_v ), MAKEPROCEDURE( 1, 0, transform_transform_2dif1, EMPTYLIST ) ); INITIALIZEVAR( t6548, ADR( transform_transform_2dif2_v ), MAKEPROCEDURE( 1, 0, transform_transform_2dif2, EMPTYLIST ) ); INITIALIZEVAR( t6669, ADR( transform_log_2dbefore_v ), MAKEPROCEDURE( 1, 0, transform_log_2dbefore, EMPTYLIST ) ); INITIALIZEVAR( t6674, ADR( transform_log_2dafter_v ), MAKEPROCEDURE( 1, 0, transform_log_2dafter, EMPTYLIST ) ); INITIALIZEVAR( t6679, ADR( transform_l_2dlambda_8f20e049_v ), MAKEPROCEDURE( 1, 0, transform_l_2dlambda_8f20e049, EMPTYLIST ) ); INITIALIZEVAR( t6889, ADR( transform_bda_2dbind_8a6984c8_v ), MAKEPROCEDURE( 2, 0, transform_bda_2dbind_8a6984c8, EMPTYLIST ) ); INITIALIZEVAR( t6902, ADR( transform_var_2duses_93ec09fc_v ), MAKEPROCEDURE( 2, 0, transform_var_2duses_93ec09fc, EMPTYLIST ) ); INITIALIZEVAR( t7037, ADR( transform_mbda_2dvar_cbbaf994_v ), MAKEPROCEDURE( 3, 0, transform_mbda_2dvar_cbbaf994, EMPTYLIST ) ); INITIALIZEVAR( t7352, ADR( transform_log_2dtransform_v ), MAKEPROCEDURE( 0, 1, transform_log_2dtransform, EMPTYLIST ) ); INITIALIZEVAR( t7366, ADR( transform_to_2dvalue_e947c03_v ), MAKEPROCEDURE( 3, 0, transform_to_2dvalue_e947c03, EMPTYLIST ) ); return; } scheme2c-2012.10.14/scsc/transform.sc000066400000000000000000000361351203736146400171060ustar00rootroot00000000000000;;; Following the expansion of the program, program optimization via ;;; transformation is done by this module. Boolean expressions are "short- ;;; circuited, and some applications of lambda expressions are rearranged. For ;;; more information on these transformations, consult section 3.4 of "ORBIT: ;;; An Optimizing Compiler for Scheme", 1986 ACM Compiler Conference. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module transform) ;;; External and in-line declarations. (include "plist.sch") (include "expform.sch") (include "lambdaexp.sch") (include "miscexp.sch") ;;; Each form is transformed by calling the TRANSFORM function. The value ;;; returned is the new form. (define TRANSFORM-STACK '()) (define (TRANSFORM exp) (let ((was transform-stack)) (set! transform-stack (cons exp transform-stack)) (let ((result (transformx exp))) (set! transform-stack was) result))) (define (TRANSFORMX exp) (cond (($call? exp) (set-$call-func! exp (transform ($call-func exp))) (set-$call-argl! exp (map transform ($call-argl exp))) (if ($lambda? ($call-func exp)) (transform-call-lambda exp) exp)) (($lambda? exp) (let ((old-current-lambda-id current-lambda-id)) (set! current-lambda-id ($lambda-id exp)) (set-$lambda-body! exp (map transform ($lambda-body exp))) (set! current-lambda-id old-current-lambda-id) exp)) (($if? exp) (or (transform-if1 exp) (begin (set-$if-test! exp (transform ($if-test exp))) (set-$if-true! exp (transform ($if-true exp))) (set-$if-false! exp (transform ($if-false exp))) (transform-if2 exp)))) (($define? exp) (set-$define-exp! exp (transform ($define-exp exp))) exp) (($set? exp) (set-$set-exp! exp (transform ($set-exp exp))) exp) (else exp))) ;;; When a $IF is detected, the following function checks for possible ;;; transformations on the whole expression. If they can be made, then the ;;; resulting expression will be transformed and then returned. If no such ;;; transformations can be done, then #F will be returned. (define (TRANSFORM-IF1 exp) (let ((test ($if-test exp)) (ift ($if-true exp)) (iff ($if-false exp))) (set! transform-stack (cons (list 'if1 exp) transform-stack)) ;;; *** (cond ((and ($call? test) ($lambda? ($call-func test))) ; (if (let ((...))...a) b c) => (let ((...))...(if a b c)) (log-before exp) (let ((last (last-pair ($lambda-body ($call-func test))))) (set-car! last `($if ,(car last) ,ift ,iff)) (transform (log-after test)))) ((and ($if? test) (eq? ($if-true test) true-alpha) (eq? ($if-false test) false-alpha)) ; (if (if a #t #f) b c) => (if a b c) (log-before exp) (set-$if-test! exp ($if-test test)) (transform (log-after exp))) ((and ($if? test) (eq? ($if-true test) false-alpha) (eq? ($if-false test) true-alpha)) ; (if (if a #f #t) b c) => (if a c b) (log-before exp) (set-$if-test! exp ($if-test test)) (set-$if-true! exp iff) (set-$if-false! exp ift) (transform (log-after exp))) (($if? test) ; (if (if a b c) d e) => (if a (if b d e) (if c d e)) ; => ((lambda (x y) (if a ; (if b (x) (y)) ; (if c (x) (y)))) ; (lambda () d) (lambda () e)) (log-before exp) (let* ((lxy (lambda-exp '(lambda (x y)) '())) (lxyid ($lambda-id lxy)) (x (car (lambda-reqvars lxyid))) (y (cadr (lambda-reqvars lxyid))) (ld (lambda-exp '(lambda ()) '())) (le (lambda-exp '(lambda ()) '()))) (set-$lambda-body! ld (list ift)) (set-$lambda-body! le (list iff)) (set-$lambda-body! lxy `(($if ,($if-test test) ($if ,($if-true test) ($call () ,x) ($call () ,y)) ($if ,($if-false test) ($call () ,x) ($call () ,y))))) (name-a-lambda x ld) (name-a-lambda y le) (transform (log-after `($call () ,lxy ,ld ,le))))) ((and (symbol? test) (eq? (id-type test) 'boolean) (eq? ift test)) ; (if a a b) => (if a #t y) when a is a boolean result (log-before exp) (set-$if-true! exp true-alpha) (transform (log-after exp))) ((and (symbol? test) (eq? (id-type test) 'boolean) (eq? iff test)) ; (if a b a) => (if a b #f) when a is a boolean result (log-before exp) (set-$if-false! exp false-alpha) (transform (log-after exp))) ((and (eq? ($lap-type ($call-func test)) 'boolean) (or (and (eq? ift true-alpha) (eq? iff false-alpha)) (and (eq? ift false-alpha) (eq? iff true-alpha)))) ; (if (lap-boolean) #t #f) => (lap-boolean) ; (if (lap-boolean) #f #t) => (not (lap-boolean)) (log-before exp) (if (eq? iff true-alpha) (let ((lap ($call-func test))) (set-$lap-body! lap `((boolean (not ,(cadar ($lap-body lap)))))))) (transform (log-after test))) (else #f)))) ;;; Simplifications on a transformed if form are done by the following ;;; function. The result will be the final transformed expression. (define (TRANSFORM-IF2 exp) (let ((test ($if-test exp)) (ift ($if-true exp)) (iff ($if-false exp))) (set! transform-stack (cons (list 'if2 exp) transform-stack)) ;;; *** (cond ((not ($if? exp)) exp) ((and (symbol? test) (eq? (id-use test) 'constant)) ; test is a constant, so evaluate at compile time. (log-before exp) (transform-if2 (log-after (if (id-value test) ift iff)))) ((or (eq? test true-alpha) (eq? test false-alpha)) ; test is "#t" or "#f" whose values are known. (log-before exp) (transform-if2 (log-after (if (eq? test true-alpha) ift iff)))) ((and (symbol? test) ($if? ift) (eq? ($if-test ift) test)) ; (if a (if a b c) d) => (if a b d) (log-before exp) (set-$if-true! exp ($if-true ift)) (transform-if2 (log-after exp))) ((and (symbol? test) ($if? iff) (eq? ($if-test iff) test)) ; (if a b (if a c d)) => (if a b d) (log-before exp) (set-$if-false! exp ($if-false iff)) (transform-if2 (log-after exp))) (else exp)))) ;;; When a transformation is going to be made, the following routine is called ;;; to log the result. (define (LOG-BEFORE exp) (if (log? 'transform) (begin (pretty-print-$tree exp sc-icode) (format sc-icode " => ~%")))) ;;; Once a transformation has been made, the result is logged by the following ;;; function. (define (LOG-AFTER exp) (if (log? 'transform) (begin (pretty-print-$tree exp sc-icode) (format sc-icode "~%~%"))) exp) ;;; When a LAMBDA expression is apply'ed, some of the lambda bindings may be ;;; eliminated by using the value being bound instead. (define (TRANSFORM-CALL-LAMBDA exp) (let* ((lid ($lambda-id ($call-func exp))) (alist (transform-lambda-bind (lambda-reqvars lid) ($call-argl exp))) (vars (map (lambda (var-value) (car var-value)) alist)) (values (map (lambda (var-value) (cadr var-value)) alist)) (body ($lambda-body ($call-func exp))) (redo #f) (newvars '()) (newargl '()) (sublis '())) (set! transform-stack (cons (list 'tcl exp) transform-stack)) ;;; *** (for-each (lambda (var-val) (let ((id (car var-val))) (set-id-refs! id 0) (set-id-calls! id 0))) alist) (if vars (for-each (lambda (exp) (count-lambda-var-uses vars exp)) body)) (for-each (lambda (var) (let* ((value (car values)) (old-new (transform-lambda-var var value body))) (cond ((eq? old-new 'no-value) (set! value old-new)) ((eq? old-new 'no-change)) ((eq? old-new 'boolean) (set! redo #t)) ((eq? (car old-new) 'both) (set! value (cadr old-new)) (set! sublis (cons (cddr old-new) sublis))) (else (set! sublis (cons old-new sublis)) (set! var '()))) (if var (begin (set! newvars (cons var newvars)) (set! newargl (cons value newargl)))) (set! values (cdr values)))) vars) (if sublis (set! body (transform-var-to-value lid body sublis))) (cond ((and (null? newvars) (= (length body) 1)) (if (log? 'transform) (format sc-icode "Lambda ~A collapsed~%" lid)) (set-lambda-generate! lid 'inline) (set! exp (car body))) (else (set-lambda-reqvars! lid newvars) (set-$call-argl! exp newargl) exp)) (if (or sublis redo) (transform exp) exp))) ;;; Build an a-list of the lambda variables and their initial bindings. (define (TRANSFORM-LAMBDA-BIND vars values) (cond ((null? vars) '()) ((pair? vars) (cons (list (car vars) (car values)) (transform-lambda-bind (cdr vars) (cdr values)))))) ;;; Count the variable uses for a list of variables in an expression. The ;;; counts maintained are ID-REFS and ID-CALLS. (define (COUNT-LAMBDA-VAR-USES vars exp) (cond ((symbol? exp) (if (memq exp vars) (set-id-refs! exp (+ 1 (id-refs exp))))) (($define? exp) (count-lambda-var-uses vars ($define-exp exp))) (($call? exp) (let ((func ($call-func exp))) (for-each (lambda (a) (count-lambda-var-uses vars a)) ($call-argl exp)) (cond (($lambda? func) (count-lambda-var-uses vars ($call-func exp))) ((memq func vars) (set-id-calls! func (+ 1 (id-calls func))))))) (($set? exp) (count-lambda-var-uses vars ($set-exp exp))) (($lambda? exp) (for-each (lambda (e) (count-lambda-var-uses vars e)) ($lambda-body exp))) (($if? exp) (count-lambda-var-uses vars ($if-test exp)) (count-lambda-var-uses vars ($if-true exp)) (count-lambda-var-uses vars ($if-false exp))))) ;;; Once the usage counts have been obtained, the following function is called ;;; to decide whether substitution is in order. If so, then it will return ;;; either "no-value" which indicates that the value is not needed, or a list ;;; of old and new values to be substitued for in the expression, or ;;; "no-change" indicating that nothing is to be changed. (define (TRANSFORM-LAMBDA-VAR var value exp) (let ((refs (id-refs var)) (calls (id-calls var)) (id ($lambda-id value)) (body ($lambda-body value)) (memvarlist (lambda (var symbols) (do ((symbols symbols (cdr symbols)) (found #f (or found (eq? (car symbols) var)))) ((or (not symbols) (not (symbol? (car symbols)))) (and found (null? symbols))))))) (cond ((or (id-set! var) (id-display var)) ; If the lambda var is set or heap allocated, then it is best ; left alone. 'no-change) ((and ($lambda? value) (= calls 1) (zero? refs)) ; A lambda expression which is called once should be moved to ; the point of call. (log-transform var " replaced by lambda " id) (list var value)) ((and body (zero? refs) (= 1 (length body)) (symbol? (car body)) (not (id-display (car body))) (null? (lambda-reqvars id)) (null? (lambda-optvars id))) ; A function with no arguments which returns the value of a ; symbol which is not heap allocated can have all calls to it ; replaced with the actual symbol. (log-transform `($call () ,var) " replaced by " (car body)) (list `($call () ,var) (car body))) ((and (symbol? value) (or (eq? value true-alpha) (eq? value false-alpha) (eq? (id-use value) 'constant) (and (eq? (id-use value) 'lexical) (not (id-display value)) (not (id-set! value))))) ; A constant or a lexical variable which is not set and not ; closed may be substituted for. (log-transform var " replaced by " value) (list var value)) ((and ($if? (car exp)) (= refs 1) (zero? calls) (or (eq? ($if-test (car exp)) var) (memvarlist var ($call-argl ($if-test (car exp)))))) ; An expression which is then used as the test in an initial IF ; can be substituted for. The test is either the variable, or ; a variable to a function which is the test which only has ; variables as arguments. (log-transform var " replaced by " value) (list var value)) ((and ($call? (car exp)) (= refs 1) (zero? calls) (memvarlist var ($call-argl (car exp)))) ; An expression which is used once as an argument to an inital ; function may be substituted for if the arguments to the ; function are all symbols. (log-transform var " replaced by " value) (list var value)) ((and ($call? value) ($lap? ($call-func value)) (not (id-type var)) (pair? (car (last-pair ($lap-body ($call-func value))))) (eq? (caar (last-pair ($lap-body ($call-func value)))) 'boolean)) ; A variable which is bound to a logical boolean can have ; it's type noted. (set-id-type! var 'boolean) 'boolean) (else 'no-change)))) ;;; Transformations done when lambda expressions are apply'ed are logged by the ;;; following function. (define (LOG-TRANSFORM . exp) (if (log? 'transform) (begin (for-each (lambda (e) (format sc-icode "~A" e)) exp) (newline sc-icode)))) ;;; Once the transformations have been figured out, the actual substitutions ;;; can be made. Note the one special case where a lambda expression replaces ;;; its variable in a call. This will require that TRANSFORM-CALL-LAMBDA be ;;; recursively invoked as more transformations may be possible. (define (TRANSFORM-VAR-TO-VALUE lid exp sublis) (let ((old-new (assoc exp sublis))) (cond (old-new (transform-var-to-value lid (cadr old-new) sublis)) (($call? exp) (let* ((old ($call-func exp)) (new (transform-var-to-value lid old sublis))) (set-$call-func! exp new) (set-$call-argl! exp (transform-var-to-value lid ($call-argl exp) sublis)) (if (or (eq? old new) (not ($lambda? new))) exp (transform-call-lambda exp)))) ((and (pair? exp) (not ($lap? exp))) (if ($lambda? exp) (set! lid ($lambda-id exp))) (set-car! exp (transform-var-to-value lid (car exp) sublis)) (set-cdr! exp (transform-var-to-value lid (cdr exp) sublis)) exp) (else exp)))) scheme2c-2012.10.14/test/000077500000000000000000000000001203736146400145605ustar00rootroot00000000000000scheme2c-2012.10.14/test/README000066400000000000000000000001111203736146400154310ustar00rootroot00000000000000This directory contains test files for the compiler and run-time system. scheme2c-2012.10.14/test/alltests.sc000066400000000000000000002650061203736146400167530ustar00rootroot00000000000000;;; Test driver. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test (main test) (with test01 test02 test03 test04 test05 test06 test07 test08 test09 test10 test11 test12 test13 test14 test15 test16 test17 test18 test19 test20 test21 test22 test23)) (define-external TEST-ERRORS testchk) (define (TEST) (set! test-errors 0) (format #t "***** Begin Scheme->C Tests *****~%") (format #t "test01:~%") (test01) (format #t "test02:~%") (test02) (format #t "test03:~%") (test03) (format #t "test04:~%") (test04) (format #t "test05:~%") (test05) (format #t "test06:~%") (test06) (format #t "test07:~%") (test07) (format #t "test08:~%") (test08) (format #t "test09:~%") (test09) (format #t "test10:~%") (test10) (format #t "test11:~%") (test11) (format #t "test12:~%") (test12) (format #t "test13:~%") (test13) (format #t "test14:~%") (test14) (format #t "test15:~%") (test15) (format #t "test16:~%") (test16) (format #t "test17:~%") (test17) (format #t "test18:~%") (test18) (format #t "test19:~%") (test19) (format #t "test20:~%") (test20) (format #t "test21:~%") (test21) (format #t "test22:~%") (test22) (format #t "test23:~%") (test23) (format #t "***** End Scheme->C Tests ~a Errors *****~%" test-errors)) (define (LOAD-TESTS) (load "testchk.sc") (load "test01.sc") (load "test02.sc") (load "test03.sc") (load "test04.sc") (load "test05.sc") (load "test06.sc") (load "test07.sc") (load "test08.sc") (load "test09.sc") (load "test10.sc") (load "test11.sc") (load "test12.sc") (load "test13.sc") (load "test14.sc") (load "test15.sc") (load "test16.sc") (load "test17.sc") (load "test18.sc") (load "test19.sc") (load "test20.sc") (load "test21.sc") (load "test22.sc") (load "test23.sc") ) ;;; Test driver checking functions. (module testchk) (define TEST-ERRORS 0) (define *ACCURACY* 1.0e-7) (define (CHK test result expected) (unless (or (equal? result expected) (and (%record? result) (%record expected) (equal? (%record->list result) (%record->list expected))) (and (number? expected) (number? result) (inexact? expected) (<= (abs (- expected result)) (* (abs expected) *accuracy*)))) (format stdout-port " Test ~a failed~%" test) (format stdout-port " expected = ~s~%" expected) (format stdout-port " result = ~s~%" result) (set! test-errors (+ test-errors 1)))) (define (CHKQ test result expected) (unless (eq? result expected) (format stdout-port " Test ~a failed~%" test) (format stdout-port " expected = ~s~%" expected) (format stdout-port " result = ~s~%" result) (set! test-errors (+ test-errors 1)))) ;;; ;;; Test functions for basic Scheme functions. ;;; (module test01) (define-external (chk testnum result expected) testchk) (define (test01) ;;; 6.1 Booleans (chk 01 (boolean? '()) #f) (chk 02 (boolean? '#()) #f) (chk 03 (boolean? '(1 2)) #f) (chk 04 (boolean? '#(1 2)) #f) (chk 05 (boolean? 'x) #f) (chk 06 (boolean? "x") #f) (chk 07 (boolean? '#\a) #f) (chk 08 (boolean? (lambda (x) x)) #f) (chk 09 (boolean? #f) #t) (chk 10 (boolean? #t) #t) (chk 11 (boolean? -1) #f) (chk 12 (boolean? 0) #f) (chk 13 (boolean? 1) #f) (chk 14 (boolean? -1.5) #f) (chk 15 (boolean? 0.0) #f) (chk 16 (boolean? 1.5) #f) (chk 21 (not '()) #t) (chk 22 (not '#()) #f) (chk 23 (not '(1 2)) #f) (chk 24 (not '#(1 2)) #f) (chk 25 (not 'x) #f) (chk 26 (not "x") #f) (chk 27 (not '#\a) #f) (chk 28 (not (lambda (x) x)) #f) (chk 29 (not #f) #t) (chk 30 (not #t) #f) (chk 31 (not -1) #f) (chk 32 (not 0) #f) (chk 33 (not 1) #f) (chk 34 (not -1.5) #f) (chk 35 (not 0.0) #f) (chk 36 (not 1.5) #f)) ;;; ;;; Test functions for basic Scheme functions. ;;; (module test02) (define-external (chk testnum result expected) testchk) (define (test02) ;;; 6.2 Equivalence Predicates (let ((list4 (list 4 3 2 1)) (vector4 (vector 4 3 2 1))) (chk 41 (eqv? "" "") #t) (chk 42 (eqv? "" "") #t) (chk 43 (eqv? '() '()) #t) (chk 44 (eqv? '#() '#()) #t) (chk 45 (eqv? (car list4) (car list4)) #t) (chk 46 (eqv? list4 list4) #t) (chk 47 (eqv? vector4 vector4) #t) (chk 48 (eqv? 1 1) #t) (chk 49 (eqv? 1.5 1.5) #t) (chk 50 (eqv? 1.5 (+ 1.0 0.5)) #t) (chk 51 (eqv? list4 (list 4 3 2 1)) #f) (chk 52 (eqv? vector4 (vector 4 3 2 1)) #f) (chk 53 (eqv? 'x 'x) #t) (chk 61 (eq? "" "") #t) (chk 62 (eq? "" "") #t) (chk 63 (eq? '() '()) #t) (chk 64 (eq? '#() '#()) #t) (chk 65 (eq? (car list4) (car list4)) #t) (chk 66 (eq? list4 list4) #t) (chk 67 (eq? vector4 vector4) #t) (chk 68 (eq? 1 1) #t) (chk 69 (eq? 1.5 (+ 1.0 0.5)) #f) (chk 70 (eq? list4 (list 4 3 2 1)) #f) (chk 71 (eq? vector4 (vector 4 3 2 1)) #f) (chk 72 (eq? 'x 'x) #t) (chk 81 (equal? "" "") #t) (chk 82 (equal? "" "") #t) (chk 83 (equal? '() '()) #t) (chk 84 (equal? '#() '#()) #t) (chk 85 (equal? (car list4) (car list4)) #t) (chk 86 (equal? list4 list4) #t) (chk 87 (equal? vector4 vector4) #t) (chk 88 (equal? 1 1) #t) (chk 89 (equal? 1.5 1.5) #t) (chk 90 (equal? 1.5 (+ 1.0 0.5)) #t) (chk 91 (equal? list4 (list 4 3 2 1)) #t) (chk 92 (equal? vector4 (vector 4 3 2 1)) #t) (chk 93 (equal? 'x 'x) #t) (chk 93 (equal? (list (list 1 2) (list 3 4)) '((1 2) (3 4))) #t) (chk 94 (equal? (list (list 1 1) (list 3 4)) '((1 2) (3 4))) #f))) ;;; ;;; Test functions for basic Scheme functions. ;;; (module test03) (define-external (chk testnum result expected) testchk) (define (test03) ;;; 6.3 Pairs and Lists (chk 101 (pair? '()) #f) (chk 102 (pair? '#()) #f) (chk 103 (pair? '(1 2)) #t) (chk 104 (pair? '#(1 2)) #f) (chk 105 (pair? 'x) #f) (chk 106 (pair? "x") #f) (chk 107 (pair? '#\a) #f) (chk 108 (pair? (lambda (x) x)) #f) (chk 109 (pair? #f) #f) (chk 110 (pair? #t) #f) (chk 111 (pair? -1) #f) (chk 112 (pair? 0) #f) (chk 113 (pair? 1) #f) (chk 114 (pair? -1.5) #f) (chk 115 (pair? 0.0) #f) (chk 116 (pair? 1.5) #f) (chk 121 (null? '()) #t) (chk 122 (null? '#()) #f) (chk 123 (null? '(1 2)) #f) (chk 124 (null? '#(1 2)) #f) (chk 125 (null? 'x) #f) (chk 126 (null? "x") #f) (chk 127 (null? '#\a) #f) (chk 128 (null? (lambda (x) x)) #f) (chk 129 (null? #f) #f) (chk 130 (null? #t) #f) (chk 131 (null? -1) #f) (chk 132 (null? 0) #f) (chk 133 (null? 1) #f) (chk 134 (null? -1.5) #f) (chk 135 (null? 0.0) #f) (chk 136 (null? 1.5) #f) (chk 201 (list? '()) #t) (chk 202 (list? '#()) #f) (chk 203 (list? '(1 2)) #t) (chk 204 (list? '#(1 2)) #f) (chk 205 (list? 'x) #f) (chk 206 (list? "x") #f) (chk 207 (list? '#\a) #f) (chk 208 (list? (lambda (x) x)) #f) (chk 209 (list? #f) #f) (chk 210 (list? #t) #f) (chk 211 (list? -1) #f) (chk 212 (list? 0) #f) (chk 213 (list? 1) #f) (chk 214 (list? -1.5) #f) (chk 215 (list? 0.0) #f) (chk 216 (list? 1.5) #f) (chk 217 (list? '(a . b)) #f) (chk 218 (list? (let ((x (list 'a 'b 'c))) (set-cdr! x x) x)) #f) (chk 401 (list) '()) (chk 402 (list 1) '(1)) (chk 403 (list 1 2 3 4 5) '(1 2 3 4 5)) (chk 411 (cons* 1) 1) (chk 412 (cons* 1 2) '(1 . 2)) (chk 413 (cons* 1 2 3) '(1 2 . 3)) (chk 414 (cons* 1 2 3 4) '(1 2 3 . 4)) (chk 415 (cons* 1 2 3 4 '()) '(1 2 3 4)) (chk 421 (car (cons 'car 'cdr)) 'car) (chk 422 (cdr (cons 'car 'cdr)) 'cdr) (let ((cx (cons (cons 'caar 'cdar) (cons 'cadr 'cddr)))) (chk 431 (caar cx) 'caar) (chk 432 (cadr cx) 'cadr) (chk 433 (cdar cx) 'cdar) (chk 434 (cddr cx) 'cddr)) (let ((cx (cons (cons (cons 'caaar 'cdaar) (cons 'cadar 'cddar)) (cons (cons 'caadr 'cdadr) (cons 'caddr 'cdddr))))) (chk 441 (caaar cx) 'caaar) (chk 442 (caadr cx) 'caadr) (chk 443 (cadar cx) 'cadar) (chk 444 (caddr cx) 'caddr) (chk 445 (cdaar cx) 'cdaar) (chk 446 (cdadr cx) 'cdadr) (chk 447 (cddar cx) 'cddar) (chk 448 (cdddr cx) 'cdddr)) (let ((cx (cons (cons (cons (cons 'caaaar 'cdaaar) (cons 'cadaar 'cddaar)) (cons (cons 'caadar 'cdadar) (cons 'caddar 'cdddar))) (cons (cons (cons 'caaadr 'cdaadr) (cons 'cadadr 'cddadr)) (cons (cons 'caaddr 'cdaddr) (cons 'cadddr 'cddddr)))))) (chk 451 (caaaar cx) 'caaaar) (chk 452 (caaadr cx) 'caaadr) (chk 453 (caadar cx) 'caadar) (chk 454 (caaddr cx) 'caaddr) (chk 455 (cadaar cx) 'cadaar) (chk 456 (cadadr cx) 'cadadr) (chk 457 (caddar cx) 'caddar) (chk 458 (cadddr cx) 'cadddr) (chk 461 (cdaaar cx) 'cdaaar) (chk 462 (cdaadr cx) 'cdaadr) (chk 463 (cdadar cx) 'cdadar) (chk 464 (cdaddr cx) 'cdaddr) (chk 465 (cddaar cx) 'cddaar) (chk 466 (cddadr cx) 'cddadr) (chk 467 (cdddar cx) 'cdddar) (chk 468 (cddddr cx) 'cddddr)) (let ((cx (cons 'car 'cdr))) (chk 471 (set-car! cx 1) 1) (chk 472 cx '(1 . cdr)) (chk 473 (set-cdr! cx 2) 2) (chk 474 cx '(1 . 2))) (chk 481 (length '()) 0) (chk 482 (length '(1)) 1) (chk 483 (length '(1 2 3)) 3) (chk 491 (append '() '(1 2 3)) '(1 2 3)) (chk 492 (append '(1 2 3) '()) '(1 2 3)) (chk 493 (append '(1) '(2 3)) '(1 2 3)) (chk 494 (append '(1 2 3) '(4 5 6)) '(1 2 3 4 5 6)) (chk 495 (append) '()) (chk 496 (append '(1 2)) '(1 2)) (chk 497 (append '(1 2) '(3 4) '(5 6)) '(1 2 3 4 5 6)) (chk 498 (append '(1 2) '(3 4) '(5 6) '(7 8) '(9 10)) '(1 2 3 4 5 6 7 8 9 10)) (chk 501 (reverse '()) '()) (chk 502 (reverse '(1)) '(1)) (chk 503 (reverse '(1 2 3)) '(3 2 1)) (chk 511 (list-tail '(0 1 2 3) 0) '(0 1 2 3)) (chk 512 (list-tail '(0 1 2 3) 1) '(1 2 3)) (chk 513 (list-tail '(0 1 2 3) 2) '(2 3)) (chk 521 (list-ref '(0 1 2 3) 0) 0) (chk 522 (list-ref '(0 1 2 3) 1) 1) (chk 523 (list-ref '(0 1 2 3) 2) 2) (chk 531 (last-pair (cons 'a 'b)) '(a . b)) (chk 532 (last-pair '(0 1 2 3 4)) '(4)) (chk 541 (memq 0 '(0 1 2 3 4)) '(0 1 2 3 4)) (chk 542 (memq 3 '(0 1 2 3 4)) '(3 4)) (chk 543 (memq 5 '(0 1 2 3 4)) #f) (chk 551 (memv 0 '(0 1 2 3 4)) '(0 1 2 3 4)) (chk 552 (memv 3 '(0 1 2 3 4)) '(3 4)) (chk 553 (memv 5 '(0 1 2 3 4)) #f) (chk 561 (member 0 '(0 1 2 3 4)) '(0 1 2 3 4)) (chk 562 (member 3 '(0 1 2 3 4)) '(3 4)) (chk 563 (member 5 '(0 1 2 3 4)) #f) (chk 564 (member "zot" '('a 1 #f 'zot "zott" "zot" 'zot)) '("zot" 'zot)) (chk 571 (assq 0 '((0 zero) (1 one) (2 two))) '(0 zero)) (chk 572 (assq 2 '((0 zero) (1 one) (2 two))) '(2 two)) (chk 573 (assq 4 '((0 zero) (1 one) (2 two))) #f) (chk 581 (assv 0 '((0 zero) (1 one) (2 two))) '(0 zero)) (chk 582 (assv 2 '((0 zero) (1 one) (2 two))) '(2 two)) (chk 583 (assv 4 '((0 zero) (1 one) (2 two))) #f) (chk 591 (assoc 0 '((0 zero) (1 one) (2 two))) '(0 zero)) (chk 592 (assoc 2 '((0 zero) (1 one) (2 two))) '(2 two)) (chk 593 (assoc 4 '((0 zero) (1 one) (2 two))) #f) (chk 594 (assoc '(1 2) '((1 one) ((1 2) (one two)) (2 two))) '((1 2) (one two))) (chk 601 (remq 1 '()) '()) (chk 602 (remq 1 '(1 1 1 1 1 1)) '()) (chk 603 (remq 1 '(1 2 1 2 1 2)) '(2 2 2)) (chk 611 (remv 1 '()) '()) (chk 612 (remv 1 '(* 1 1 1 1 1 1)) '(*)) (chk 613 (remv 1 '(1 2 1 2 1 2)) '(2 2 2)) (chk 621 (remove '(1) '()) '()) (chk 622 (remove '(1) '((1) (1) (1) (1) (1) (1))) '()) (chk 623 (remove '(1) '((1) 2 (1) 2 (1) 2)) '(2 2 2)) (let ((cx (list '* 1 1 1 1 1 1)) (l2 (list 2 1 2 1 2 1 2))) (chk 631 (remq! 1 '()) '()) (chk 632 (remq! 1 cx) '(*)) (chk 633 cx '(*)) (chk 634 (remq! 1 l2) '(2 2 2 2)) (chk 635 l2 '(2 2 2 2))) (let ((l1 (list 1 1 1 1 1 1)) (l2 (list 2 1 2 1 2 1 2))) (chk 641 (remv! 1 '()) '()) (chk 642 (remv! 1 l1) '()) (chk 643 l1 '(1 1 1 1 1 1)) (chk 644 (remv! 1 l2) '(2 2 2 2)) (chk 645 l2 '(2 2 2 2))) (let ((l1 (list '(1) '(1) '(1) '(1) '(1) '(1))) (l2 (list 2 '(1) 2 '(1) 2 '(1) 2))) (chk 641 (remove! '(1) '()) '()) (chk 642 (remove! '(1) l1) '()) (chk 643 l1 '((1) (1) (1) (1) (1) (1))) (chk 644 (remove! '(1) l2) '(2 2 2 2)) (chk 645 l2 '(2 2 2 2)))) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test04) (define-external (chk testnum result expected) testchk) (define (test04) ;;; 6.4 Symbols (chk 2.001 (symbol? '()) #f) (chk 2.002 (symbol? '#()) #f) (chk 2.003 (symbol? '(1 2)) #f) (chk 2.004 (symbol? '#(1 2)) #f) (chk 2.005 (symbol? 'x) #t) (chk 2.006 (symbol? "x") #f) (chk 2.007 (symbol? '#\a) #f) (chk 2.008 (symbol? (lambda (x) x)) #f) (chk 2.009 (symbol? #f) #f) (chk 2.010 (symbol? #t) #f) (chk 2.011 (symbol? -1) #f) (chk 2.012 (symbol? 0) #f) (chk 2.013 (symbol? 1) #f) (chk 2.014 (symbol? -2.5) #f) (chk 2.015 (symbol? 0.0) #f) (chk 2.016 (symbol? 1.5) #f) (chk 2.021 (string->symbol "APPLE") 'apple) (chk 2.022(string->symbol "apple") '\a\p\p\l\e) (chk 2.023 (eq? (string->uninterned-symbol "APPLE") 'apple) #f) (chk 2.024 (symbol? (string->uninterned-symbol "APPLE")) #t) (chk 2.025 (uninterned-symbol? 'apple) #f) (chk 2.026 (uninterned-symbol? (string->uninterned-symbol "APPLE")) #t) (let* ((s (string #\A #\p #\p #\L #\E)) (s-sym (string->symbol s)) (s-usym (string->uninterned-symbol s))) (string-set! s 0 #\space) (chk 2.027 (symbol->string s-sym) "AppLE") (chk 2.028 (symbol->string s-usym) "AppLE")) (putprop 'x 1 #f) (chk 2.031 (getprop 'x 1) #f) (chk 2.032 (putprop 'x 1 -1) -1) (chk 2.033 (putprop 'x 2 -2) -2) (chk 2.034 (putprop 'x 3 -3) -3) (chk 2.035 (getprop 'x 1) -1) (chk 2.036 (getprop 'x 2) -2) (chk 2.037 (getprop 'x 3) -3) (chk 2.038 (putprop 'x 2 #f) #f) (chk 2.039 (getprop 'x 3) -3) (chk 2.040 (putprop 'x 3 #f) #f) (chk 2.040 (getprop 'x 3) #f) (chk 2.041 (getprop 'x 1) -1) (chk 2.042 (putprop 'x 1 1) 1) (chk 2.043 (getprop 'x 1) 1)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test05) (define-external (chk testnum result expected) testchk) (define (test05) ;;; 6.5 Numbers (chk 051 (number? '()) #f) (chk 052 (number? '#()) #f) (chk 053 (number? '(1 2)) #f) (chk 054 (number? '#(1 2)) #f) (chk 055 (number? 'x) #f) (chk 056 (number? "x") #f) (chk 057 (number? '#\a) #f) (chk 058 (number? (lambda (x) x)) #f) (chk 059 (number? #f) #f) (chk 060 (number? #t) #f) (chk 061 (number? -1) #t) (chk 062 (number? 0) #t) (chk 063 (number? 1) #t) (chk 064 (number? -5) #t) (chk 065 (number? 0.0) #t) (chk 066 (number? 1.5) #t) (chk 071 (complex? '()) #f) (chk 072 (complex? '#()) #f) (chk 073 (complex? '(1 2)) #f) (chk 074 (complex? '#(1 2)) #f) (chk 075 (complex? 'x) #f) (chk 076 (complex? "x") #f) (chk 077 (complex? '#\a) #f) (chk 078 (complex? (lambda (x) x)) #f) (chk 079 (complex? #f) #f) (chk 080 (complex? #t) #f) (chk 081 (complex? -1) #t) (chk 082 (complex? 0) #t) (chk 083 (complex? 1) #t) (chk 084 (complex? -2.5) #t) (chk 085 (complex? 0.0) #t) (chk 086 (complex? 1.5) #t) (chk 091 (real? '()) #f) (chk 092 (real? '#()) #f) (chk 093 (real? '(1 2)) #f) (chk 094 (real? '#(1 2)) #f) (chk 095 (real? 'x) #f) (chk 096 (real? "x") #f) (chk 097 (real? '#\a) #f) (chk 098 (real? (lambda (x) x)) #f) (chk 099 (real? #f) #f) (chk 100 (real? #t) #f) (chk 101 (real? -1) #t) (chk 102 (real? 0) #t) (chk 103 (real? 1) #t) (chk 104 (real? -2.5) #t) (chk 105 (real? 0.0) #t) (chk 106 (real? 1.5) #t) (chk 111 (rational? '()) #f) (chk 112 (rational? '#()) #f) (chk 113 (rational? '(1 2)) #f) (chk 114 (rational? '#(1 2)) #f) (chk 115 (rational? 'x) #f) (chk 116 (rational? "x") #f) (chk 117 (rational? '#\a) #f) (chk 118 (rational? (lambda (x) x)) #f) (chk 119 (rational? #f) #f) (chk 120 (rational? #t) #f) (chk 121 (rational? -1) #t) (chk 122 (rational? 0) #t) (chk 123 (rational? 1) #t) (chk 124 (rational? -2.5) #t) (chk 125 (rational? 0.0) #t) (chk 126 (rational? 1.5) #t) (chk 131 (integer? '()) #f) (chk 132 (integer? '#()) #f) (chk 133 (integer? '(1 2)) #f) (chk 134 (integer? '#(1 2)) #f) (chk 135 (integer? 'x) #f) (chk 136 (integer? "x") #f) (chk 137 (integer? '#\a) #f) (chk 138 (integer? (lambda (x) x)) #f) (chk 139 (integer? #f) #f) (chk 140 (integer? #t) #f) (chk 141 (integer? -1) #t) (chk 142 (integer? 0) #t) (chk 143 (integer? 1) #t) (chk 144 (integer? -2.5) #f) (chk 145 (integer? 0.0) #t) (chk 146 (integer? 1.5) #f) (chk 151 (zero? -1) #f) (chk 152 (zero? 0) #t) (chk 153 (zero? 1) #f) (chk 154 (zero? -2.5) #f) (chk 155 (zero? 0.0) #t) (chk 156 (zero? 1.5) #f) (chk 161 (positive? -1) #f) (chk 162 (positive? 0) #f) (chk 163 (positive? 1) #t) (chk 164 (positive? -2.5) #f) (chk 165 (positive? 0.0) #f) (chk 166 (positive? 1.5) #t) (chk 171 (negative? -1) #t) (chk 172 (negative? 0) #f) (chk 173 (negative? 1) #f) (chk 174 (negative? -2.5) #t) (chk 175 (negative? 0.0) #f) (chk 176 (negative? 1.5) #f)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test06) (define-external (chk testnum result expected) testchk) (define (test06) (chk 181 (odd? -1) #t) (chk 182 (odd? 0) #f) (chk 183 (odd? 1) #t) (chk 184 (odd? -2) #f) (chk 185 (odd? 2) #f) (chk 191 (even? -1) #f) (chk 192 (even? 0) #t) (chk 193 (even? 1) #f) (chk 194 (even? -2) #t) (chk 195 (even? 2) #t) (chk 201 (exact? -1) #t) (chk 202 (exact? 0) #t) (chk 203 (exact? 1) #t) (chk 204 (exact? -2.5) #f) (chk 205 (exact? 0.0) #f) (chk 206 (exact? 1.5) #f) (chk 211 (inexact? -1) #f) (chk 212 (inexact? 0) #f) (chk 213 (inexact? 1) #f) (chk 214 (inexact? -2.5) #t) (chk 215 (inexact? 0.0) #t) (chk 216 (inexact? 1.5) #t) (chk 220 (= 1 2) #F) (chk 221 (= 2 1) #F) (chk 222 (= 2 3) #F) (chk 223 (= 3 2) #F) (chk 224 (= -1 2) #F) (chk 225 (= -2 1) #F) (chk 226 (= -2 3) #F) (chk 227 (= -3 2) #F) (chk 228 (= 1 -2) #F) (chk 229 (= 2 -1) #F) (chk 230 (= 2 -3) #F) (chk 231 (= 3 -2) #F) (chk 232 (= -1 -2) #F) (chk 233 (= -2 -1) #F) (chk 234 (= -2 -3) #F) (chk 235 (= -3 -2) #F) (chk 236 (= 2 2) #T) (chk 237 (= -2 -2) #T) (chk 240 (< 1 2) #T) (chk 241 (< 2 1) #F) (chk 242 (< 2 3) #T) (chk 243 (< 3 2) #F) (chk 244 (< -1 2) #T) (chk 245 (< -2 1) #T) (chk 246 (< -2 3) #T) (chk 247 (< -3 2) #T) (chk 248 (< 1 -2) #F) (chk 249 (< 2 -1) #F) (chk 250 (< 2 -3) #F) (chk 251 (< 3 -2) #F) (chk 252 (< -1 -2) #F) (chk 253 (< -2 -1) #T) (chk 254 (< -2 -3) #F) (chk 255 (< -3 -2) #T) (chk 256 (< 2 2) #F) (chk 257 (< -2 -2) #F) (chk 260 (> 1 2) #F) (chk 261 (> 2 1) #T) (chk 262 (> 2 3) #F) (chk 263 (> 3 2) #T) (chk 264 (> -1 2) #F) (chk 265 (> -2 1) #F) (chk 266 (> -2 3) #F) (chk 267 (> -3 2) #F) (chk 268 (> 1 -2) #T) (chk 269 (> 2 -1) #T) (chk 270 (> 2 -3) #T) (chk 271 (> 3 -2) #T) (chk 272 (> -1 -2) #T) (chk 273 (> -2 -1) #F) (chk 274 (> -2 -3) #T) (chk 275 (> -3 -2) #F) (chk 276 (> 2 2) #F) (chk 277 (> -2 -2) #F) (chk 280 (<= 1 2) #T) (chk 281 (<= 2 1) #F) (chk 282 (<= 2 3) #T) (chk 283 (<= 3 2) #F) (chk 284 (<= -1 2) #T) (chk 285 (<= -2 1) #T) (chk 286 (<= -2 3) #T) (chk 287 (<= -3 2) #T) (chk 288 (<= 1 -2) #F) (chk 289 (<= 2 -1) #F) (chk 290 (<= 2 -3) #F) (chk 291 (<= 3 -2) #F) (chk 292 (<= -1 -2) #F) (chk 293 (<= -2 -1) #T) (chk 294 (<= -2 -3) #F) (chk 295 (<= -3 -2) #T) (chk 296 (<= 2 2) #T) (chk 297 (<= -2 -2) #T) (chk 300 (= 1 1 1 1) #T) (chk 301 (= 2 1 1 1) #F) (chk 302 (= 1 1 1 2) #F) (chk 310 (< 1 2 3 4) #T) (chk 311 (< 2 2 3 4) #F) (chk 312 (< 2 3 3 4) #F) (chk 313 (< 2 3 4 4) #F) (chk 320 (> 4 3 2 1) #T) (chk 321 (> 4 3 2 2) #F) (chk 322 (> 4 3 3 2) #F) (chk 323 (> 4 4 3 2) #F) (chk 330 (<= 1 2 3 4) #T) (chk 331 (<= 2 2 3 4) #T) (chk 332 (<= 2 3 3 4) #T) (chk 333 (<= 2 3 4 4) #T) (chk 334 (<= 1 2 3 3 2 1) #F) (chk 335 (<= 1 2 3 3 2) #F)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test07) (define-external (chk testnum result expected) testchk) (define (test07) (chk 300 (>= 1 2) #F) (chk 301 (>= 2 1) #T) (chk 302 (>= 2 3) #F) (chk 303 (>= 3 2) #T) (chk 304 (>= -1 2) #F) (chk 305 (>= -2 1) #F) (chk 306 (>= -2 3) #F) (chk 307 (>= -3 2) #F) (chk 308 (>= 1 -2) #T) (chk 309 (>= 2 -1) #T) (chk 310 (>= 2 -3) #T) (chk 311 (>= 3 -2) #T) (chk 312 (>= -1 -2) #T) (chk 313 (>= -2 -1) #F) (chk 314 (>= -2 -3) #T) (chk 315 (>= -3 -2) #F) (chk 316 (>= 2 2) #T) (chk 317 (>= -2 -2) #T) (chk 320 (max 1 2) 2) (chk 321 (max 2 1) 2) (chk 322 (max 2 3) 3) (chk 323 (max 3 2) 3) (chk 324 (max -1 2) 2) (chk 325 (max -2 1) 1) (chk 326 (max -2 3) 3) (chk 327 (max -3 2) 2) (chk 328 (max 1 -2) 1) (chk 329 (max 2 -1) 2) (chk 330 (max 2 -3) 2) (chk 331 (max 3 -2) 3) (chk 332 (max -1 -2) -1) (chk 333 (max -2 -1) -1) (chk 334 (max -2 -3) -2) (chk 335 (max -3 -2) -2) (chk 336 (max 2 2) 2) (chk 337 (max -2 -2) -2) (chk 340 (abs 1) 1) (chk 341 (abs 0) 0) (chk 342 (abs -1) 1) (chk 343 (abs -.5) .5) (chk 343 (abs 0.0) 0.0) (chk 344 (abs .5) .5) (chk 360 (min 1 2) 1) (chk 361 (min 2 1) 1) (chk 362 (min 2 3) 2) (chk 363 (min 3 2) 2) (chk 364 (min -1 2) -1) (chk 365 (min -2 1) -2) (chk 366 (min -2 3) -2) (chk 367 (min -3 2) -3) (chk 368 (min 1 -2) -2) (chk 369 (min 2 -1) -1) (chk 370 (min 2 -3) -3) (chk 371 (min 3 -2) -2) (chk 372 (min -1 -2) -2) (chk 373 (min -2 -1) -2) (chk 374 (min -2 -3) -3) (chk 375 (min -3 -2) -3) (chk 376 (min 2 2) 2) (chk 377 (min -2 -2) -2) (chk 380 (+ 1 2) 3) (chk 381 (+ 2 1) 3) (chk 382 (+ 2 3) 5) (chk 383 (+ 3 2) 5) (chk 384 (+ -1 2) 1) (chk 385 (+ -2 1) -1) (chk 386 (+ -2 3) 1) (chk 387 (+ -3 2) -1) (chk 388 (+ 1 -2) -1) (chk 389 (+ 2 -1) 1) (chk 390 (+ 2 -3) -1) (chk 391 (+ 3 -2) 1) (chk 392 (+ -1 -2) -3) (chk 393 (+ -2 -1) -3) (chk 394 (+ -2 -3) -5) (chk 395 (+ -3 -2) -5) (chk 396 (+ 2 2) 4) (chk 397 (+ -2 -2) -4) (chk 400 (* 1 2) 2) (chk 401 (* 2 1) 2) (chk 402 (* 2 3) 6) (chk 403 (* 3 2) 6) (chk 404 (* -1 2) -2) (chk 405 (* -2 1) -2) (chk 406 (* -2 3) -6) (chk 407 (* -3 2) -6) (chk 408 (* 1 -2) -2) (chk 409 (* 2 -1) -2) (chk 410 (* 2 -3) -6) (chk 411 (* 3 -2) -6) (chk 412 (* -1 -2) 2) (chk 413 (* -2 -1) 2) (chk 414 (* -2 -3) 6) (chk 415 (* -3 -2) 6) (chk 416 (* 2 2) 4) (chk 417 (* -2 -2) 4) (chk 420 (>= 4 3 2 1) #T) (chk 421 (>= 4 3 2 2) #T) (chk 422 (>= 4 3 3 2) #T) (chk 423 (>= 4 4 3 2) #T) (chk 424 (>= 1 2 3 3 2 1) #F) (chk 425 (>= 2 3 3 2 1) #F) (chk 430 (max 1) 1) (chk 431 (max 1 2 3) 3) (chk 432 (max 3 2 1) 3) (chk 433 (max 2 3 1) 3) (chk 434 (max 1 3 5 7 9 7 5 3 1) 9) (chk 440 (min 1) 1) (chk 441 (min 1 2 3) 1) (chk 442 (min 3 2 1) 1) (chk 443 (min 2 3 1) 1) (chk 444 (min 1 3 5 7 0 7 5 3 1) 0) (chk 450 (+) 0) (chk 451 (+ 1 2 3) 6) (chk 452 (+ 1 2 3 4 5 6) 21) (chk 460 (*) 1) (chk 461 (* 1 2 3) 6) (chk 462 (* 5 4 3 2) 120)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test08) (define-external (chk testnum result expected) testchk) (define (test08) (chk 420 (- 1 2) -1) (chk 421 (- 2 1) 1) (chk 422 (- 2 3) -1) (chk 423 (- 3 2) 1) (chk 424 (- -1 2) -3) (chk 425 (- -2 1) -3) (chk 426 (- -2 3) -5) (chk 427 (- -3 2) -5) (chk 428 (- 1 -2) 3) (chk 429 (- 2 -1) 3) (chk 430 (- 2 -3) 5) (chk 431 (- 3 -2) 5) (chk 432 (- -1 -2) 1) (chk 433 (- -2 -1) -1) (chk 434 (- -2 -3) 1) (chk 435 (- -3 -2) -1) (chk 436 (- 2 2) 0) (chk 437 (- -2 -2) 0) (chk 440 (/ 1 2) .5) (chk 441 (/ 2 1) 2) (chk 442 (/ 2 3) .6666666666666667) (chk 443 (/ 3 2) 1.5) (chk 444 (/ -1 2) -.5) (chk 445 (/ -2 1) -2) (chk 446 (/ -2 3) -.6666666666666667) (chk 447 (/ -3 2) -1.5) (chk 448 (/ 1 -2) -.5) (chk 449 (/ 2 -1) -2) (chk 450 (/ 2 -3) -.6666666666666667) (chk 451 (/ 3 -2) -1.5) (chk 452 (/ -1 -2) .5) (chk 453 (/ -2 -1) 2) (chk 454 (/ -2 -3) .6666666666666667) (chk 455 (/ -3 -2) 1.5) (chk 456 (/ 2 2) 1) (chk 457 (/ -2 -2) 1) (chk 460 (quotient 1 2) 0) (chk 461 (quotient 2 1) 2) (chk 462 (quotient 2 3) 0) (chk 463 (quotient 3 2) 1) (chk 464 (quotient -1 2) 0) (chk 465 (quotient -2 1) -2) (chk 466 (quotient -2 3) 0) (chk 467 (quotient -3 2) -1) (chk 468 (quotient 1 -2) 0) (chk 469 (quotient 2 -1) -2) (chk 470 (quotient 2 -3) 0) (chk 471 (quotient 3 -2) -1) (chk 472 (quotient -1 -2) 0) (chk 473 (quotient -2 -1) 2) (chk 474 (quotient -2 -3) 0) (chk 475 (quotient -3 -2) 1) (chk 476 (quotient 2 2) 1) (chk 477 (quotient -2 -2) 1) (chk 480 (remainder 1 2) 1) (chk 481 (remainder 2 1) 0) (chk 482 (remainder 2 3) 2) (chk 483 (remainder 3 2) 1) (chk 484 (remainder -1 2) -1) (chk 485 (remainder -2 1) 0) (chk 486 (remainder -2 3) -2) (chk 487 (remainder -3 2) -1) (chk 488 (remainder 1 -2) 1) (chk 489 (remainder 2 -1) 0) (chk 490 (remainder 2 -3) 2) (chk 491 (remainder 3 -2) 1) (chk 492 (remainder -1 -2) -1) (chk 493 (remainder -2 -1) 0) (chk 494 (remainder -2 -3) -2) (chk 495 (remainder -3 -2) -1) (chk 496 (remainder 2 2) 0) (chk 497 (remainder -2 -2) 0) (chk 500 (+ -2 -2) -4) (chk 501 (+ -2 -1.4) -3.4) (chk 502 (+ -2 2) 0) (chk 503 (+ -2 2.4) .4) (chk 504 (+ -1.4 -2) -3.4) (chk 505 (+ -1.4 -1.4) -2.8) (chk 506 (+ -1.4 2) .6) (chk 507 (+ -1.4 2.4) 1.) (chk 508 (+ 2 -2) 0) (chk 509 (+ 2 -1.4) .6) (chk 510 (+ 2 2) 4) (chk 511 (+ 2 2.4) 4.4) (chk 512 (+ 2.4 -2) .4) (chk 513 (+ 2.4 -1.4) 1.) (chk 514 (+ 2.4 2) 4.4) (chk 515 (+ 2.4 2.4) 4.8) (chk 520 (- -2 -2) 0) (chk 521 (- -2 -1.4) -.6) (chk 522 (- -2 2) -4) (chk 523 (- -2 2.4) -4.4) (chk 524 (- -1.4 -2) .6) (chk 525 (- -1.4 -1.4) 0.) (chk 526 (- -1.4 2) -3.4) (chk 527 (- -1.4 2.4) -3.8) (chk 528 (- 2 -2) 4) (chk 529 (- 2 -1.4) 3.4) (chk 530 (- 2 2) 0) (chk 531 (- 2 2.4) -.4) (chk 532 (- 2.4 -2) 4.4) (chk 533 (- 2.4 -1.4) 3.8) (chk 534 (- 2.4 2) .4) (chk 535 (- 2.4 2.4) 0.) (chk 540 (- 1) -1) (chk 541 (- 1.3) -1.3) (chk 542 (- 3 4 5) -6) (chk 543 (- 3 4 5 -6) 0) (chk 550 (/ 3) .3333333333) (chk 551 (/ 3 4 5) .15) (chk 552 (/ 3 4 5 10) .015) (chk 580 (modulo 1 2) 1) (chk 581 (modulo 2 1) 0) (chk 582 (modulo 2 3) 2) (chk 583 (modulo 3 2) 1) (chk 584 (modulo -1 2) 1) (chk 585 (modulo -2 1) 0) (chk 586 (modulo -2 3) 1) (chk 587 (modulo -3 2) 1) (chk 588 (modulo 1 -2) -1) (chk 589 (modulo 2 -1) 0) (chk 590 (modulo 2 -3) -1) (chk 591 (modulo 3 -2) -1) (chk 592 (modulo -1 -2) -1) (chk 593 (modulo -2 -1) 0) (chk 594 (modulo -2 -3) -2) (chk 595 (modulo -3 -2) -1) (chk 596 (modulo 2 2) 0) (chk 597 (modulo -2 -2) 0) (chk 600 (modulo 13 4) 1) (chk 601 (remainder 13 4) 1) (chk 602 (modulo -13 4) 3) (chk 603 (remainder -13 4) -1) (chk 604 (modulo 13 -4) -3) (chk 605 (remainder 13 -4) 1) (chk 606 (modulo -13 -4) -1) (chk 607 (remainder -13 -4) -1) (chk 610 (gcd) 0) (chk 611 (gcd 32 -36) 4) (chk 612 (gcd -32.0 -36) 4.0) (chk 613 (gcd 16 8 4 2 1) 1) (chk 614 (gcd 16 8 4 2 0) 2) (chk 620 (lcm) 1) (chk 621 (lcm 32 -36) 288) (chk 622 (lcm 32.0 -36) 288.0) (chk 623 (lcm 3 5 7 35) 105)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test09) (define-external (chk testnum result expected) testchk) (define (test09) (chk 540 (* -2 -2) 4) (chk 541 (* -2 -1.4) 2.8) (chk 542 (* -2 2) -4) (chk 543 (* -2 2.4) -4.8) (chk 544 (* -1.4 -2) 2.8) (chk 545 (* -1.4 -1.4) 1.96) (chk 546 (* -1.4 2) -2.8) (chk 547 (* -1.4 2.4) -3.36) (chk 548 (* 2 -2) -4) (chk 549 (* 2 -1.4) -2.8) (chk 550 (* 2 2) 4) (chk 551 (* 2 2.4) 4.8) (chk 552 (* 2.4 -2) -4.8) (chk 553 (* 2.4 -1.4) -3.36) (chk 554 (* 2.4 2) 4.8) (chk 555 (* 2.4 2.4) 5.76) (chk 560 (/ -2 -2) 1) (chk 561 (/ -2 -1.4) 1.428571428571429) (chk 562 (/ -2 2) -1) (chk 563 (/ -2 2.4) -.8333333333333334) (chk 564 (/ -1.4 -2) .7) (chk 565 (/ -1.4 -1.4) 1.) (chk 566 (/ -1.4 2) -.7) (chk 567 (/ -1.4 2.4) -.5833333333333334) (chk 568 (/ 2 -2) -1) (chk 569 (/ 2 -1.4) -1.428571428571429) (chk 570 (/ 2 2) 1) (chk 571 (/ 2 2.4) .8333333333333334) (chk 572 (/ 2.4 -2) -1.2) (chk 573 (/ 2.4 -1.4) -1.714285714285714) (chk 574 (/ 2.4 2) 1.2) (chk 575 (/ 2.4 2.4) 1.) (chk 580 (< -2 -2) #F) (chk 581 (< -2 -1.4) #T) (chk 582 (< -2 2) #T) (chk 583 (< -2 2.4) #T) (chk 584 (< -1.4 -2) #F) (chk 585 (< -1.4 -1.4) #F) (chk 586 (< -1.4 2) #T) (chk 587 (< -1.4 2.4) #T) (chk 588 (< 2 -2) #F) (chk 589 (< 2 -1.4) #F) (chk 590 (< 2 2) #F) (chk 591 (< 2 2.4) #T) (chk 592 (< 2.4 -2) #F) (chk 593 (< 2.4 -1.4) #F) (chk 594 (< 2.4 2) #F) (chk 595 (< 2.4 2.4) #F) (chk 600 (<= -2 -2) #T) (chk 601 (<= -2 -1.4) #T) (chk 602 (<= -2 2) #T) (chk 603 (<= -2 2.4) #T) (chk 604 (<= -1.4 -2) #F) (chk 605 (<= -1.4 -1.4) #T) (chk 606 (<= -1.4 2) #T) (chk 607 (<= -1.4 2.4) #T) (chk 608 (<= 2 -2) #F) (chk 609 (<= 2 -1.4) #F) (chk 610 (<= 2 2) #T) (chk 611 (<= 2 2.4) #T) (chk 612 (<= 2.4 -2) #F) (chk 613 (<= 2.4 -1.4) #F) (chk 614 (<= 2.4 2) #F) (chk 615 (<= 2.4 2.4) #T) (chk 620 (= -2 -2) #T) (chk 621 (= -2 -1.4) #F) (chk 622 (= -2 2) #F) (chk 623 (= -2 2.4) #F) (chk 624 (= -1.4 -2) #F) (chk 625 (= -1.4 -1.4) #T) (chk 626 (= -1.4 2) #F) (chk 627 (= -1.4 2.4) #F) (chk 628 (= 2 -2) #F) (chk 629 (= 2 -1.4) #F) (chk 630 (= 2 2) #T) (chk 631 (= 2 2.4) #F) (chk 632 (= 2.4 -2) #F) (chk 633 (= 2.4 -1.4) #F) (chk 634 (= 2.4 2) #F) (chk 635 (= 2.4 2.4) #T) (chk 640 (> -2 -2) #F) (chk 641 (> -2 -1.4) #F) (chk 642 (> -2 2) #F) (chk 643 (> -2 2.4) #F) (chk 644 (> -1.4 -2) #T) (chk 645 (> -1.4 -1.4) #F) (chk 646 (> -1.4 2) #F) (chk 647 (> -1.4 2.4) #F) (chk 648 (> 2 -2) #T) (chk 649 (> 2 -1.4) #T) (chk 650 (> 2 2) #F) (chk 651 (> 2 2.4) #F) (chk 652 (> 2.4 -2) #T) (chk 653 (> 2.4 -1.4) #T) (chk 654 (> 2.4 2) #T) (chk 655 (> 2.4 2.4) #F)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test10) (define-external (chk testnum result expected) testchk) (define (test10) (chk 660 (>= -2 -2) #T) (chk 661 (>= -2 -1.4) #F) (chk 662 (>= -2 2) #F) (chk 663 (>= -2 2.4) #F) (chk 664 (>= -1.4 -2) #T) (chk 665 (>= -1.4 -1.4) #T) (chk 666 (>= -1.4 2) #F) (chk 667 (>= -1.4 2.4) #F) (chk 668 (>= 2 -2) #T) (chk 669 (>= 2 -1.4) #T) (chk 670 (>= 2 2) #T) (chk 671 (>= 2 2.4) #F) (chk 672 (>= 2.4 -2) #T) (chk 673 (>= 2.4 -1.4) #T) (chk 674 (>= 2.4 2) #T) (chk 675 (>= 2.4 2.4) #T) (chk 680 (MIN -2 -2) -2) (chk 681 (MIN -2 -1.4) -2) (chk 682 (MIN -2 2) -2) (chk 683 (MIN -2 2.4) -2) (chk 684 (MIN -1.4 -2) -2) (chk 685 (MIN -1.4 -1.4) -1.4) (chk 686 (MIN -1.4 2) -1.4) (chk 687 (MIN -1.4 2.4) -1.4) (chk 688 (MIN 2 -2) -2) (chk 689 (MIN 2 -1.4) -1.4) (chk 690 (MIN 2 2) 2) (chk 691 (MIN 2 2.4) 2) (chk 692 (MIN 2.4 -2) -2) (chk 693 (MIN 2.4 -1.4) -1.4) (chk 694 (MIN 2.4 2) 2) (chk 695 (MIN 2.4 2.4) 2.4) (chk 700 (MAX -2 -2) -2) (chk 701 (MAX -2 -1.4) -1.4) (chk 702 (MAX -2 2) 2) (chk 703 (MAX -2 2.4) 2.4) (chk 704 (MAX -1.4 -2) -1.4) (chk 705 (MAX -1.4 -1.4) -1.4) (chk 706 (MAX -1.4 2) 2) (chk 707 (MAX -1.4 2.4) 2.4) (chk 708 (MAX 2 -2) 2) (chk 709 (MAX 2 -1.4) 2) (chk 710 (MAX 2 2) 2) (chk 711 (MAX 2 2.4) 2.4) (chk 712 (MAX 2.4 -2) 2.4) (chk 713 (MAX 2.4 -1.4) 2.4) (chk 714 (MAX 2.4 2) 2.4) (chk 715 (MAX 2.4 2.4) 2.4) (chk 720 (POSITIVE? -2) #F) (chk 721 (POSITIVE? -1.6) #F) (chk 722 (POSITIVE? -1.4) #F) (chk 723 (POSITIVE? 0) #F) (chk 724 (POSITIVE? 0.) #F) (chk 725 (POSITIVE? 1.6) #T) (chk 726 (POSITIVE? 2) #T) (chk 727 (POSITIVE? 2.4) #T) (chk 730 (ZERO? -2) #F) (chk 731 (ZERO? -1.6) #F) (chk 732 (ZERO? -1.4) #F) (chk 733 (ZERO? 0) #T) (chk 734 (ZERO? 0.) #T) (chk 735 (ZERO? 1.6) #F) (chk 736 (ZERO? 2) #F) (chk 737 (ZERO? 2.4) #F) (chk 740 (NEGATIVE? -2) #T) (chk 741 (NEGATIVE? -1.6) #T) (chk 742 (NEGATIVE? -1.4) #T) (chk 743 (NEGATIVE? 0) #F) (chk 744 (NEGATIVE? 0.) #F) (chk 745 (NEGATIVE? 1.6) #F) (chk 746 (NEGATIVE? 2) #F) (chk 747 (NEGATIVE? 2.4) #F) (chk 750 (ABS -2) 2) (chk 751 (ABS -1.6) 1.6) (chk 752 (ABS -1.4) 1.4) (chk 753 (ABS 0) 0) (chk 754 (ABS 0.) 0.) (chk 755 (ABS 1.6) 1.6) (chk 756 (ABS 2) 2) (chk 757 (ABS 2.4) 2.4) (if (member (list-ref (implementation-information) 3) '("VAX" "R2000")) (chk 758 (ABS -536870912) 536870912.)) (chk 760 (FLOOR -2) -2) (chk 761 (FLOOR -1.6) -2.) (chk 762 (FLOOR -1.4) -2.) (chk 763 (FLOOR 0) 0) (chk 764 (FLOOR 0.) 0.) (chk 765 (FLOOR 1.6) 1.) (chk 766 (FLOOR 2) 2) (chk 767 (FLOOR 2.4) 2.) (chk 770 (CEILING -2) -2) (chk 771 (CEILING -1.6) -1.) (chk 772 (CEILING -1.4) -1.) (chk 773 (CEILING 0) 0) (chk 774 (CEILING 0.) 0.) (chk 775 (CEILING 1.6) 2.) (chk 776 (CEILING 2) 2) (chk 777 (CEILING 2.4) 3.)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test11) (define-external (chk testnum result expected) testchk) (define minint (string->number "-536870912")) (define zero 0) (define zeropt 0.0) (define (test11) (let ((arch (list-ref (implementation-information) 3))) (when (member arch '("VAX" "R2000")) (chk 01 (+ 268435455 268435456) 536870911) (chk 02 (+ 536870910 1) 536870911) (chk 03 (+ 536870909 2) 536870911) (chk 04 (+ 3 536870908) 536870911) (chk 05 (+ 536870907 4) 536870911) (chk 06 (+ 2 536870910) 536870912.) (chk 07 (+ 536870909 3) 536870912.) (chk 08 (+ 536870908 4) 536870912.) (chk 09 (+ 300000000 300000000) 600000000.) (chk 10 (+ 500000000 522334455) 1022334455.) (chk 11 (+ -500000000 522334455) 22334455.) (chk 12 (+ -536543210 -522334455) -1058877665.) (chk 13 (+ -1 -536870911) minint) (chk 14 (+ 268435456 268435456) 536870912.) (chk 15 (+ 0 0.) 0.) (chk 16 (+ 164. 78) 242.) (chk 17 (- 0 -536870911) 536870911) (chk 18 (- -300000000 300000000) -600000000.) (chk 19 (- -500000000 36870912) minint) (chk 20 (- 1 -536870911) 536870912.) (chk 21 (- -268435455 268435456) -536870911) (chk 22 (- -536870911 1) minint) (chk 23 (- -500000001 1) -500000002) (chk 24 (- 420000000 520000000) -100000000) (chk 25 (- -230000000 450000000) -680000000.) (chk 26 (- 11 60000000011.) -60000000000.) (chk 27 (- 536870911 643) 536870268) (chk 28 (- -536870911 643) -536871554.) (chk 29 (- 448000000 448000000) 0) (chk 30 (- 448000000. 448000000) 0.) (chk 31 (* -23000 -23000) 529000000) (chk 32 (* 59652323 9) 536870907) (chk 33 (* 8 100000000) 800000000.) (chk 34 (* 43210 12345) 533427450) (chk 35 (* 3000000 3000000) 9000000000000.) (chk 36 (* 2 268435456) 536870912.) (chk 37 (* -268435456 2) minint) (chk 38 (* -536870911 -1) 536870911) (chk 38 (* 4500 -60000) -270000000) (when (equal? arch "VAX") (chk 40 (catch-error (lambda () (/ 233545 zero))) "***** ????? Divide by zero") (chk 41 (catch-error (lambda ()(quotient 233 zero))) "***** ????? Divide by zero") (chk 42 (catch-error (lambda ()(/ 1. zero))) "***** ????? Divide by zero") (chk 43 (catch-error (lambda () (quotient 345 zeropt))) "***** ????? Divide by zero") (chk 44 (catch-error (lambda ()(* -02.9e-38 .1))) '(0.0)) (chk 45 (catch-error (lambda ()(* 1.27e38 10))) "***** ????? Overflow") (chk 46 (catch-error (lambda ()(* 6.e37 3))) "***** ????? Overflow")) (when (equal? arch "R2000") (chk 50 (catch-error (lambda () (/ 233545 zero))) "***** ????? Divide by zero") (chk 51 (catch-error (lambda () (quotient 233 zero))) "***** ????? Divide by zero") (chk 52 (number? (/ 1. zero)) #t) (chk 53 (number? (quotient 345 zeropt)) #t) (chk 54 (number? (* 1.e99 2.e99)) #t) (chk 55 (* 1 3.e99) 3.e99)) (chk 60 (- -536870912) 536870912.))) (chk 780 (TRUNCATE -2) -2) (chk 781 (TRUNCATE -1.6) -1.) (chk 782 (TRUNCATE -1.4) -1.) (chk 783 (TRUNCATE 0) 0) (chk 784 (TRUNCATE 0.) 0.) (chk 785 (TRUNCATE 1.6) 1.) (chk 786 (TRUNCATE 2) 2) (chk 787 (TRUNCATE 2.4) 2.) (chk 790 (ROUND -2) -2) (chk 791 (ROUND -1.6) -2.) (chk 792 (ROUND -1.4) -1.) (chk 793 (ROUND 0) 0) (chk 794 (ROUND 0.) 0.) (chk 795 (ROUND 1.6) 2.) (chk 796 (ROUND 2) 2) (chk 797 (ROUND 2.4) 2.) (chk 801 (exp 0) 1.) (chk 802 (exp 1) 2.7182818) (chk 811 (log (exp 1)) 1.0) (chk 821 (sin 0) 0.0) (chk 822 (sin 1) .841471) (chk 823 (+ (* (sin 1) (sin 1)) (* (cos 1) (cos 1))) 1.0) (chk 824 (/ (sin 1) (cos 1)) (tan 1)) (chk 830 (asin (sin 1)) 1.0) (chk 831 (acos (cos 1)) 1.0) (chk 832 (atan (tan 1)) 1.0) (chk 833 (atan 1 1) (atan 1)) (chk 840 (sqrt 25) 5) (chk 841 (sqrt (expt 2 40)) (exact->inexact (expt 2 20))) (chk 842 (exact? (expt 2 20)) #t) (chk 843 (expt 0 0) 1.0) (chk 850 (exact->inexact 23.0) 23.0) (chk 851 (exact->inexact 23) 23.0) (chk 860 (inexact->exact 23) 23) (chk 861 (inexact->exact 23.3) 23) (chk 865 (number->string -23 '(int)) "-23") (chk 866 (number->string -1.3333 '(int)) "-1") (chk 867 (number->string 2.7 '(int)) "3") (chk 868 (number->string 23 '(int)) "23") (chk 869 (number->string -23 '(fix 3)) "-23.000") (chk 870 (number->string -1.3333 '(fix 3)) "-1.333") (chk 871 (number->string 2.7 '(fix 3)) "2.700") (chk 872 (number->string 23 '(fix 3)) "23.000") (let ((x (number->string -23 '(sci 2)))) (if (= (string-length x) 9) (begin (chk 873 (number->string -23 '(sci 2)) "-2.3e+001") (chk 874 (number->string -1.3333 '(sci 2)) "-1.3e+000") (chk 875 (number->string 2.7 '(sci 2)) "2.7e+000") (chk 876 (number->string 23 '(sci 2)) "2.3e+001")) (begin (chk 873 (number->string -23 '(sci 2)) "-2.3e+01") (chk 874 (number->string -1.3333 '(sci 2)) "-1.3e+00") (chk 875 (number->string 2.7 '(sci 2)) "2.7e+00") (chk 876 (number->string 23 '(sci 2)) "2.3e+01")))) (chk 880 (number->string 23) "23") (chk 881 (number->string 23 2) "10111") (chk 882 (number->string 23 8) "27") (chk 883 (number->string 23 10) "23") (chk 884 (number->string 23 16) "17") (chk 885 (number->string -23.32) "-23.32") (chk 890 (string->number "") #f) (chk 891 (string->number "11") 11) (chk 892 (string->number "11" 2) 3) (chk 893 (string->number "11" 8) 9) (chk 894 (string->number "11" 10) 11) (chk 895 (string->number "11" 16) 17) (chk 896 (string->number "#b11" 10) 3) (chk 897 (string->number "-#b11" 10) -3)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test12) (define-external (chk testnum result expected) testchk) (define (test12) ;;; 6.6 Characters (chk 1 (char? '()) #f) (chk 2 (char? '#()) #f) (chk 3 (char? '(1 2)) #f) (chk 4 (char? '#(1 2)) #f) (chk 5 (char? 'x) #f) (chk 6 (char? "x") #f) (chk 7 (char? #\a) #t) (chk 8 (char? (lambda (x) x)) #f) (chk 9 (char? #f) #f) (chk 10 (char? #t) #f) (chk 11 (char? -1) #f) (chk 12 (char? 0) #f) (chk 13 (char? 1) #f) (chk 14 (char? -2.5) #f) (chk 15 (char? 0.0) #f) (chk 16 (char? 1.5) #f) (chk 20 (char=? #\a #\A) #f) (chk 21 (char=? #\2 #\4) #f) (chk 22 (char=? #\a #\b) #f) (chk 23 (char=? #\b #\a) #f) (chk 24 (char=? #\c #\c) #t) (chk 30 (char? #\a #\A) #t) (chk 41 (char>? #\2 #\4) #f) (chk 42 (char>? #\a #\b) #f) (chk 43 (char>? #\b #\a) #t) (chk 44 (char>? #\c #\c) #f) (chk 50 (char<=? #\a #\A) #f) (chk 51 (char<=? #\2 #\4) #t) (chk 52 (char<=? #\a #\b) #t) (chk 53 (char<=? #\b #\a) #f) (chk 54 (char<=? #\c #\c) #t) (chk 60 (char>=? #\a #\A) #t) (chk 61 (char>=? #\2 #\4) #f) (chk 62 (char>=? #\a #\b) #f) (chk 63 (char>=? #\b #\a) #t) (chk 64 (char>=? #\c #\c) #t) (chk 70 (char-alphabetic? #\.) #f) (chk 71 (char-alphabetic? #\3) #f) (chk 72 (char-alphabetic? #\a) #t) (chk 73 (char-alphabetic? #\A) #t) (chk 74 (char-alphabetic? #\tab) #f) (chk 75 (char-alphabetic? #\space) #f) (chk 76 (char-alphabetic? #\newline) #f) (chk 80 (char-numeric? #\.) #f) (chk 81 (char-numeric? #\3) #t) (chk 82 (char-numeric? #\a) #f) (chk 83 (char-numeric? #\A) #f) (chk 84 (char-numeric? #\tab) #f) (chk 85 (char-numeric? #\space) #f) (chk 86 (char-numeric? #\newline) #f) (chk 90 (char-whitespace? #\.) #f) (chk 91 (char-whitespace? #\3) #f) (chk 92 (char-whitespace? #\a) #f) (chk 93 (char-whitespace? #\A) #f) (chk 94 (char-whitespace? #\tab) #t) (chk 95 (char-whitespace? #\space) #t) (chk 96 (char-whitespace? #\newline) #t) (chk 100 (char-upper-case? #\a) #f) (chk 101 (char-upper-case? #\A) #t) (chk 102 (char-upper-case? #\z) #f) (chk 103 (char-upper-case? #\Z) #t) (chk 110 (char-lower-case? #\a) #t) (chk 111 (char-lower-case? #\A) #f) (chk 112 (char-lower-case? #\z) #t) (chk 113 (char-lower-case? #\Z) #f) (chk 120 (char-upcase #\a) #\A) (chk 121 (char-upcase #\A) #\A) (chk 122 (char-upcase #\z) #\Z) (chk 123 (char-upcase #\Z) #\Z) (chk 124 (char-upcase #\space) #\space) (chk 130 (char-downcase #\a) #\a) (chk 131 (char-downcase #\A) #\a) (chk 132 (char-downcase #\z) #\z) (chk 133 (char-downcase #\Z) #\z) (chk 134 (char-downcase #\space) #\space) (chk 140 (char->integer #\space) 32) (chk 141 (char->integer #\A) 65) (chk 150 (integer->char 32) #\space) (chk 151 (integer->char 65) #\A) (chk 160 (char-ci=? #\a #\A) #t) (chk 161 (char-ci=? #\2 #\4) #f) (chk 162 (char-ci=? #\a #\b) #f) (chk 163 (char-ci=? #\b #\a) #f) (chk 164 (char-ci=? #\c #\c) #t) (chk 165 (char-ci=? #\C #\c) #t) (chk 170 (char-ci? #\a #\A) #f) (chk 181 (char-ci>? #\2 #\4) #f) (chk 182 (char-ci>? #\a #\b) #f) (chk 183 (char-ci>? #\b #\a) #t) (chk 184 (char-ci>? #\B #\a) #t) (chk 185 (char-ci>? #\b #\A) #t) (chk 186 (char-ci>? #\a #\B) #f) (chk 187 (char-ci>? #\c #\c) #f) (chk 190 (char-ci<=? #\a #\A) #t) (chk 191 (char-ci<=? #\2 #\4) #t) (chk 192 (char-ci<=? #\a #\b) #t) (chk 193 (char-ci<=? #\b #\a) #f) (chk 194 (char-ci<=? #\c #\c) #t) (chk 195 (char-ci<=? #\c #\D) #t) (chk 196 (char-ci<=? #\C #\a) #f) (chk 197 (char-ci<=? #\a #\1) #f) (chk 200 (char-ci>=? #\a #\A) #t) (chk 201 (char-ci>=? #\2 #\4) #f) (chk 202 (char-ci>=? #\a #\b) #f) (chk 203 (char-ci>=? #\b #\a) #t) (chk 204 (char-ci>=? #\C #\c) #t) (chk 205 (char-ci>=? #\c #\C) #t) (chk 206 (char-ci>=? #\C #\C) #t) (chk 207 (char-ci>=? #\c #\D) #f)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test13) (define-external (chk testnum result expected) testchk) (define (test13) ;;; 6.7 Strings (chk 1 (string? '()) #f) (chk 2 (string? '#()) #f) (chk 3 (string? '(1 2)) #f) (chk 4 (string? '#(1 2)) #f) (chk 5 (string? 'x) #f) (chk 6 (string? "x") #t) (chk 7 (string? '#\a) #f) (chk 8 (string? (lambda (x) x)) #f) (chk 9 (string? #f) #f) (chk 10 (string? #t) #f) (chk 11 (string? -1) #f) (chk 12 (string? 0) #f) (chk 13 (string? 1) #f) (chk 14 (string? -2.5) #f) (chk 15 (string? 0.0) #f) (chk 16 (string? 1.5) #f) (chk 17 (string) "") (chk 18 (string #\a #\b #\c) "abc") (chk 20 (string-length (make-string 20)) 20) (chk 21 (make-string 20 #\$) "$$$$$$$$$$$$$$$$$$$$") (chk 22 (eqv? (make-string 0) "") #t) (chk 30 (string-length "") 0) (chk 31 (string-length "This string is 17") 17) (chk 32 (string-length (make-string 47)) 47) (chk 40 (string-ref "s" 0) #\s) (chk 41 (string-ref "same" 2) #\m) (chk 42 (string-ref "same" 3) #\e) (let* ((string "This is a sample") (xstring (string-copy string))) (chk 50 (string-set! xstring 4 #\*) #\*) (chk 51 (string-ref xstring 4) #\*) (chk 52 (string-set! xstring 7 #\*) #\*) (chk 53 (string-ref xstring 7) #\*) (chk 54 (string-set! xstring 9 #\*) #\*) (chk 55 (string-ref xstring 9) #\*) (chk 56 string "This is a sample") (chk 57 xstring "This*is*a*sample") (string-set! xstring 3 (integer->char 204)) (chk 58 (char->integer (string-ref xstring 3)) 204)) (chk 60 (string=? "" "zot") #f) (chk 61 (string=? "zot" "") #f) (chk 62 (string=? "a" "abc") #f) (chk 63 (string=? "Apple Core" "Apple") #f) (chk 64 (string=? "Zort 23" "Zort 23") #t) (chk 70 (string? "" "zot") #f) (chk 81 (string>? "zot" "") #t) (chk 82 (string>? "a" "abc") #f) (chk 83 (string>? "Apple Core" "Apple") #t) (chk 84 (string>? "Zort 23" "Zort 23") #f) (chk 90 (string<=? "" "zot") #t) (chk 91 (string<=? "zot" "") #f) (chk 92 (string<=? "a" "abc") #t) (chk 93 (string<=? "Apple Core" "Apple") #f) (chk 94 (string<=? "Zort 23" "Zort 23") #t) (chk 100 (string>=? "" "zot") #f) (chk 101 (string>=? "zot" "") #t) (chk 102 (string>=? "a" "abc") #f) (chk 103 (string>=? "Apple Core" "Apple") #t) (chk 104 (string>=? "Zort 23" "Zort 23") #t) (let ((xstring "This is a sample string")) (chk 110 (substring xstring 0 (string-length xstring)) (string-copy xstring)) (chk 111 (substring xstring 0 (string-length xstring)) xstring) (chk 112 (eq? (substring xstring 0 (string-length xstring)) xstring) #f) (chk 113 (substring xstring 4 8) " is ") (chk 114 (substring xstring 7 10) " a ")) (chk 120 (string-append "" "zot") "zot") (chk 121 (string-append "zot" "") "zot") (chk 122 (string-append "a" "abc") "aabc") (chk 123 (string-append "Apple Core" "Apple") "Apple CoreApple") (chk 124 (string-append "Zort 23" "Zort 23") "Zort 23Zort 23") (chk 130 (string->list "") '()) (chk 131 (string->list "a") '(#\a)) (chk 132 (string->list "This is a sample") '(#\T #\h #\i #\s #\space #\i #\s #\space #\a #\space #\s #\a #\m #\p #\l #\e)) (chk 140 (list->string '()) "") (chk 141 (list->string '(#\a)) "a") (chk 142 (list->string '(#\T #\h #\i #\s)) "This") (chk 150 (string-fill! (make-string 10) #\<) "<<<<<<<<<<") (chk 151 (string-fill! "" #\Z) "") (chk 160 (string-ci=? "" "zot") #f) (chk 161 (string-ci=? "zot" "") #f) (chk 162 (string-ci=? "a" "aBc") #f) (chk 163 (string-ci=? "Apple Core" "Apple") #f) (chk 164 (string-ci=? "Zort 23" "Zort 23") #t) (chk 165 (string-ci=? "Able was I ere I saw Elba" "able was i ere i saw elba") #t) (chk 170 (string-ci? "" "zot") #f) (chk 181 (string-ci>? "zot" "") #t) (chk 182 (string-ci>? "A" "abc") #f) (chk 183 (string-ci>? "APPLE Core" "apple") #t) (chk 184 (string-ci>? "Zort 23" "Zort 23") #f) (chk 185 (string-ci>? "zoRt 23" "ZoRt 22") #t) (chk 190 (string-ci<=? "" "zot") #t) (chk 191 (string-ci<=? "zot" "") #f) (chk 192 (string-ci<=? "a" "abc") #t) (chk 193 (string-ci<=? "Apple Core" "Apple") #f) (chk 194 (string-ci<=? "Zort 23" "Zort 23") #t) (chk 195 (string-ci<=? "zoRt 23" "ZoRt 24") #t) (chk 200 (string-ci>=? "" "zot") #f) (chk 201 (string-ci>=? "zot" "") #t) (chk 202 (string-ci>=? "a" "abc") #f) (chk 203 (string-ci>=? "Apple Core" "Apple") #t) (chk 204 (string-ci>=? "Zort 23" "Zort 23") #t) (chk 205 (string-ci>=? "zoRt 23" "ZoRt 22") #t)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test14) (define-external (chk testnum result expected) testchk) (define (RR s) (set! %record-prefix-char #\~) (set! %record-read (lambda (port) (list->%record (read port)))) (read (open-input-string s))) (define (test14) ;;; 6.8 Vectors (chk 01 (vector? '()) #f) (chk 02 (vector? '#()) #t) (chk 03 (vector? '(1 2)) #f) (chk 04 (vector? '#(1 2)) #t) (chk 05 (vector? 'x) #f) (chk 06 (vector? "x") #f) (chk 07 (vector? '#\a) #f) (chk 08 (vector? (lambda (x) x)) #f) (chk 09 (vector? #f) #f) (chk 10 (vector? #t) #f) (chk 11 (vector? -1) #f) (chk 12 (vector? 0) #f) (chk 13 (vector? 1) #f) (chk 14 (vector? -2.5) #f) (chk 15 (vector? 0.0) #f) (chk 16 (vector? 1.5) #f) (chk 20 (vector-length (make-vector 20)) 20) (chk 21 (eq? (make-vector 0) '#()) #t) (chk 22 (make-vector 5 (make-vector 1 1)) '#(#(1) #(1) #(1) #(1) #(1))) (chk 30 (vector) '#()) (chk 31 (vector 0) '#(0)) (chk 32 (vector 0 1) '#(0 1)) (chk 31 (vector 0 1 2 3 4) '#(0 1 2 3 4)) (chk 40 (vector-length '#()) 0) (chk 41 (vector-length '#(1 2 3)) 3) (chk 42 (vector-length (make-vector 1000)) 1000) (chk 50 (vector-ref '#(zero one two three) 0) 'zero) (chk 51 (vector-ref '#(zero one two three) 1) 'one) (chk 52 (vector-ref '#(zero one two three) 3) 'three) (let ((xvector (make-vector 4))) (vector-set! xvector 0 'zero) (vector-set! xvector 1 'one) (vector-set! xvector 2 'two) (vector-set! xvector 3 'three) (chk 60 xvector '#(zero one two three))) (chk 70 (vector->list '#()) '()) (chk 71 (vector->list '#(zero one two three)) '(zero one two three)) (chk 80 (list->vector '()) '#()) (chk 81 (list->vector '(1)) '#(1)) (chk 82 (list->vector '(1 2 3 4)) '#(1 2 3 4)) (chk 90 (vector-fill! (make-vector 10) #t) '#(#t #t #t #t #t #t #t #t #t #t)) (chk 91 (vector-fill! '#() 1) '#()) ;;; *.* Records (chk 101 (%record? '()) #f) (chk 102 (%record? '#()) #f) (chk 103 (%record? '(1 2)) #f) (chk 104 (%record? '#(1 2)) #f) (chk 105 (%record? 'x) #f) (chk 106 (%record? "x") #f) (chk 107 (%record? '#\a) #f) (chk 108 (%record? (lambda (x) x)) #f) (chk 109 (%record? #f) #f) (chk 110 (%record? #t) #f) (chk 111 (%record? -1) #f) (chk 112 (%record? 0) #f) (chk 113 (%record? 1) #f) (chk 114 (%record? -2.5) #f) (chk 115 (%record? 0.0) #f) (chk 116 (%record? 1.5) #f) (chk 117 (%record? (make-%record 1)) #t) (chk 120 (%record-length (make-%record 20)) 20) (chk 121 (eq? (make-%record 0) (make-%record 0)) #f) (chk 122 (eq? (make-%record 0) (make-%record 0)) #f) (chk 123 (equal? (make-%record 0) (make-%record 0)) #f) (chk 124 (make-%record 0) (make-%record 0)) (chk 125 (make-%record 5 #t) (rr "#~(#t #t #t #t #t)")) (chk 130 (%record) (rr "#~()")) (chk 131 (%record 0) (rr "#~(0)")) (chk 132 (%record 0 1) (rr "#~(0 1)")) (chk 131 (%record 0 1 2 3 4) (rr "#~(0 1 2 3 4)")) (chk 140 (%record-length (rr "#~()")) 0) (chk 141 (%record-length (rr "#~(1 2 3)")) 3) (chk 142 (%record-length (make-%record 1000)) 1000) (chk 150 (%record-ref (rr "#~(zero one two three)") 0) 'zero) (chk 151 (%record-ref (rr "#~(zero one two three)") 1) 'one) (chk 152 (%record-ref (rr "#~(zero one two three)") 3) 'three) (let ((x%record (make-%record 4))) (%record-set! x%record 0 'zero) (%record-set! x%record 1 'one) (%record-set! x%record 2 'two) (%record-set! x%record 3 'three) (chk 160 x%record (rr "#~(zero one two three)"))) (chk 170 (%record->list (rr "#~()")) '()) (chk 171 (%record->list (rr "#~(zero one two three)")) '(zero one two three)) (chk 180 (list->%record '()) (rr "#~()")) (chk 181 (list->%record '(1)) (rr "#~(1)")) (chk 182 (list->%record '(1 2 3 4)) (rr "#~(1 2 3 4)"))) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test15) (define-external (chk testnum result expected) testchk) (define unknown #t) (define (test15) ;;; 6.9 Control features (chk 01 (procedure? '()) #f) (chk 02 (procedure? '#()) #f) (chk 03 (procedure? '(1 2)) #f) (chk 04 (procedure? '#(1 2)) #f) (chk 05 (procedure? 'x) #f) (chk 06 (procedure? "x") #f) (chk 07 (procedure? '#\a) #f) (chk 08 (procedure? (lambda (x) x)) #t) (chk 09 (procedure? #f) #f) (chk 10 (procedure? #f) #f) (chk 11 (procedure? -1) #f) (chk 12 (procedure? 0) #f) (chk 13 (procedure? 1) #f) (chk 14 (procedure? -2.5) #f) (chk 15 (procedure? 0.0) #f) (chk 16 (procedure? 1.5) #f) (chk 20 (apply (lambda () 1) '()) 1) (chk 21 (apply (lambda (x) x) '(1)) 1) (chk 22 (apply (lambda (x y) (+ x y)) '(1 2)) 3) (chk 23 (apply (lambda x x) '(1 2 3)) '(1 2 3)) (chk 24 (apply (lambda (x . y) (cons x y)) '(1 2 3 4)) '(1 2 3 4)) (chk 25 (apply + '(1 2 3 4)) 10) (chk 26 (apply + 1 2 3 4 '()) 10) (chk 27 (apply + 1 2 '(3 4)) 10) (let ((x '(a b c))) (chk 28 (eq? (apply list x) x) #f)) (chk 30 (map (lambda (x) (+ x 1)) '(0 1 2 3 4 5 6 7 8 9)) '(1 2 3 4 5 6 7 8 9 10)) (chk 31 (map + '(1 2 3 4 5) '(2 4 6 8 10)) '(3 6 9 12 15)) (chk 32 (map + '(1 2 3 4 5) '(10 20 30 40 50) '(100 200 300 400 500)) '(111 222 333 444 555)) (chk 33 (map + '(1 2 3 4 5) '(10 20 30 40 50) '(100 200 300 400 500) '(1000 2000 3000 4000 5000)) '(1111 2222 3333 4444 5555)) (let ((x (make-vector 10))) (for-each (lambda (i) (vector-set! x i (- 0 i))) '(0 1 2 3 4 5 6 7 8 9)) (chk 40 x '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)) (for-each (lambda (i j) (vector-set! x i (+ i j))) '(0 1 2 3 4 5 6 7 8 9) '(0 10 20 30 40 50 60 70 80 90)) (chk 41 x '#(0 11 22 33 44 55 66 77 88 99)) (for-each (lambda (i j k) (vector-set! x i (+ i j k))) '(0 1 2 3 4 5 6 7 8 9) '(0 10 20 30 40 50 60 70 80 90) '(0 100 200 300 400 500 600 700 800 900)) (chk 42 x '#(0 111 222 333 444 555 666 777 888 999)) (for-each (lambda (i j k l) (vector-set! x i (+ i j k l))) '(0 1 2 3 4 5 6 7 8 9) '(0 10 20 30 40 50 60 70 80 90) '(0 100 200 300 400 500 600 700 800 900) '(0 1000 2000 3000 4000 5000 6000 7000 8000 9000)) (chk 43 x '#(0 1111 2222 3333 4444 5555 6666 7777 8888 9999))) (chk 50 (with-output-to-string cwcc1) "12") (chk 51 (with-output-to-string cwcc2) "12") (chk 52 (with-output-to-string cwcc3) "hi") (chk 53 (with-output-to-string cwcc4) "HEY!") (chk 54 (with-output-to-string mondo-bizarro) "11213") (set! unknown (lambda () 'zero-args)) (chk 60 (unknown) 'zero-args) (set! unknown (lambda x x)) (chk 61 (unknown) '()) (chk 62 (unknown 1) '(1)) (chk 63 (unknown 1 2) '(1 2)) (chk 64 (unknown 1 2 3 4 5 6) '(1 2 3 4 5 6)) (set! unknown (lambda (x) x)) (chk 65 (unknown 23) 23) (set! unknown (lambda (x . y) (list x y))) (chk 66 (unknown 1) '(1 ())) (chk 67 (unknown 1 2) '(1 (2))) (chk 68 (unknown 1 2 3 4 5) '(1 (2 3 4 5))) (set! unknown (lambda (x y z) (list x y z))) (chk 69 (unknown 20 30 40) '(20 30 40)) (chk 70 (force (delay (string-length "abc"))) 3) (chk 71 (procedure? (delay (string-length "abc"))) #t) (let* ((y 0) (x (delay (begin (set! y (+ 1 y)) y)))) (chk 72 (force x) 1) (chk 73 (force x) 1))) (define (cwcc1) ;;; Normal return. (display (call-with-current-continuation (lambda (x) (display 1) 2)))) (define (cwcc2) ;;; Return value via the continuation. (display (call-with-current-continuation (lambda (x) (display 1) (x 2) (display 3))))) (define (cwcc3) ;;; Call the returned continuation. (Dybvig, pg 80) (display (let ((x (call-with-current-continuation (lambda (k) k)))) (x (lambda (ignore) "hi"))))) (define (cwcc4) ;;; Another trick (Dybvig, pg 81) (display (((call-with-current-continuation (lambda (k) k)) (lambda (x) x)) 'hey!))) (define (mondo-bizarro) ;;; Finally, a classic (Lisp Pointers I-2.27) (let ((k (call-with-current-continuation (lambda (c) c)))) (display 1) (call-with-current-continuation (lambda (c) (k c))) (display 2) (call-with-current-continuation (lambda (c) (k c))) (display 3))) (define (WITH-OUTPUT-TO-STRING func) (let ((port (open-output-string)) (save-current-output-port (current-output-port))) (set! scrt5_current-output-port-value port) (func) (set! scrt5_current-output-port-value save-current-output-port) (get-output-string port))) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test16) (define-external (chk testnum result expected) testchk) (define BIGENDIAN (not (eq? (c-byte-ref "A" (- 1 c-sizeof-tscp)) 1))) (define LSB-SHORT (if bigendian (/ c-sizeof-int 2) 0)) ; byte offset to lsb short (define MSB-SHORT (if bigendian 0 (/ c-sizeof-int 2))) ; byte offset to msb short (define (test16) ;;; *.* Extensions for accessing C structures. Byte order is computed (let ((s (make-string 10 #\*))) (c-byte-set! s 0 (char->integer #\S)) (c-byte-set! s 1 (char->integer #\c)) (c-byte-set! s 2 (char->integer #\h)) (c-byte-set! s 3 (char->integer #\e)) (c-byte-set! s 4 (char->integer #\m)) (c-byte-set! s 5 (char->integer #\e)) (c-byte-set! s 6 0.0) (c-byte-set! s 7 -1) (c-byte-set! s 8 255) (chk 1 (c-string->string s) "Scheme") (chk 2 (integer->char (c-byte-ref s 0)) #\S) (chk 3 (integer->char (c-byte-ref s 2)) #\h) (chk 4 (c-byte-ref s 7) 255) (chk 5 (c-byte-ref s 8) 255)) (let ((s (make-string 10 #\*))) (cond ((and (= c-sizeof-int 4) (= c-sizeof-short 2)) (c-int-set! s 0 #xffff) (chk 10 (c-int-ref s 0) #xffff) (chk 11 (c-shortunsigned-ref s lsb-short) #xffff) (chk 12 (c-shortunsigned-ref s msb-short) 0) (chk 13 (c-shortint-ref s lsb-short) -1) (chk 14 (c-shortint-ref s msb-short) 0) (c-shortint-set! s msb-short -1) (chk 15 (c-int-ref s 0) -1) (c-shortunsigned-set! s lsb-short #xfffe) (chk 16 (c-int-ref s 0) -2)) (else (format #t "Tests 10-16 omitted~%")))) (let ((s (make-string 20 #\*))) (cond ((and (= c-sizeof-int 4) (= c-sizeof-tscp 4)) (c-unsigned-set! s 0 (- (expt 2 32) 1)) (c-int-set! s 4 4) (chk 20 (c-int-ref s 0) -1) (chk 21 (c-unsigned-ref s 0) (- (expt 2 32) 1)) (chk 22 (c-int-ref s 4) 4) (chk 23 (c-unsigned-ref s 4) 4) (chk 24 (c-tscp-ref s 4) 1) (c-tscp-set! s 0 -1) (chk 25 (c-int-ref s 0) -4)) ((and (= c-sizeof-int 4) (= c-sizeof-tscp 8)) (c-unsigned-set! s 0 (- (expt 2 32) 1)) (c-int-set! s 4 4) (chk 20 (c-int-ref s 0) -1) (chk 21 (c-unsigned-ref s 0) (- (expt 2 32) 1)) (chk 22 (c-int-ref s 4) 4) (chk 23 (c-unsigned-ref s 4) 4) (c-int-set! s 8 -4) (c-unsigned-set! s 12 (- (expt 2 32) 1)) (chk 24 (c-tscp-ref s 8) -1) (c-tscp-set! s 0 -1) (chk 25 (c-int-ref s 0) -4)) (else (format #t "Tests 20-25 omitted~%")))) (let ((s (make-string 20))) (c-float-set! s 0 -1) (chk 30 (c-float-ref s 0) -1.0) (c-double-set! s 0 -1) (chk 31 (c-double-ref s 0) -1.0)) (let ((s (make-string 10 #\*)) (v (make-vector 10 -1))) (chk 40 (scheme-byte-ref s (if bigendian (- c-sizeof-tscp 2) 1)) 10) (chk 41 (scheme-byte-ref s c-sizeof-tscp) (char->integer #\*)) (chk 42 (scheme-byte-ref s (+ 10 c-sizeof-tscp)) 0) (scheme-byte-set! s (+ c-sizeof-tscp 1) (char->integer #\^)) (scheme-byte-set! s (+ c-sizeof-tscp 5) (char->integer #\^)) (chk 43 s "*^***^****") (chk 44 (scheme-s2cuint-ref s 0) (+ 2560 134)) (chk 45 (scheme-int-ref v c-sizeof-tscp) (if (and bigendian (= c-sizeof-int 2) (= c-sizeof-tscp 4)) -1 -4)) (scheme-int-set! v c-sizeof-tscp 4) (scheme-int-set! v (+ c-sizeof-int c-sizeof-tscp) 0) (chk 46 (scheme-tscp-ref v c-sizeof-tscp) (if (and bigendian (= c-sizeof-int 2) (= c-sizeof-tscp 4)) (expt 2 16) 1)) (chk 47 (scheme-int-ref v c-sizeof-tscp) 4) (scheme-tscp-set! v c-sizeof-tscp "This is the TSCP") (chk 48 (vector-ref v 0) "This is the TSCP")) ;;; *.* Bit operations (chk 50 (bit-and 1) 1) (chk 51 (bit-or 1) 1) (chk 52 (bit-xor 1) 1) (chk 53 (bit-not (bit-not 1)) 1) (chk 54 (bit-and 1 3 5) 1) (chk 55 (bit-or 1 3 5) 7) (chk 56 (bit-xor 1 3 5) 7) (chk 57 (bit-lsh 1 31) 2147483648.) (chk 58 (bit-rsh -1 31) 1)) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test17) (define-external (chk testnum result expected) testchk) (define (MAKE-COUNTER x) (lambda () (set! x (+ 1 x)))) ;;; This funny little function showed up on the Scheme mailing list. It ;;; creates an object which has state which never uses a SET!. The I/O ;;; statements in it are there for debugging purposes. (define (MAKE-CELL) (call-with-current-continuation (lambda (return-from-make-cell) (letrec ((state (call-with-current-continuation (lambda (return-new-state) (return-from-make-cell (lambda (op) ; (format (current-output-port) "OP is ~s~%" op) (case op ((set) (lambda (value) (call-with-current-continuation (lambda (return-from-access) (return-new-state (begin ; (format (current-output-port) ; "VALUE is ~s~%" value) (list value return-from-access))))))) ((get) (car state))))))))) ; (format (current-output-port) "STATE is ~s~%" state) ((cadr state) 'done))))) (define (test17) ;;; Exercise the display and call-with-current-continuation some more. (let* ((cntr1 (make-counter 0)) (cntr2 (make-counter 100)) (c1-1 (cntr1)) (c2-101 (cntr2)) (c1-2 (cntr1)) (c2-102 (cntr2))) (chk 1 (list c1-1 c2-101 c1-2 c2-102) '(1 101 2 102))) (let ((cell (make-cell))) ((cell 'set) 23) (chk 2 (cell 'get) 23))) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test18) (define-external (chk test-number result expected) testchk) (define (TEST18) ;;; 6.10 I/O tests. (chk 01 (input-port? '()) #f) (chk 02 (input-port? '#()) #f) (chk 03 (input-port? '(1 2)) #f) (chk 04 (input-port? '#(1 2)) #f) (chk 05 (input-port? 'x) #f) (chk 06 (input-port? "x") #f) (chk 07 (input-port? '#\a) #f) (chk 08 (input-port? (lambda (x) x)) #f) (chk 09 (input-port? #f) #f) (chk 10 (input-port? #t) #f) (chk 11 (input-port? -1) #f) (chk 12 (input-port? 0) #f) (chk 13 (input-port? 1) #f) (chk 14 (input-port? -1.5) #f) (chk 15 (input-port? 0.0) #f) (chk 16 (input-port? 1.5) #f) (chk 17 (input-port? stdin-port) #t) (chk 21 (output-port? '()) #f) (chk 22 (output-port? '#()) #f) (chk 23 (output-port? '(1 2)) #f) (chk 24 (output-port? '#(1 2)) #f) (chk 25 (output-port? 'x) #f) (chk 26 (output-port? "x") #f) (chk 27 (output-port? '#\a) #f) (chk 28 (output-port? (lambda (x) x)) #f) (chk 29 (output-port? #f) #f) (chk 30 (output-port? #t) #f) (chk 31 (output-port? -1) #f) (chk 32 (output-port? 0) #f) (chk 33 (output-port? 1) #f) (chk 34 (output-port? -1.5) #f) (chk 35 (output-port? 0.0) #f) (chk 36 (output-port? 1.5) #f) (chk 37 (output-port? stdout-port) #t) (chk 38 (output-port? stderr-port) #t) (chk 40 (call-with-output-file "test18.tmp" (lambda (port) (write "Test18 - 40" port) 'test-40)) 'test-40) (chk 43 (call-with-input-file "test18.tmp" (lambda (port) (chk 41 (read port) "Test18 - 40") (chk 42 (eof-object? (read port)) #t) 'test-43)) 'test-43) (chk 50 (with-output-to-file "test18.tmp" (lambda () (write "Test18 - 50") 'test-50)) 'test-50) (chk 53 (with-input-from-file "test18.tmp" (lambda () (chk 51 (read) "Test18 - 50") (chk 52 (eof-object? (read)) #t) 'test-53)) 'test-53) (let ((port (open-input-file "test18.tmp"))) (chk 60 (read port) "Test18 - 50") (chk 61 (eof-object? (read port)) #t) (close-input-port port)) (let ((port (open-output-file "test18.tmp"))) (write "Test18 - 70" port) (close-output-port port) (set! port (open-file "test18.tmp" "r")) (chk 70 (read port) "Test18 - 70") (chk 71 (eof-object? (read port)) #t) (chk 72 (eof-object? (read port)) #t) (close-port port)) (let ((port (open-input-string "1.2 (a b c)"))) (chk 80 (read port) 1.2) (chk 81 (read port) '(a b c)) (chk 82 (eof-object? (read port)) #t) (chk 83 (eof-object? (read port)) #t)) (let ((port (open-output-string))) (chk 90 (get-output-string port) "") (write '(a b c d) port) (chk 91 (get-output-string port) "(A B C D)") (chk 92 (get-output-string port) "") (write "This is a string" port) (chk 93 (get-output-string port) "\"This is a string\""))) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test19) (define-external (chk test-number result expected) testchk) (define (TEST19) ;;; 6.10 I/O tests. (let ((port (open-input-string "*"))) (chk 1 (peek-char port) #\*) (chk 2 (peek-char port) #\*) (chk 3 (read-char port) #\*) (chk 4 (eof-object? (read-char port)) #t) (chk 5 (eof-object? (peek-char port)) #t)) (with-output-to-file "test19.tmp" (lambda () (write-char #\*) (chk 10 (write-count) 1) (chk 11 (write-width) 80) (set-write-width! 132) (chk 12 (write-width) 132))) (with-input-from-file "test19.tmp" (lambda () (chk 21 (peek-char) #\*) (chk 22 (peek-char) #\*) (chk 23 (read-char) #\*) (chk 24 (eof-object? (read-char)) #t) (chk 25 (eof-object? (peek-char)) #t))) (with-output-to-file "test19.tmp" (lambda () (with-input-from-file "test19.tmp" (lambda () (display 'a) (chk 30 (eof-object? (read)) #t) (flush-buffer) (chk 31 (read) 'a))))) (chk 50 (format "~%") (list->string '(#\newline))) (chk 51 (format "~a~s" "a" "a") "a\"a\"") (chk 52 (format "~A~S" "a" "a") "a\"a\"") (chk 53 (format "~c~C" #\a #\a) "aa") (chk 54 (format "~~") "~") ) (module test20) (define (TEST20) (with-input-from-file "test20-input.sc" (lambda () (chk 1 (read) '#T) (chk 2 (read) '#T) (chk 3 (read) '#F) (chk 4 (read) '#F) (chk 5 (read) 'APPLE) (chk 6 (read) 'APPLE) (chk 7 (read) '\aPPLE) (chk 8 (read) '\1+) (chk 9 (read) '+) (chk 10 (read) '-) (chk 11 (read) 'A.B) (chk 12 (read) '1) (chk 13 (read) '-1) (chk 14 (read) '1) (chk 15 (read) '3) (chk 16 (read) '9) (chk 17 (read) '161) (chk 18 (read) '3) (chk 19 (read) '9) (chk 20 (read) '161) (chk 21 (read) '1.3) (chk 22 (read) '-1.3) (chk 23 (read) '130.) (chk 24 (read) '-130.) (chk 25 (read) '#\a) (chk 26 (read) '#\A) (chk 27 (read) '#\tab) (chk 28 (read) '#\newline) (chk 29 (read) '#\newline) (chk 30 (read) '#\formfeed) (chk 31 (read) '#\return) (chk 32 (read) '#\space) (chk 33 (read) '#\space) (chk 34 (read) '#\\) (chk 35 (read) '#\space) (chk 36 (read) '#\tab) (chk 37 (read) '"") (chk 38 (read) '"This is a string") (chk 39 (read) '"This is a string with \"embedded\" quote marks") (chk 40 (read) '"This string covers two lines") (chk 41 (read) '()) (chk 42 (read) '(A)) (chk 43 (read) '(A . B)) (chk 44 (read) '(A B C D)) (chk 45 (read) '(A B C D)) (chk 46 (read) '((A B) (C D) (E F) (G H))) (chk 47 (read) '(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 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 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 A B C D E F G H I J K L)) (chk 48 (read) '#()) (chk 49 (read) '#(1)) (chk 50 (read) '#(1 2 3 4)) (chk 51 (read) '#(#(1 2) #(2 3) #(3 4))) (chk 52 (read) '#(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 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 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 A B C D E F G H I J K L)) (chk 53 (read) ''A) (chk 54 (read) ''(1 2 3)) (chk 55 (read) ',B) (chk 56 (read) ',@C) (chk 57 (read) '`(A B C)) (chk 58 (read) '`(A ,B ,@C)) ))) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test21) (define-external (chk test-number result expected) testchk) ;;; An example of the use of nested defines from Abelson & Sussman. (define (SUM term a next b) (if (> a b) 0. (+ (term a) (sum term (next a) next b)))) (define (PI-SUM a b) (define (PI-TERM x) (/ 1. (* x (+ x 2)))) (define (PI-NEXT x) (+ x 4.)) (sum pi-term a pi-next b)) (define (CUBE x) (* x (* x x))) (define (INTEGRAL f a b dx) (define (ADD-DX x) (+ x dx)) (* (sum f (+ a (/ dx 2.)) add-dx b) dx)) (define TOP-TEST21 40) (define (TEST21) (chk 1 (integral cube 0 1 .01) 0.249987492) (chk 10 ((lambda () 10)) 10) (chk 11 ((lambda (x) x) 11) 11) (chk 12 ((lambda x x) 12) '(12)) (chk 13 ((lambda (x . y) (cons x y)) 1 3) '(1 3)) (chk 14 ((lambda (x y . z) (list x y z)) 1 2 3 4) '(1 2 (3 4))) (chk 20 (if #t #f) #f) (chk 21 (if #t #f #t) #f) (chk 22 (if #f #f #t) #t) (let ((get #f) (set #f)) (let ((value #f)) (set! get (lambda () value)) (set! set (lambda (x) (set! value x) x))) (chk 30 (get) #f) (chk 31 (set 31) 31) (chk 32 (get) 31)) (set! top-test21 40) (chk 40 top-test21 40) (let ((f (lambda (x) (cond ((eq? x 1) 'one) ((eq? x 2) 'two) ((if (number? x) x #f) => (lambda (x) (- x 1))) (else 'else))))) (chk 50 (f 1) 'one) (chk 51 (f 2) 'two) (chk 53 (f 10) 9) (chk 54 (f 20) 19) (chk 55 (f 'a) 'else)) (let ((f (lambda (x) (case x ((2 3 5 7) 'prime) ((1) 'one) ((a e i o u) 'vowel) (else 'mystery))))) (chk 60 (f 5) 'prime) (chk 61 (f 1) 'one) (chk 62 (f 'u) 'vowel) (chk 63 (f 'f) 'mystery)) (chk 70 (and (= 2 2) (> 2 1)) #t) (chk 71 (and (= 2 2) (< 2 1)) #f) (chk 72 (and 1 2 'c '(f g)) '(f g)) (chk 73 (and) #t) (chk 74 (and 1) 1) (chk 75 (and '()) '()) (chk 76 (and 1 2 '()) '()) (chk 77 (and (or #f '() (and (not #f) 1 2 3))) 3) (chk 78 (and '() 1 2) '()) (chk 80 (or (= 2 2) (> 2 1)) #t) (chk 81 (or (= 2 2) (< 2 1)) #t) (chk 82 (or #f #f #f) #f) (chk 83 (or (memq 'b '(a b c)) (char->integer 0)) '(b c)) (chk 84 (or) #f) (chk 85 (or 1) 1) (chk 86 (or '()) '()) (chk 87 (or (cdr '(a)) 0) 0) (chk 88 (or (cdr '(a)) 0 1) 0) (let ((x 'x) (y 'y) (z 'z)) (let ((x 'newx) (y x) (z y)) (chk 90 x 'newx) (chk 91 y 'x) (chk 92 z 'y)) (let* ((x 'newx) (y x) (z y)) (chk 90 x 'newx) (chk 91 y 'newx) (chk 92 z 'newx))) (letrec ((even*? (lambda (n) (if (zero? n) #t (odd*? (- n 1))))) (odd*? (lambda (n) (if (zero? n) #f (even*? (- n 1)))))) (chk 100 (even*? 88) #t) (chk 101 (odd*? 13) #t) (chk 102 (even*? 7) #f) (chk 103 (odd*? 14) #f)) (let ((x 1)) (begin (chk 110 x 1) (set! x 10) (chk 111 x 10))) (let ((x (do ((i 0 (+ 1 i)) (j 0) (k '() (cons i k))) ((= i 5) k)))) (chk 120 x '(4 3 2 1 0))) (do ((i 0 (+ 1 i)) (j (lambda (x) (x)))) ((= i 10)) (chk 130 (j (lambda () i)) i)) (do ((i 0 (+ i 1)) (j (lambda (x) (x))) (k 0 (+ k 1)) (l 0 (+ l 1)) (m '() (cons l m))) ((eq? i 5) (chk 140 m '(9 7 5 3 1))) (j (lambda () (list i k))) (chk 140 (* i 2) k) (chk 141 (* i 2) l) (set! k (+ k 1)) (set! l (+ l 1))) (do ((i 0 (+ 1 i))) ((eq? i 10)) (set! i (+ i 1)) (chk 150 (remainder i 2) 1)) (let loop ((l1 '(1 2 3 4)) (l2 '())) (if l1 (loop (cdr l1) (cons (car l1) l2)) (chk 160 l2 '(4 3 2 1)))) (chk 170 `(list ,(+ 1 2) 4) '(list 3 4)) (chk 171 (let ((name 'a)) `(list ,name ',name)) '(list a (quote a))) (chk 172 `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b) '(a 3 4 5 6 b)) (chk 173 `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))) '((foo 7) . cons)) (chk 174 `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)) (chk 175 (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) '(a `(b ,x ,'y d) e)) ) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test22) (define-external (chk test-number result expected) testchk) (define (FSM1 l) (letrec ((s1 (lambda (l c) (set! c (+ c 1)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 1 c)))))) (s2 (lambda (l c) (set! c (+ c 1)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 2 c)))))) (s3 (lambda (l c) (set! c (+ c 1)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 3 c)))))) (s4 (lambda (x) x))) (s1 l 0))) (define (FSM2 l) (letrec ((s1 (lambda (l c) (case (car l) ((a) (s1 (cdr l) (+ c 1))) ((b) (s2 (cdr l) (+ c 1))) ((c) (s3 (cdr l) (+ c 1))) (else (s4 (list 1 (+ c 1))))))) (s2 (lambda (l c) (case (car l) ((a) (s1 (cdr l) (+ c 1))) ((b) (s2 (cdr l) (+ c 1))) ((c) (s3 (cdr l) (+ c 1))) (else (s4 (list 2 (+ c 1))))))) (s3 (lambda (l c) (case (car l) ((a) (s1 (cdr l) (+ c 1))) ((b) (s2 (cdr l) (+ c 1))) ((c) (s3 (cdr l) (+ c 1))) (else (s4 (list 3 (+ c 1))))))) (s4 (lambda (x) x))) (s1 l 0))) (define (FSM3 l) (letrec ((s1 (lambda (l) (case (car l) ((a) (s1 (cdr l))) ((b) (s2 (cdr l))) ((c) (s3 (cdr l))) (else #f)))) (s2 (lambda (l) (case (car l) ((a) (s1 (cdr l))) ((b) (s2 (cdr l))) ((c) (s3 (cdr l))) (else #f)))) (s3 (lambda (l) (case (car l) ((a) (s1 (cdr l))) ((b) (s2 (cdr l))) ((c) (s3 (cdr l))) (else #t))))) (s1 l))) (define (FSM4 l) (letrec ((save '()) (s1 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () l)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 1 c)))))) (s2 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () l)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 2 c)))))) (s3 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () l)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 3 c)))))) (s4 (lambda (x) x))) (s1 l 0))) (define (FSM5 l) (letrec ((save '()) (s1 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () c)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 1 c)))))) (s2 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () c)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 2 c)))))) (s3 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () c)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 3 c)))))) (s4 (lambda (x) x))) (s1 l 0))) (define (TEST22) (chk 1 (fsm1 '(d)) '(1 1)) (chk 2 (fsm1 '(a b c d)) '(3 4)) (chk 10 (fsm2 '(d)) '(1 1)) (chk 11 (fsm2 '(a b c d)) '(3 4)) (chk 20 (fsm3 '(d)) #f) (chk 21 (fsm3 '(c d)) #t) (chk 30 (let l1 ((l '((1 2 3) (4 5 6 7) (8 9))) (m '())) (if l (let l2 ((sl (car (apply (lambda () l) '()))) (c 0)) (if sl (l2 (cdr sl) (+ (apply (lambda () c) '()) 1)) (l1 (cdr l) (append m (list c))))) m)) '(3 4 2)) (chk 40 (fsm4 '(d)) '(1 1)) (chk 41 (fsm4 '(a b c d)) '(3 4)) (chk 50 (fsm5 '(d)) '(1 1)) (chk 51 (fsm5 '(a b c d)) '(3 4)) ) ;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; (module test23) (define-external (chk test-number result expected) testchk) (define (FSM23-1 c) (letrec ((s1 (lambda (c) (if (eq? c 0) #t (s2 (- c 1))))) (s2 (lambda (c) (if (eq? c 0) #f (s1 (- c 1)))))) (s1 c))) (eval-when (load) (define fsm23-1-trials 1000000)) (eval-when (eval) (define fsm23-1-trials 10000)) (define (FSM23-2 c) (letrec ((s1 (lambda (c) (if (car c) (s2 (cdr c)) (s3 (cdr c))))) (s2 (lambda (c) (if (car c) (s1 (cdr c)) (s3 (cdr c))))) (s3 (lambda (c) c))) (s1 c))) (define (FSM23-3 c) (letrec ((s1 (lambda (c) (if c (if (car c) (s2 (cdr c)) (s3 (cdr c))) 'done))) (s2 (lambda (c) (s3 c))) (s3 (lambda (c) (s1 c)))) (s1 c))) (define DEF1-23 (lambda () #f)) (define (DEF2-23) #f) ;;; The following test verifies that assignment to variables initially bound ;;; to functions is correctly handled. (define (NESTED23) (let ((f1 (lambda () 'first-f1))) (define (f2) 'first-f2) (define (f3) 'only-f3) (let ((result (list (f1) (f2) (f3)))) (set! f1 (lambda () 'second-f1)) (set! f2 (lambda () 'second-f2)) (append result (list (f1) (f2) (f3)))))) ;;; The following test verifies that the display is correctly preserved. (define (DISPLAY23) (let ((d1 (car '(a))) (d2 (car '(b))) (d3 (car '(c)))) (define (f1) d1) (define (f2) d2) (define (f3) d3) (chk 60 (f1) 'a) (chk 61 (f2) 'b) (chk 62 (f3) 'c) (chk 63 (display23-1) '(a-1 b-1 c-1)) (chk 64 (f1) 'a) (chk 65 (f2) 'b) (chk 66 (f3) 'c))) (define (DISPLAY23-1) (let ((d1 (car '(a-1)))) (define (f1) (let ((d2 (car '(b-1))) (d3 (car '(c-1)))) (define (f2) (list d1 d2 d3)) (f2) (f2))) (f1) (f1))) ;;; The following test assures that the variable 'a' is correctly allocated to ;;; the display. (define (JMD-DISPLAY23 a) (define (i1) a) (define (i2 x) (if x (i2 #f)) (i1)) (i2 #t)) ;;; The following test assures that the variables 'x' and 'y' are correctly ;;; handled in the display on a tail call. (define (BH-DISPLAY23 x y) (if (< x 10) (begin (input-port? (lambda () (list x y))) (set! y (+ y 1)) (bh-display23 (+ x 1) (+ y 1))) (list x y))) ; make-gen - Try to make Icon-style generator function in Scheme->C. ; David J. Slate; Mon Dec 18 05:10:32 CST 1989 ; make-gen is called with the generator function as its first argument, and ; the args to the generator as remaining args. make-gen returns ; a function object that is called with one of two messages: ; 'refresh - to re-initialize the generator. ; 'next - to get the next result. ; The generator function must take a leading extra arg through which the ; suspend function is passed. ; Results are returned only by (suspend result) calls. ; When generator is exhausted, it returns '(). (define (MAKE-GEN genfun . args) (let* ((savefun genfun) (savecal #f) (call/cc call-with-current-continuation) (suspnd (lambda (result) (call/cc (lambda (contin) (set! savefun contin) (savecal result))))) (gargs (cons suspnd args))) (lambda (msg) (cond ((eq? msg 'refresh) (set! savefun genfun) '() ) ((eq? msg 'next) (if savefun (call/cc (lambda (return) (set! savecal return) (if (eq? savefun genfun) (apply genfun gargs) (savefun '() )) (set! savefun #f) '() )) '() )) (else (display "No such msg!: ") (display msg) (newline)))))) ; gen-sequence illustrates the use of make-gen: (define GEN-SEQUENCE (lambda (suspnd n) (suspnd n) (gen-sequence suspnd (+ n 1)))) (define GENERATOR (make-gen gen-sequence 1)) ;;; Assure that lexical variable in an inline tail-call is detected. (define (interpret-query query item-identifier) (define (examine-each fn) (item-identifier 3)) (define (internal-interpret q) (case (car query) ((and) ; (AND ...) (map internal-interpret (cdr query))) ((contains?) (case (length query) ((2) (examine-each ; (CONTAINS? word) (lambda (record) 3))) ((3) ; (CONTAINS? word field) (examine-each (lambda (record) 3))))))) (internal-interpret query)) ;;; Force compilation of code to pass procedural arguments. (define-c-external (cfunc1 pointer) int "atoi") (define (DONT-CALL-THIS-TEST) (cfunc1 cfunc1)) ;;; Make sure the compiler finds all closed over variables. (define (BH-CLOSED23 x) (define (F1) (cons x x)) (define (F2) (f1)) (define (F3) (f1)) (define (F4) (lambda () (f2))) (f3) f4) ;;; Make sure that SQUARE generates correct C code. (define HC-JUNK (let ((SQUARE (lambda (x) (* x x)))) (lambda (a) (square (square a))))) ;;; Make sure that H as an argument generates correct C code. (define HC-F (lambda (x y) x)) (define HC-G (let ((h (lambda () #f))) (hc-f h (lambda () #f)))) ;;; Problem reported by Henry Cejtin, henry@math.nwu.edu. This procedure is ;;; incorrectly compiled. If the commented-out cont is not commented-out, ;;; then the routine is correctly compiled. (define (comp scan1 cont) (let loop ((scan2 scan1)) (scan2 (lambda () (comp do-2 (lambda (scan3) (scan3 not-called (lambda () ; cont (loop do-3)) should-not-be-called)))) (lambda () (cont scan2)) (lambda () (cont scan2))))) (define not-called (lambda ignored (error 'reg "NOT POSSIBLE"))) (define should-not-be-called (lambda ignored (error 'reg "BUG"))) (define do-1 (lambda (one two three) (one))) (define do-2 (lambda (one two three) (two))) (define do-3 (lambda (one two three) (three))) (define go (lambda () (comp do-1 (lambda ignored 'ok)))) ;;; Used to cause the compiler to loop. (define (bar) (define (index-of-char-in-string char string start-index length-of-string) (cond ((= start-index length-of-string) '()) ((char=? (string-ref string start-index) char) start-index) (#t (index-of-char-in-string char string (+ start-index 1) length-of-string)))) '()) ;;; Used to cause the compiler to crash. (define (CRASH) (define (F x) (+ x 1)) (define (G x) (+ (f x) (f x))) (define (H) (g 23))) ;;; Check top level variable declarations. (define-external TOP-LEVEL-X top-level) (define (TEST-TOP) (set! top-level-x 1) (set! top-level-y 2) (list 'top-level-x top-level-x 'top-level-y top-level-y)) ;;; Compiled constants and macros. (eval-when (load eval) (define-constant A-IS-23 23) (define-macro PLUS1 (lambda (f e) (e `(+ 1 ,(cadr f)) e)))) (eval-when (load compile eval) (define-constant A-CONSTANT-1 23)) (define-constant A-CONSTANT-2 a-constant-1) (define-constant A-CONSTANT-3 3) (define-constant A-CONSTANT-4 (* a-constant-3 a-constant-3)) ;;; Access to an external array. (define-c-external _\i\o\b* ARRAY "_iob") (eval-when (load) (define _iob _\i\o\b*)) (eval-when (eval) (define _iob 0)) ;;; Access to an external procedure pointer. (define-c-external (c-hypot double double) double "hypot") (eval-when (load) (define hypot c-hypot)) (eval-when (eval) (define hypot 0)) ;;; Incorrect optimization, used to result in bad C code. (define a-variable 3) (define (a-procedure) (let ((a-variable 4) (g (lambda (x) a-variable))) (g (g (display 1))))) ;;; Shared constant and top-level variable value, used to result in bad C ;;; code. (define-external some-x top-level) (define (TEST-SOME-X) `(some-x 1) (some-x)) (define (TEST23) (chk 1 (fsm23-1 fsm23-1-trials) #t) (chk 10 (fsm23-2 '(#t #f result)) '(result)) (chk 11 (fsm23-2 '(#f result)) '(result)) (chk 12 (fsm23-2 '(#t #t #f result)) '(result)) (chk 20 (fsm23-3 '(#t #f #t #f #f #t . #f)) 'done) (chk 30 (let l1 ((x 0)) (let l2 ((y 0)) (cond ((procedure? x) 'done) (y (l1 (lambda () y))) (else (l2 (lambda () x)))))) 'done) (chk 40 (def1-23) #f) (set! def1-23 (lambda () #t)) (chk 41 (def1-23) #t) (chk 42 (def2-23) #f) (set! def2-23 (lambda () #t)) (chk 43 (def2-23) #t) (chk 50 (nested23) '(first-f1 first-f2 only-f3 second-f1 second-f2 only-f3)) (display23) (chk 70 (jmd-display23 'jmd) 'jmd) (chk 71 (bh-display23 0 0) '(10 20)) (chk 80 (generator 'next) 1) (chk 81 (generator 'next) 2) (chk 82 (generator 'refresh) '()) (chk 83 (generator 'next) 1) (chk 90 (((bh-closed23 42))) '(42 . 42)) (chk 100 (go) 'ok) (chk 110 (test-top) '(top-level-x 1 top-level-y 2)) (chk 120 (expand 'a-is-23) 23) (chk 121 (expand '(plus1 a-is-23)) '(+ 1 23)) (chk 122 a-constant-2 23) (chk 123 (expand 'a-constant-1) 23) (chk 124 a-constant-3 3) (chk 125 a-constant-4 9) (chk 130 (string-ref "" 0) (integer->char #o21)) (chk 140 (number? _iob) #t) (chk 141 (number? hypot) #t) (chk 150 (letrec ((x 1)) (define x 2) x) 2) ) ;;; ;;; Test functions for basic Scheme functions. ;;; (define (TEST55) ;;; Write length and levels. (for-each (lambda (v n) (set-write-level! v) (set-write-length! n) (format #t "~s ~s ~s~%" v n '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz"))))) '(0 1 1 1 1 2 2 2 3 3 3 #f) '(1 1 2 3 4 1 2 3 2 3 4 #f)) (newline) ;;; Circularity detection. (set-write-circle! #t) (let* ((x (list 1 2 3 4 5)) (y (make-vector 5 x))) (set-cdr! (last-pair x) x) (vector-set! y 4 y) (write y)) (newline) (newline) ;;; Pretty-printing (set-write-pretty! #t) (write '(for-each (lambda (v n) (set-write-level! v) (set-write-length! n) (format #t "~s ~s ~s~%" v n '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz"))))) '(0 1 1 1 1 2 2 2 3 3 3 #f) '(1 1 2 3 4 1 2 3 2 3 4 #f))) (newline) (newline) (set-write-pretty! #f) (pp '(for-each (lambda (v n) (set-write-level! v) (set-write-length! n) (format #t "~s ~s ~s~%" v n '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz"))))) '(0 1 1 1 1 2 2 2 3 3 3 #f) '(1 1 2 3 4 1 2 3 2 3 4 #f))) (newline) #f) scheme2c-2012.10.14/test/makefile000066400000000000000000000057561203736146400162750ustar00rootroot00000000000000# # Scheme->C compiler and runtime tests. # SCC = ../scsc/Xs2cc SCCFLAGS = -g n = n must be defined SRCDIR = ../../test .SUFFIXES: .SUFFIXES: .sc .c .o batch-c = test01.c test02.c test03.c test04.c test05.c \ test06.c test07.c test08.c test09.c test10.c \ test11.c test12.c test13.c test14.c test15.c \ test16.c test17.c test18.c test19.c test20.c \ test21.c test22.c test23.c batch-o = test01.o test02.o test03.o test04.o test05.o \ test06.o test07.o test08.o test09.o test10.o \ test11.o test12.o test13.o test14.o test15.o \ test16.o test17.o test18.o test19.o test20.o \ test21.o test22.o test23.o progs = test test50 test51 test52 test53 test54 \ test01 test02 test03 test04 test05 \ test06 test07 test08 test09 test10 \ test11 test12 test13 test14 test15 \ test16 test17 test18 test19 test20 \ test21 test22 test23 alltests= test.sc testchk.sc \ test01.sc test02.sc test03.sc test04.sc test05.sc \ test06.sc test07.sc test08.sc test09.sc test10.sc \ test11.sc test12.sc test13.sc test14.sc test15.sc \ test16.sc test17.sc test18.sc test19.sc test20.sc \ test21.sc test22.sc test23.sc \ test55.sc source = test.sc testchk.sc \ test01.sc test02.sc test03.sc test04.sc test05.sc \ test06.sc test07.sc test08.sc test09.sc test10.sc \ test11.sc test12.sc test13.sc test14.sc test15.sc \ test16.sc test17.sc test18.sc test19.sc test20.sc \ test20-input.sc test20-make.sc \ test21.sc test22.sc test23.sc \ test50.sc test51.sc test52.sc test53.sc test54.sc test54c.c \ test55.sc \ alltests.sc .sc.c: ${SCC} -C ${SCCFLAGS} $*.sc .c.o: ${SCC} -c ${SCCFLAGS} $*.c test: test.c test.o testchk.c testchk.o ${batch-c} ${batch-o} ${SCC} ${LDFLAGS} -o test ${SCCFLAGS} test.o testchk.o ${batch-o} testn: testchk.c testchk.o ${SCC} ${LDFLAGS} -i ${SCCFLAGS} -o test${n} test${n}.sc testchk.o test50: test50.c test50.o ${SCC} ${LDFLAGS} -o test50 ${SCCFLAGS} test50.o test51: test51.c test51.o ${SCC} ${LDFLAGS} -o test51 ${SCCFLAGS} test51.o test52: test52.c test52.o ${SCC} ${LDFLAGS} -o test52 ${SCCFLAGS} test52.o test53: test53.sc ${SCC} ${LDFLAGS} -i -o test53 ${SCCFLAGS} test53.sc test54: test54.c test54.o test54c.o testchk.o ${SCC} ${LDFLAGS} -o test54 test54.o test54c.o testchk.o test55: test55.c test55.o testchk.o ${SCC} ${LDFLAGS} -o test55 test55.o testchk.o clean: rm -f *.o *.BAK *.CKP core *.S2C clean-sc-to-c: rm -f ${batch-c} test.c testchk.c test50.c test51.c test52.c test53.c \ test54.c noprogs: rm -f ${progs} all: $(MAKE) "SCC=${SCC}" "SCCFLAGS=${SCCFLAGS}" \ test test50 test51 test52 test54 $(MAKE) "SCC=${SCC}" "SCCFLAGS=${SCCFLAGS}" "n=53" testn alltests.sc: ${alltests} cat ${alltests} > alltests.sc srclinks: for x in ${source}; \ do ln -s ${SRCDIR}/$$x $$x;\ done autotest: autotest-test autotest-test50 autotest-test54 autotest-test: test ./test autotest-test50: test50 ./test50 autotest-test54: test54 ./test54 .PHONY: autotest-test autotest-test50 autotest-test54 scheme2c-2012.10.14/test/test.sc000066400000000000000000000060771203736146400161000ustar00rootroot00000000000000;;; Test driver. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test (main test) (with test01 test02 test03 test04 test05 test06 test07 test08 test09 test10 test11 test12 test13 test14 test15 test16 test17 test18 test19 test20 test21 test22 test23)) (define-external TEST-ERRORS testchk) (define (TEST) (set! test-errors 0) (format #t "***** Begin Scheme->C Tests *****~%") (format #t "test01:~%") (test01) (format #t "test02:~%") (test02) (format #t "test03:~%") (test03) (format #t "test04:~%") (test04) (format #t "test05:~%") (test05) (format #t "test06:~%") (test06) (format #t "test07:~%") (test07) (format #t "test08:~%") (test08) (format #t "test09:~%") (test09) (format #t "test10:~%") (test10) (format #t "test11:~%") (test11) (format #t "test12:~%") (test12) (format #t "test13:~%") (test13) (format #t "test14:~%") (test14) (format #t "test15:~%") (test15) (format #t "test16:~%") (test16) (format #t "test17:~%") (test17) (format #t "test18:~%") (test18) (format #t "test19:~%") (test19) (format #t "test20:~%") (test20) (format #t "test21:~%") (test21) (format #t "test22:~%") (test22) (format #t "test23:~%") (test23) (format #t "***** End Scheme->C Tests ~a Errors *****~%" test-errors)) (define (LOAD-TESTS) (load "testchk.sc") (load "test01.sc") (load "test02.sc") (load "test03.sc") (load "test04.sc") (load "test05.sc") (load "test06.sc") (load "test07.sc") (load "test08.sc") (load "test09.sc") (load "test10.sc") (load "test11.sc") (load "test12.sc") (load "test13.sc") (load "test14.sc") (load "test15.sc") (load "test16.sc") (load "test17.sc") (load "test18.sc") (load "test19.sc") (load "test20.sc") (load "test21.sc") (load "test22.sc") (load "test23.sc") ) scheme2c-2012.10.14/test/test01.sc000066400000000000000000000043671203736146400162410ustar00rootroot00000000000000;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test01) (define-external (chk testnum result expected) testchk) (define (test01) ;;; 6.1 Booleans (chk 01 (boolean? '()) #f) (chk 02 (boolean? '#()) #f) (chk 03 (boolean? '(1 2)) #f) (chk 04 (boolean? '#(1 2)) #f) (chk 05 (boolean? 'x) #f) (chk 06 (boolean? "x") #f) (chk 07 (boolean? '#\a) #f) (chk 08 (boolean? (lambda (x) x)) #f) (chk 09 (boolean? #f) #t) (chk 10 (boolean? #t) #t) (chk 11 (boolean? -1) #f) (chk 12 (boolean? 0) #f) (chk 13 (boolean? 1) #f) (chk 14 (boolean? -1.5) #f) (chk 15 (boolean? 0.0) #f) (chk 16 (boolean? 1.5) #f) (chk 21 (not '()) #t) (chk 22 (not '#()) #f) (chk 23 (not '(1 2)) #f) (chk 24 (not '#(1 2)) #f) (chk 25 (not 'x) #f) (chk 26 (not "x") #f) (chk 27 (not '#\a) #f) (chk 28 (not (lambda (x) x)) #f) (chk 29 (not #f) #t) (chk 30 (not #t) #f) (chk 31 (not -1) #f) (chk 32 (not 0) #f) (chk 33 (not 1) #f) (chk 34 (not -1.5) #f) (chk 35 (not 0.0) #f) (chk 36 (not 1.5) #f)) scheme2c-2012.10.14/test/test02.sc000066400000000000000000000055151203736146400162360ustar00rootroot00000000000000;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test02) (define-external (chk testnum result expected) testchk) (define (test02) ;;; 6.2 Equivalence Predicates (let ((list4 (list 4 3 2 1)) (vector4 (vector 4 3 2 1))) (chk 41 (eqv? "" "") #t) (chk 42 (eqv? "" "") #t) (chk 43 (eqv? '() '()) #t) (chk 44 (eqv? '#() '#()) #t) (chk 45 (eqv? (car list4) (car list4)) #t) (chk 46 (eqv? list4 list4) #t) (chk 47 (eqv? vector4 vector4) #t) (chk 48 (eqv? 1 1) #t) (chk 49 (eqv? 1.5 1.5) #t) (chk 50 (eqv? 1.5 (+ 1.0 0.5)) #t) (chk 51 (eqv? list4 (list 4 3 2 1)) #f) (chk 52 (eqv? vector4 (vector 4 3 2 1)) #f) (chk 53 (eqv? 'x 'x) #t) (chk 61 (eq? "" "") #t) (chk 62 (eq? "" "") #t) (chk 63 (eq? '() '()) #t) (chk 64 (eq? '#() '#()) #t) (chk 65 (eq? (car list4) (car list4)) #t) (chk 66 (eq? list4 list4) #t) (chk 67 (eq? vector4 vector4) #t) (chk 68 (eq? 1 1) #t) (chk 69 (eq? 1.5 (+ 1.0 0.5)) #f) (chk 70 (eq? list4 (list 4 3 2 1)) #f) (chk 71 (eq? vector4 (vector 4 3 2 1)) #f) (chk 72 (eq? 'x 'x) #t) (chk 81 (equal? "" "") #t) (chk 82 (equal? "" "") #t) (chk 83 (equal? '() '()) #t) (chk 84 (equal? '#() '#()) #t) (chk 85 (equal? (car list4) (car list4)) #t) (chk 86 (equal? list4 list4) #t) (chk 87 (equal? vector4 vector4) #t) (chk 88 (equal? 1 1) #t) (chk 89 (equal? 1.5 1.5) #t) (chk 90 (equal? 1.5 (+ 1.0 0.5)) #t) (chk 91 (equal? list4 (list 4 3 2 1)) #t) (chk 92 (equal? vector4 (vector 4 3 2 1)) #t) (chk 93 (equal? 'x 'x) #t) (chk 93 (equal? (list (list 1 2) (list 3 4)) '((1 2) (3 4))) #t) (chk 94 (equal? (list (list 1 1) (list 3 4)) '((1 2) (3 4))) #f))) scheme2c-2012.10.14/test/test03.sc000066400000000000000000000174351203736146400162430ustar00rootroot00000000000000;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test03) (define-external (chk testnum result expected) testchk) (define (test03) ;;; 6.3 Pairs and Lists (chk 101 (pair? '()) #f) (chk 102 (pair? '#()) #f) (chk 103 (pair? '(1 2)) #t) (chk 104 (pair? '#(1 2)) #f) (chk 105 (pair? 'x) #f) (chk 106 (pair? "x") #f) (chk 107 (pair? '#\a) #f) (chk 108 (pair? (lambda (x) x)) #f) (chk 109 (pair? #f) #f) (chk 110 (pair? #t) #f) (chk 111 (pair? -1) #f) (chk 112 (pair? 0) #f) (chk 113 (pair? 1) #f) (chk 114 (pair? -1.5) #f) (chk 115 (pair? 0.0) #f) (chk 116 (pair? 1.5) #f) (chk 121 (null? '()) #t) (chk 122 (null? '#()) #f) (chk 123 (null? '(1 2)) #f) (chk 124 (null? '#(1 2)) #f) (chk 125 (null? 'x) #f) (chk 126 (null? "x") #f) (chk 127 (null? '#\a) #f) (chk 128 (null? (lambda (x) x)) #f) (chk 129 (null? #f) #f) (chk 130 (null? #t) #f) (chk 131 (null? -1) #f) (chk 132 (null? 0) #f) (chk 133 (null? 1) #f) (chk 134 (null? -1.5) #f) (chk 135 (null? 0.0) #f) (chk 136 (null? 1.5) #f) (chk 201 (list? '()) #t) (chk 202 (list? '#()) #f) (chk 203 (list? '(1 2)) #t) (chk 204 (list? '#(1 2)) #f) (chk 205 (list? 'x) #f) (chk 206 (list? "x") #f) (chk 207 (list? '#\a) #f) (chk 208 (list? (lambda (x) x)) #f) (chk 209 (list? #f) #f) (chk 210 (list? #t) #f) (chk 211 (list? -1) #f) (chk 212 (list? 0) #f) (chk 213 (list? 1) #f) (chk 214 (list? -1.5) #f) (chk 215 (list? 0.0) #f) (chk 216 (list? 1.5) #f) (chk 217 (list? '(a . b)) #f) (chk 218 (list? (let ((x (list 'a 'b 'c))) (set-cdr! x x) x)) #f) (chk 401 (list) '()) (chk 402 (list 1) '(1)) (chk 403 (list 1 2 3 4 5) '(1 2 3 4 5)) (chk 411 (cons* 1) 1) (chk 412 (cons* 1 2) '(1 . 2)) (chk 413 (cons* 1 2 3) '(1 2 . 3)) (chk 414 (cons* 1 2 3 4) '(1 2 3 . 4)) (chk 415 (cons* 1 2 3 4 '()) '(1 2 3 4)) (chk 421 (car (cons 'car 'cdr)) 'car) (chk 422 (cdr (cons 'car 'cdr)) 'cdr) (let ((cx (cons (cons 'caar 'cdar) (cons 'cadr 'cddr)))) (chk 431 (caar cx) 'caar) (chk 432 (cadr cx) 'cadr) (chk 433 (cdar cx) 'cdar) (chk 434 (cddr cx) 'cddr)) (let ((cx (cons (cons (cons 'caaar 'cdaar) (cons 'cadar 'cddar)) (cons (cons 'caadr 'cdadr) (cons 'caddr 'cdddr))))) (chk 441 (caaar cx) 'caaar) (chk 442 (caadr cx) 'caadr) (chk 443 (cadar cx) 'cadar) (chk 444 (caddr cx) 'caddr) (chk 445 (cdaar cx) 'cdaar) (chk 446 (cdadr cx) 'cdadr) (chk 447 (cddar cx) 'cddar) (chk 448 (cdddr cx) 'cdddr)) (let ((cx (cons (cons (cons (cons 'caaaar 'cdaaar) (cons 'cadaar 'cddaar)) (cons (cons 'caadar 'cdadar) (cons 'caddar 'cdddar))) (cons (cons (cons 'caaadr 'cdaadr) (cons 'cadadr 'cddadr)) (cons (cons 'caaddr 'cdaddr) (cons 'cadddr 'cddddr)))))) (chk 451 (caaaar cx) 'caaaar) (chk 452 (caaadr cx) 'caaadr) (chk 453 (caadar cx) 'caadar) (chk 454 (caaddr cx) 'caaddr) (chk 455 (cadaar cx) 'cadaar) (chk 456 (cadadr cx) 'cadadr) (chk 457 (caddar cx) 'caddar) (chk 458 (cadddr cx) 'cadddr) (chk 461 (cdaaar cx) 'cdaaar) (chk 462 (cdaadr cx) 'cdaadr) (chk 463 (cdadar cx) 'cdadar) (chk 464 (cdaddr cx) 'cdaddr) (chk 465 (cddaar cx) 'cddaar) (chk 466 (cddadr cx) 'cddadr) (chk 467 (cdddar cx) 'cdddar) (chk 468 (cddddr cx) 'cddddr)) (let ((cx (cons 'car 'cdr))) (chk 471 (set-car! cx 1) 1) (chk 472 cx '(1 . cdr)) (chk 473 (set-cdr! cx 2) 2) (chk 474 cx '(1 . 2))) (chk 481 (length '()) 0) (chk 482 (length '(1)) 1) (chk 483 (length '(1 2 3)) 3) (chk 491 (append '() '(1 2 3)) '(1 2 3)) (chk 492 (append '(1 2 3) '()) '(1 2 3)) (chk 493 (append '(1) '(2 3)) '(1 2 3)) (chk 494 (append '(1 2 3) '(4 5 6)) '(1 2 3 4 5 6)) (chk 495 (append) '()) (chk 496 (append '(1 2)) '(1 2)) (chk 497 (append '(1 2) '(3 4) '(5 6)) '(1 2 3 4 5 6)) (chk 498 (append '(1 2) '(3 4) '(5 6) '(7 8) '(9 10)) '(1 2 3 4 5 6 7 8 9 10)) (chk 501 (reverse '()) '()) (chk 502 (reverse '(1)) '(1)) (chk 503 (reverse '(1 2 3)) '(3 2 1)) (chk 511 (list-tail '(0 1 2 3) 0) '(0 1 2 3)) (chk 512 (list-tail '(0 1 2 3) 1) '(1 2 3)) (chk 513 (list-tail '(0 1 2 3) 2) '(2 3)) (chk 521 (list-ref '(0 1 2 3) 0) 0) (chk 522 (list-ref '(0 1 2 3) 1) 1) (chk 523 (list-ref '(0 1 2 3) 2) 2) (chk 531 (last-pair (cons 'a 'b)) '(a . b)) (chk 532 (last-pair '(0 1 2 3 4)) '(4)) (chk 541 (memq 0 '(0 1 2 3 4)) '(0 1 2 3 4)) (chk 542 (memq 3 '(0 1 2 3 4)) '(3 4)) (chk 543 (memq 5 '(0 1 2 3 4)) #f) (chk 551 (memv 0 '(0 1 2 3 4)) '(0 1 2 3 4)) (chk 552 (memv 3 '(0 1 2 3 4)) '(3 4)) (chk 553 (memv 5 '(0 1 2 3 4)) #f) (chk 561 (member 0 '(0 1 2 3 4)) '(0 1 2 3 4)) (chk 562 (member 3 '(0 1 2 3 4)) '(3 4)) (chk 563 (member 5 '(0 1 2 3 4)) #f) (chk 564 (member "zot" '('a 1 #f 'zot "zott" "zot" 'zot)) '("zot" 'zot)) (chk 571 (assq 0 '((0 zero) (1 one) (2 two))) '(0 zero)) (chk 572 (assq 2 '((0 zero) (1 one) (2 two))) '(2 two)) (chk 573 (assq 4 '((0 zero) (1 one) (2 two))) #f) (chk 581 (assv 0 '((0 zero) (1 one) (2 two))) '(0 zero)) (chk 582 (assv 2 '((0 zero) (1 one) (2 two))) '(2 two)) (chk 583 (assv 4 '((0 zero) (1 one) (2 two))) #f) (chk 591 (assoc 0 '((0 zero) (1 one) (2 two))) '(0 zero)) (chk 592 (assoc 2 '((0 zero) (1 one) (2 two))) '(2 two)) (chk 593 (assoc 4 '((0 zero) (1 one) (2 two))) #f) (chk 594 (assoc '(1 2) '((1 one) ((1 2) (one two)) (2 two))) '((1 2) (one two))) (chk 601 (remq 1 '()) '()) (chk 602 (remq 1 '(1 1 1 1 1 1)) '()) (chk 603 (remq 1 '(1 2 1 2 1 2)) '(2 2 2)) (chk 611 (remv 1 '()) '()) (chk 612 (remv 1 '(* 1 1 1 1 1 1)) '(*)) (chk 613 (remv 1 '(1 2 1 2 1 2)) '(2 2 2)) (chk 621 (remove '(1) '()) '()) (chk 622 (remove '(1) '((1) (1) (1) (1) (1) (1))) '()) (chk 623 (remove '(1) '((1) 2 (1) 2 (1) 2)) '(2 2 2)) (let ((cx (list '* 1 1 1 1 1 1)) (l2 (list 2 1 2 1 2 1 2))) (chk 631 (remq! 1 '()) '()) (chk 632 (remq! 1 cx) '(*)) (chk 633 cx '(*)) (chk 634 (remq! 1 l2) '(2 2 2 2)) (chk 635 l2 '(2 2 2 2))) (let ((l1 (list 1 1 1 1 1 1)) (l2 (list 2 1 2 1 2 1 2))) (chk 641 (remv! 1 '()) '()) (chk 642 (remv! 1 l1) '()) (chk 643 l1 '(1 1 1 1 1 1)) (chk 644 (remv! 1 l2) '(2 2 2 2)) (chk 645 l2 '(2 2 2 2))) (let ((l1 (list '(1) '(1) '(1) '(1) '(1) '(1))) (l2 (list 2 '(1) 2 '(1) 2 '(1) 2))) (chk 641 (remove! '(1) '()) '()) (chk 642 (remove! '(1) l1) '()) (chk 643 l1 '((1) (1) (1) (1) (1) (1))) (chk 644 (remove! '(1) l2) '(2 2 2 2)) (chk 645 l2 '(2 2 2 2)))) scheme2c-2012.10.14/test/test04.sc000066400000000000000000000057261203736146400162440ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test04) (define-external (chk testnum result expected) testchk) (define (test04) ;;; 6.4 Symbols (chk 2.001 (symbol? '()) #f) (chk 2.002 (symbol? '#()) #f) (chk 2.003 (symbol? '(1 2)) #f) (chk 2.004 (symbol? '#(1 2)) #f) (chk 2.005 (symbol? 'x) #t) (chk 2.006 (symbol? "x") #f) (chk 2.007 (symbol? '#\a) #f) (chk 2.008 (symbol? (lambda (x) x)) #f) (chk 2.009 (symbol? #f) #f) (chk 2.010 (symbol? #t) #f) (chk 2.011 (symbol? -1) #f) (chk 2.012 (symbol? 0) #f) (chk 2.013 (symbol? 1) #f) (chk 2.014 (symbol? -2.5) #f) (chk 2.015 (symbol? 0.0) #f) (chk 2.016 (symbol? 1.5) #f) (chk 2.021 (string->symbol "APPLE") 'apple) (chk 2.022(string->symbol "apple") '\a\p\p\l\e) (chk 2.023 (eq? (string->uninterned-symbol "APPLE") 'apple) #f) (chk 2.024 (symbol? (string->uninterned-symbol "APPLE")) #t) (chk 2.025 (uninterned-symbol? 'apple) #f) (chk 2.026 (uninterned-symbol? (string->uninterned-symbol "APPLE")) #t) (let* ((s (string #\A #\p #\p #\L #\E)) (s-sym (string->symbol s)) (s-usym (string->uninterned-symbol s))) (string-set! s 0 #\space) (chk 2.027 (symbol->string s-sym) "AppLE") (chk 2.028 (symbol->string s-usym) "AppLE")) (putprop 'x 1 #f) (chk 2.031 (getprop 'x 1) #f) (chk 2.032 (putprop 'x 1 -1) -1) (chk 2.033 (putprop 'x 2 -2) -2) (chk 2.034 (putprop 'x 3 -3) -3) (chk 2.035 (getprop 'x 1) -1) (chk 2.036 (getprop 'x 2) -2) (chk 2.037 (getprop 'x 3) -3) (chk 2.038 (putprop 'x 2 #f) #f) (chk 2.039 (getprop 'x 3) -3) (chk 2.040 (putprop 'x 3 #f) #f) (chk 2.040 (getprop 'x 3) #f) (chk 2.041 (getprop 'x 1) -1) (chk 2.042 (putprop 'x 1 1) 1) (chk 2.043 (getprop 'x 1) 1)) scheme2c-2012.10.14/test/test05.sc000066400000000000000000000106551203736146400162420ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test05) (define-external (chk testnum result expected) testchk) (define (test05) ;;; 6.5 Numbers (chk 051 (number? '()) #f) (chk 052 (number? '#()) #f) (chk 053 (number? '(1 2)) #f) (chk 054 (number? '#(1 2)) #f) (chk 055 (number? 'x) #f) (chk 056 (number? "x") #f) (chk 057 (number? '#\a) #f) (chk 058 (number? (lambda (x) x)) #f) (chk 059 (number? #f) #f) (chk 060 (number? #t) #f) (chk 061 (number? -1) #t) (chk 062 (number? 0) #t) (chk 063 (number? 1) #t) (chk 064 (number? -5) #t) (chk 065 (number? 0.0) #t) (chk 066 (number? 1.5) #t) (chk 071 (complex? '()) #f) (chk 072 (complex? '#()) #f) (chk 073 (complex? '(1 2)) #f) (chk 074 (complex? '#(1 2)) #f) (chk 075 (complex? 'x) #f) (chk 076 (complex? "x") #f) (chk 077 (complex? '#\a) #f) (chk 078 (complex? (lambda (x) x)) #f) (chk 079 (complex? #f) #f) (chk 080 (complex? #t) #f) (chk 081 (complex? -1) #t) (chk 082 (complex? 0) #t) (chk 083 (complex? 1) #t) (chk 084 (complex? -2.5) #t) (chk 085 (complex? 0.0) #t) (chk 086 (complex? 1.5) #t) (chk 091 (real? '()) #f) (chk 092 (real? '#()) #f) (chk 093 (real? '(1 2)) #f) (chk 094 (real? '#(1 2)) #f) (chk 095 (real? 'x) #f) (chk 096 (real? "x") #f) (chk 097 (real? '#\a) #f) (chk 098 (real? (lambda (x) x)) #f) (chk 099 (real? #f) #f) (chk 100 (real? #t) #f) (chk 101 (real? -1) #t) (chk 102 (real? 0) #t) (chk 103 (real? 1) #t) (chk 104 (real? -2.5) #t) (chk 105 (real? 0.0) #t) (chk 106 (real? 1.5) #t) (chk 111 (rational? '()) #f) (chk 112 (rational? '#()) #f) (chk 113 (rational? '(1 2)) #f) (chk 114 (rational? '#(1 2)) #f) (chk 115 (rational? 'x) #f) (chk 116 (rational? "x") #f) (chk 117 (rational? '#\a) #f) (chk 118 (rational? (lambda (x) x)) #f) (chk 119 (rational? #f) #f) (chk 120 (rational? #t) #f) (chk 121 (rational? -1) #t) (chk 122 (rational? 0) #t) (chk 123 (rational? 1) #t) (chk 124 (rational? -2.5) #t) (chk 125 (rational? 0.0) #t) (chk 126 (rational? 1.5) #t) (chk 131 (integer? '()) #f) (chk 132 (integer? '#()) #f) (chk 133 (integer? '(1 2)) #f) (chk 134 (integer? '#(1 2)) #f) (chk 135 (integer? 'x) #f) (chk 136 (integer? "x") #f) (chk 137 (integer? '#\a) #f) (chk 138 (integer? (lambda (x) x)) #f) (chk 139 (integer? #f) #f) (chk 140 (integer? #t) #f) (chk 141 (integer? -1) #t) (chk 142 (integer? 0) #t) (chk 143 (integer? 1) #t) (chk 144 (integer? -2.5) #f) (chk 145 (integer? 0.0) #t) (chk 146 (integer? 1.5) #f) (chk 151 (zero? -1) #f) (chk 152 (zero? 0) #t) (chk 153 (zero? 1) #f) (chk 154 (zero? -2.5) #f) (chk 155 (zero? 0.0) #t) (chk 156 (zero? 1.5) #f) (chk 161 (positive? -1) #f) (chk 162 (positive? 0) #f) (chk 163 (positive? 1) #t) (chk 164 (positive? -2.5) #f) (chk 165 (positive? 0.0) #f) (chk 166 (positive? 1.5) #t) (chk 171 (negative? -1) #t) (chk 172 (negative? 0) #f) (chk 173 (negative? 1) #f) (chk 174 (negative? -2.5) #t) (chk 175 (negative? 0.0) #f) (chk 176 (negative? 1.5) #f)) scheme2c-2012.10.14/test/test06.sc000066400000000000000000000104501203736146400162340ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test06) (define-external (chk testnum result expected) testchk) (define (test06) (chk 181 (odd? -1) #t) (chk 182 (odd? 0) #f) (chk 183 (odd? 1) #t) (chk 184 (odd? -2) #f) (chk 185 (odd? 2) #f) (chk 191 (even? -1) #f) (chk 192 (even? 0) #t) (chk 193 (even? 1) #f) (chk 194 (even? -2) #t) (chk 195 (even? 2) #t) (chk 201 (exact? -1) #t) (chk 202 (exact? 0) #t) (chk 203 (exact? 1) #t) (chk 204 (exact? -2.5) #f) (chk 205 (exact? 0.0) #f) (chk 206 (exact? 1.5) #f) (chk 211 (inexact? -1) #f) (chk 212 (inexact? 0) #f) (chk 213 (inexact? 1) #f) (chk 214 (inexact? -2.5) #t) (chk 215 (inexact? 0.0) #t) (chk 216 (inexact? 1.5) #t) (chk 220 (= 1 2) #F) (chk 221 (= 2 1) #F) (chk 222 (= 2 3) #F) (chk 223 (= 3 2) #F) (chk 224 (= -1 2) #F) (chk 225 (= -2 1) #F) (chk 226 (= -2 3) #F) (chk 227 (= -3 2) #F) (chk 228 (= 1 -2) #F) (chk 229 (= 2 -1) #F) (chk 230 (= 2 -3) #F) (chk 231 (= 3 -2) #F) (chk 232 (= -1 -2) #F) (chk 233 (= -2 -1) #F) (chk 234 (= -2 -3) #F) (chk 235 (= -3 -2) #F) (chk 236 (= 2 2) #T) (chk 237 (= -2 -2) #T) (chk 240 (< 1 2) #T) (chk 241 (< 2 1) #F) (chk 242 (< 2 3) #T) (chk 243 (< 3 2) #F) (chk 244 (< -1 2) #T) (chk 245 (< -2 1) #T) (chk 246 (< -2 3) #T) (chk 247 (< -3 2) #T) (chk 248 (< 1 -2) #F) (chk 249 (< 2 -1) #F) (chk 250 (< 2 -3) #F) (chk 251 (< 3 -2) #F) (chk 252 (< -1 -2) #F) (chk 253 (< -2 -1) #T) (chk 254 (< -2 -3) #F) (chk 255 (< -3 -2) #T) (chk 256 (< 2 2) #F) (chk 257 (< -2 -2) #F) (chk 260 (> 1 2) #F) (chk 261 (> 2 1) #T) (chk 262 (> 2 3) #F) (chk 263 (> 3 2) #T) (chk 264 (> -1 2) #F) (chk 265 (> -2 1) #F) (chk 266 (> -2 3) #F) (chk 267 (> -3 2) #F) (chk 268 (> 1 -2) #T) (chk 269 (> 2 -1) #T) (chk 270 (> 2 -3) #T) (chk 271 (> 3 -2) #T) (chk 272 (> -1 -2) #T) (chk 273 (> -2 -1) #F) (chk 274 (> -2 -3) #T) (chk 275 (> -3 -2) #F) (chk 276 (> 2 2) #F) (chk 277 (> -2 -2) #F) (chk 280 (<= 1 2) #T) (chk 281 (<= 2 1) #F) (chk 282 (<= 2 3) #T) (chk 283 (<= 3 2) #F) (chk 284 (<= -1 2) #T) (chk 285 (<= -2 1) #T) (chk 286 (<= -2 3) #T) (chk 287 (<= -3 2) #T) (chk 288 (<= 1 -2) #F) (chk 289 (<= 2 -1) #F) (chk 290 (<= 2 -3) #F) (chk 291 (<= 3 -2) #F) (chk 292 (<= -1 -2) #F) (chk 293 (<= -2 -1) #T) (chk 294 (<= -2 -3) #F) (chk 295 (<= -3 -2) #T) (chk 296 (<= 2 2) #T) (chk 297 (<= -2 -2) #T) (chk 300 (= 1 1 1 1) #T) (chk 301 (= 2 1 1 1) #F) (chk 302 (= 1 1 1 2) #F) (chk 310 (< 1 2 3 4) #T) (chk 311 (< 2 2 3 4) #F) (chk 312 (< 2 3 3 4) #F) (chk 313 (< 2 3 4 4) #F) (chk 320 (> 4 3 2 1) #T) (chk 321 (> 4 3 2 2) #F) (chk 322 (> 4 3 3 2) #F) (chk 323 (> 4 4 3 2) #F) (chk 330 (<= 1 2 3 4) #T) (chk 331 (<= 2 2 3 4) #T) (chk 332 (<= 2 3 3 4) #T) (chk 333 (<= 2 3 4 4) #T) (chk 334 (<= 1 2 3 3 2 1) #F) (chk 335 (<= 1 2 3 3 2) #F)) scheme2c-2012.10.14/test/test07.sc000066400000000000000000000107101203736146400162340ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test07) (define-external (chk testnum result expected) testchk) (define (test07) (chk 300 (>= 1 2) #F) (chk 301 (>= 2 1) #T) (chk 302 (>= 2 3) #F) (chk 303 (>= 3 2) #T) (chk 304 (>= -1 2) #F) (chk 305 (>= -2 1) #F) (chk 306 (>= -2 3) #F) (chk 307 (>= -3 2) #F) (chk 308 (>= 1 -2) #T) (chk 309 (>= 2 -1) #T) (chk 310 (>= 2 -3) #T) (chk 311 (>= 3 -2) #T) (chk 312 (>= -1 -2) #T) (chk 313 (>= -2 -1) #F) (chk 314 (>= -2 -3) #T) (chk 315 (>= -3 -2) #F) (chk 316 (>= 2 2) #T) (chk 317 (>= -2 -2) #T) (chk 320 (max 1 2) 2) (chk 321 (max 2 1) 2) (chk 322 (max 2 3) 3) (chk 323 (max 3 2) 3) (chk 324 (max -1 2) 2) (chk 325 (max -2 1) 1) (chk 326 (max -2 3) 3) (chk 327 (max -3 2) 2) (chk 328 (max 1 -2) 1) (chk 329 (max 2 -1) 2) (chk 330 (max 2 -3) 2) (chk 331 (max 3 -2) 3) (chk 332 (max -1 -2) -1) (chk 333 (max -2 -1) -1) (chk 334 (max -2 -3) -2) (chk 335 (max -3 -2) -2) (chk 336 (max 2 2) 2) (chk 337 (max -2 -2) -2) (chk 340 (abs 1) 1) (chk 341 (abs 0) 0) (chk 342 (abs -1) 1) (chk 343 (abs -.5) .5) (chk 343 (abs 0.0) 0.0) (chk 344 (abs .5) .5) (chk 360 (min 1 2) 1) (chk 361 (min 2 1) 1) (chk 362 (min 2 3) 2) (chk 363 (min 3 2) 2) (chk 364 (min -1 2) -1) (chk 365 (min -2 1) -2) (chk 366 (min -2 3) -2) (chk 367 (min -3 2) -3) (chk 368 (min 1 -2) -2) (chk 369 (min 2 -1) -1) (chk 370 (min 2 -3) -3) (chk 371 (min 3 -2) -2) (chk 372 (min -1 -2) -2) (chk 373 (min -2 -1) -2) (chk 374 (min -2 -3) -3) (chk 375 (min -3 -2) -3) (chk 376 (min 2 2) 2) (chk 377 (min -2 -2) -2) (chk 380 (+ 1 2) 3) (chk 381 (+ 2 1) 3) (chk 382 (+ 2 3) 5) (chk 383 (+ 3 2) 5) (chk 384 (+ -1 2) 1) (chk 385 (+ -2 1) -1) (chk 386 (+ -2 3) 1) (chk 387 (+ -3 2) -1) (chk 388 (+ 1 -2) -1) (chk 389 (+ 2 -1) 1) (chk 390 (+ 2 -3) -1) (chk 391 (+ 3 -2) 1) (chk 392 (+ -1 -2) -3) (chk 393 (+ -2 -1) -3) (chk 394 (+ -2 -3) -5) (chk 395 (+ -3 -2) -5) (chk 396 (+ 2 2) 4) (chk 397 (+ -2 -2) -4) (chk 400 (* 1 2) 2) (chk 401 (* 2 1) 2) (chk 402 (* 2 3) 6) (chk 403 (* 3 2) 6) (chk 404 (* -1 2) -2) (chk 405 (* -2 1) -2) (chk 406 (* -2 3) -6) (chk 407 (* -3 2) -6) (chk 408 (* 1 -2) -2) (chk 409 (* 2 -1) -2) (chk 410 (* 2 -3) -6) (chk 411 (* 3 -2) -6) (chk 412 (* -1 -2) 2) (chk 413 (* -2 -1) 2) (chk 414 (* -2 -3) 6) (chk 415 (* -3 -2) 6) (chk 416 (* 2 2) 4) (chk 417 (* -2 -2) 4) (chk 420 (>= 4 3 2 1) #T) (chk 421 (>= 4 3 2 2) #T) (chk 422 (>= 4 3 3 2) #T) (chk 423 (>= 4 4 3 2) #T) (chk 424 (>= 1 2 3 3 2 1) #F) (chk 425 (>= 2 3 3 2 1) #F) (chk 430 (max 1) 1) (chk 431 (max 1 2 3) 3) (chk 432 (max 3 2 1) 3) (chk 433 (max 2 3 1) 3) (chk 434 (max 1 3 5 7 9 7 5 3 1) 9) (chk 440 (min 1) 1) (chk 441 (min 1 2 3) 1) (chk 442 (min 3 2 1) 1) (chk 443 (min 2 3 1) 1) (chk 444 (min 1 3 5 7 0 7 5 3 1) 0) (chk 450 (+) 0) (chk 451 (+ 1 2 3) 6) (chk 452 (+ 1 2 3 4 5 6) 21) (chk 460 (*) 1) (chk 461 (* 1 2 3) 6) (chk 462 (* 5 4 3 2) 120)) scheme2c-2012.10.14/test/test08.sc000066400000000000000000000131361203736146400162420ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test08) (define-external (chk testnum result expected) testchk) (define (test08) (chk 420 (- 1 2) -1) (chk 421 (- 2 1) 1) (chk 422 (- 2 3) -1) (chk 423 (- 3 2) 1) (chk 424 (- -1 2) -3) (chk 425 (- -2 1) -3) (chk 426 (- -2 3) -5) (chk 427 (- -3 2) -5) (chk 428 (- 1 -2) 3) (chk 429 (- 2 -1) 3) (chk 430 (- 2 -3) 5) (chk 431 (- 3 -2) 5) (chk 432 (- -1 -2) 1) (chk 433 (- -2 -1) -1) (chk 434 (- -2 -3) 1) (chk 435 (- -3 -2) -1) (chk 436 (- 2 2) 0) (chk 437 (- -2 -2) 0) (chk 440 (/ 1 2) .5) (chk 441 (/ 2 1) 2) (chk 442 (/ 2 3) .6666666666666667) (chk 443 (/ 3 2) 1.5) (chk 444 (/ -1 2) -.5) (chk 445 (/ -2 1) -2) (chk 446 (/ -2 3) -.6666666666666667) (chk 447 (/ -3 2) -1.5) (chk 448 (/ 1 -2) -.5) (chk 449 (/ 2 -1) -2) (chk 450 (/ 2 -3) -.6666666666666667) (chk 451 (/ 3 -2) -1.5) (chk 452 (/ -1 -2) .5) (chk 453 (/ -2 -1) 2) (chk 454 (/ -2 -3) .6666666666666667) (chk 455 (/ -3 -2) 1.5) (chk 456 (/ 2 2) 1) (chk 457 (/ -2 -2) 1) (chk 460 (quotient 1 2) 0) (chk 461 (quotient 2 1) 2) (chk 462 (quotient 2 3) 0) (chk 463 (quotient 3 2) 1) (chk 464 (quotient -1 2) 0) (chk 465 (quotient -2 1) -2) (chk 466 (quotient -2 3) 0) (chk 467 (quotient -3 2) -1) (chk 468 (quotient 1 -2) 0) (chk 469 (quotient 2 -1) -2) (chk 470 (quotient 2 -3) 0) (chk 471 (quotient 3 -2) -1) (chk 472 (quotient -1 -2) 0) (chk 473 (quotient -2 -1) 2) (chk 474 (quotient -2 -3) 0) (chk 475 (quotient -3 -2) 1) (chk 476 (quotient 2 2) 1) (chk 477 (quotient -2 -2) 1) (chk 480 (remainder 1 2) 1) (chk 481 (remainder 2 1) 0) (chk 482 (remainder 2 3) 2) (chk 483 (remainder 3 2) 1) (chk 484 (remainder -1 2) -1) (chk 485 (remainder -2 1) 0) (chk 486 (remainder -2 3) -2) (chk 487 (remainder -3 2) -1) (chk 488 (remainder 1 -2) 1) (chk 489 (remainder 2 -1) 0) (chk 490 (remainder 2 -3) 2) (chk 491 (remainder 3 -2) 1) (chk 492 (remainder -1 -2) -1) (chk 493 (remainder -2 -1) 0) (chk 494 (remainder -2 -3) -2) (chk 495 (remainder -3 -2) -1) (chk 496 (remainder 2 2) 0) (chk 497 (remainder -2 -2) 0) (chk 500 (+ -2 -2) -4) (chk 501 (+ -2 -1.4) -3.4) (chk 502 (+ -2 2) 0) (chk 503 (+ -2 2.4) .4) (chk 504 (+ -1.4 -2) -3.4) (chk 505 (+ -1.4 -1.4) -2.8) (chk 506 (+ -1.4 2) .6) (chk 507 (+ -1.4 2.4) 1.) (chk 508 (+ 2 -2) 0) (chk 509 (+ 2 -1.4) .6) (chk 510 (+ 2 2) 4) (chk 511 (+ 2 2.4) 4.4) (chk 512 (+ 2.4 -2) .4) (chk 513 (+ 2.4 -1.4) 1.) (chk 514 (+ 2.4 2) 4.4) (chk 515 (+ 2.4 2.4) 4.8) (chk 520 (- -2 -2) 0) (chk 521 (- -2 -1.4) -.6) (chk 522 (- -2 2) -4) (chk 523 (- -2 2.4) -4.4) (chk 524 (- -1.4 -2) .6) (chk 525 (- -1.4 -1.4) 0.) (chk 526 (- -1.4 2) -3.4) (chk 527 (- -1.4 2.4) -3.8) (chk 528 (- 2 -2) 4) (chk 529 (- 2 -1.4) 3.4) (chk 530 (- 2 2) 0) (chk 531 (- 2 2.4) -.4) (chk 532 (- 2.4 -2) 4.4) (chk 533 (- 2.4 -1.4) 3.8) (chk 534 (- 2.4 2) .4) (chk 535 (- 2.4 2.4) 0.) (chk 540 (- 1) -1) (chk 541 (- 1.3) -1.3) (chk 542 (- 3 4 5) -6) (chk 543 (- 3 4 5 -6) 0) (chk 550 (/ 3) .3333333333) (chk 551 (/ 3 4 5) .15) (chk 552 (/ 3 4 5 10) .015) (chk 580 (modulo 1 2) 1) (chk 581 (modulo 2 1) 0) (chk 582 (modulo 2 3) 2) (chk 583 (modulo 3 2) 1) (chk 584 (modulo -1 2) 1) (chk 585 (modulo -2 1) 0) (chk 586 (modulo -2 3) 1) (chk 587 (modulo -3 2) 1) (chk 588 (modulo 1 -2) -1) (chk 589 (modulo 2 -1) 0) (chk 590 (modulo 2 -3) -1) (chk 591 (modulo 3 -2) -1) (chk 592 (modulo -1 -2) -1) (chk 593 (modulo -2 -1) 0) (chk 594 (modulo -2 -3) -2) (chk 595 (modulo -3 -2) -1) (chk 596 (modulo 2 2) 0) (chk 597 (modulo -2 -2) 0) (chk 600 (modulo 13 4) 1) (chk 601 (remainder 13 4) 1) (chk 602 (modulo -13 4) 3) (chk 603 (remainder -13 4) -1) (chk 604 (modulo 13 -4) -3) (chk 605 (remainder 13 -4) 1) (chk 606 (modulo -13 -4) -1) (chk 607 (remainder -13 -4) -1) (chk 610 (gcd) 0) (chk 611 (gcd 32 -36) 4) (chk 612 (gcd -32.0 -36) 4.0) (chk 613 (gcd 16 8 4 2 1) 1) (chk 614 (gcd 16 8 4 2 0) 2) (chk 620 (lcm) 1) (chk 621 (lcm 32 -36) 288) (chk 622 (lcm 32.0 -36) 288.0) (chk 623 (lcm 3 5 7 35) 105)) scheme2c-2012.10.14/test/test09.sc000066400000000000000000000101221203736146400162330ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test09) (define-external (chk testnum result expected) testchk) (define (test09) (chk 540 (* -2 -2) 4) (chk 541 (* -2 -1.4) 2.8) (chk 542 (* -2 2) -4) (chk 543 (* -2 2.4) -4.8) (chk 544 (* -1.4 -2) 2.8) (chk 545 (* -1.4 -1.4) 1.96) (chk 546 (* -1.4 2) -2.8) (chk 547 (* -1.4 2.4) -3.36) (chk 548 (* 2 -2) -4) (chk 549 (* 2 -1.4) -2.8) (chk 550 (* 2 2) 4) (chk 551 (* 2 2.4) 4.8) (chk 552 (* 2.4 -2) -4.8) (chk 553 (* 2.4 -1.4) -3.36) (chk 554 (* 2.4 2) 4.8) (chk 555 (* 2.4 2.4) 5.76) (chk 560 (/ -2 -2) 1) (chk 561 (/ -2 -1.4) 1.428571428571429) (chk 562 (/ -2 2) -1) (chk 563 (/ -2 2.4) -.8333333333333334) (chk 564 (/ -1.4 -2) .7) (chk 565 (/ -1.4 -1.4) 1.) (chk 566 (/ -1.4 2) -.7) (chk 567 (/ -1.4 2.4) -.5833333333333334) (chk 568 (/ 2 -2) -1) (chk 569 (/ 2 -1.4) -1.428571428571429) (chk 570 (/ 2 2) 1) (chk 571 (/ 2 2.4) .8333333333333334) (chk 572 (/ 2.4 -2) -1.2) (chk 573 (/ 2.4 -1.4) -1.714285714285714) (chk 574 (/ 2.4 2) 1.2) (chk 575 (/ 2.4 2.4) 1.) (chk 580 (< -2 -2) #F) (chk 581 (< -2 -1.4) #T) (chk 582 (< -2 2) #T) (chk 583 (< -2 2.4) #T) (chk 584 (< -1.4 -2) #F) (chk 585 (< -1.4 -1.4) #F) (chk 586 (< -1.4 2) #T) (chk 587 (< -1.4 2.4) #T) (chk 588 (< 2 -2) #F) (chk 589 (< 2 -1.4) #F) (chk 590 (< 2 2) #F) (chk 591 (< 2 2.4) #T) (chk 592 (< 2.4 -2) #F) (chk 593 (< 2.4 -1.4) #F) (chk 594 (< 2.4 2) #F) (chk 595 (< 2.4 2.4) #F) (chk 600 (<= -2 -2) #T) (chk 601 (<= -2 -1.4) #T) (chk 602 (<= -2 2) #T) (chk 603 (<= -2 2.4) #T) (chk 604 (<= -1.4 -2) #F) (chk 605 (<= -1.4 -1.4) #T) (chk 606 (<= -1.4 2) #T) (chk 607 (<= -1.4 2.4) #T) (chk 608 (<= 2 -2) #F) (chk 609 (<= 2 -1.4) #F) (chk 610 (<= 2 2) #T) (chk 611 (<= 2 2.4) #T) (chk 612 (<= 2.4 -2) #F) (chk 613 (<= 2.4 -1.4) #F) (chk 614 (<= 2.4 2) #F) (chk 615 (<= 2.4 2.4) #T) (chk 620 (= -2 -2) #T) (chk 621 (= -2 -1.4) #F) (chk 622 (= -2 2) #F) (chk 623 (= -2 2.4) #F) (chk 624 (= -1.4 -2) #F) (chk 625 (= -1.4 -1.4) #T) (chk 626 (= -1.4 2) #F) (chk 627 (= -1.4 2.4) #F) (chk 628 (= 2 -2) #F) (chk 629 (= 2 -1.4) #F) (chk 630 (= 2 2) #T) (chk 631 (= 2 2.4) #F) (chk 632 (= 2.4 -2) #F) (chk 633 (= 2.4 -1.4) #F) (chk 634 (= 2.4 2) #F) (chk 635 (= 2.4 2.4) #T) (chk 640 (> -2 -2) #F) (chk 641 (> -2 -1.4) #F) (chk 642 (> -2 2) #F) (chk 643 (> -2 2.4) #F) (chk 644 (> -1.4 -2) #T) (chk 645 (> -1.4 -1.4) #F) (chk 646 (> -1.4 2) #F) (chk 647 (> -1.4 2.4) #F) (chk 648 (> 2 -2) #T) (chk 649 (> 2 -1.4) #T) (chk 650 (> 2 2) #F) (chk 651 (> 2 2.4) #F) (chk 652 (> 2.4 -2) #T) (chk 653 (> 2.4 -1.4) #T) (chk 654 (> 2.4 2) #T) (chk 655 (> 2.4 2.4) #F)) scheme2c-2012.10.14/test/test10.sc000066400000000000000000000104061203736146400162300ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test10) (define-external (chk testnum result expected) testchk) (define (test10) (chk 660 (>= -2 -2) #T) (chk 661 (>= -2 -1.4) #F) (chk 662 (>= -2 2) #F) (chk 663 (>= -2 2.4) #F) (chk 664 (>= -1.4 -2) #T) (chk 665 (>= -1.4 -1.4) #T) (chk 666 (>= -1.4 2) #F) (chk 667 (>= -1.4 2.4) #F) (chk 668 (>= 2 -2) #T) (chk 669 (>= 2 -1.4) #T) (chk 670 (>= 2 2) #T) (chk 671 (>= 2 2.4) #F) (chk 672 (>= 2.4 -2) #T) (chk 673 (>= 2.4 -1.4) #T) (chk 674 (>= 2.4 2) #T) (chk 675 (>= 2.4 2.4) #T) (chk 680 (MIN -2 -2) -2) (chk 681 (MIN -2 -1.4) -2) (chk 682 (MIN -2 2) -2) (chk 683 (MIN -2 2.4) -2) (chk 684 (MIN -1.4 -2) -2) (chk 685 (MIN -1.4 -1.4) -1.4) (chk 686 (MIN -1.4 2) -1.4) (chk 687 (MIN -1.4 2.4) -1.4) (chk 688 (MIN 2 -2) -2) (chk 689 (MIN 2 -1.4) -1.4) (chk 690 (MIN 2 2) 2) (chk 691 (MIN 2 2.4) 2) (chk 692 (MIN 2.4 -2) -2) (chk 693 (MIN 2.4 -1.4) -1.4) (chk 694 (MIN 2.4 2) 2) (chk 695 (MIN 2.4 2.4) 2.4) (chk 700 (MAX -2 -2) -2) (chk 701 (MAX -2 -1.4) -1.4) (chk 702 (MAX -2 2) 2) (chk 703 (MAX -2 2.4) 2.4) (chk 704 (MAX -1.4 -2) -1.4) (chk 705 (MAX -1.4 -1.4) -1.4) (chk 706 (MAX -1.4 2) 2) (chk 707 (MAX -1.4 2.4) 2.4) (chk 708 (MAX 2 -2) 2) (chk 709 (MAX 2 -1.4) 2) (chk 710 (MAX 2 2) 2) (chk 711 (MAX 2 2.4) 2.4) (chk 712 (MAX 2.4 -2) 2.4) (chk 713 (MAX 2.4 -1.4) 2.4) (chk 714 (MAX 2.4 2) 2.4) (chk 715 (MAX 2.4 2.4) 2.4) (chk 720 (POSITIVE? -2) #F) (chk 721 (POSITIVE? -1.6) #F) (chk 722 (POSITIVE? -1.4) #F) (chk 723 (POSITIVE? 0) #F) (chk 724 (POSITIVE? 0.) #F) (chk 725 (POSITIVE? 1.6) #T) (chk 726 (POSITIVE? 2) #T) (chk 727 (POSITIVE? 2.4) #T) (chk 730 (ZERO? -2) #F) (chk 731 (ZERO? -1.6) #F) (chk 732 (ZERO? -1.4) #F) (chk 733 (ZERO? 0) #T) (chk 734 (ZERO? 0.) #T) (chk 735 (ZERO? 1.6) #F) (chk 736 (ZERO? 2) #F) (chk 737 (ZERO? 2.4) #F) (chk 740 (NEGATIVE? -2) #T) (chk 741 (NEGATIVE? -1.6) #T) (chk 742 (NEGATIVE? -1.4) #T) (chk 743 (NEGATIVE? 0) #F) (chk 744 (NEGATIVE? 0.) #F) (chk 745 (NEGATIVE? 1.6) #F) (chk 746 (NEGATIVE? 2) #F) (chk 747 (NEGATIVE? 2.4) #F) (chk 750 (ABS -2) 2) (chk 751 (ABS -1.6) 1.6) (chk 752 (ABS -1.4) 1.4) (chk 753 (ABS 0) 0) (chk 754 (ABS 0.) 0.) (chk 755 (ABS 1.6) 1.6) (chk 756 (ABS 2) 2) (chk 757 (ABS 2.4) 2.4) (if (member (list-ref (implementation-information) 3) '("VAX" "R2000" "SPARC")) (chk 758 (ABS -536870912) 536870912.)) (chk 760 (FLOOR -2) -2) (chk 761 (FLOOR -1.6) -2.) (chk 762 (FLOOR -1.4) -2.) (chk 763 (FLOOR 0) 0) (chk 764 (FLOOR 0.) 0.) (chk 765 (FLOOR 1.6) 1.) (chk 766 (FLOOR 2) 2) (chk 767 (FLOOR 2.4) 2.) (chk 770 (CEILING -2) -2) (chk 771 (CEILING -1.6) -1.) (chk 772 (CEILING -1.4) -1.) (chk 773 (CEILING 0) 0) (chk 774 (CEILING 0.) 0.) (chk 775 (CEILING 1.6) 2.) (chk 776 (CEILING 2) 2) (chk 777 (CEILING 2.4) 3.)) scheme2c-2012.10.14/test/test11.sc000066400000000000000000000160701203736146400162340ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test11) (define-external (chk testnum result expected) testchk) (define minint (string->number "-536870912")) (define zero 0) (define zeropt 0.0) (define (test11) (let ((arch (list-ref (implementation-information) 3))) (when (member arch '("VAX" "R2000" "SPARC")) (chk 01 (+ 268435455 268435456) 536870911) (chk 02 (+ 536870910 1) 536870911) (chk 03 (+ 536870909 2) 536870911) (chk 04 (+ 3 536870908) 536870911) (chk 05 (+ 536870907 4) 536870911) (chk 06 (+ 2 536870910) 536870912.) (chk 07 (+ 536870909 3) 536870912.) (chk 08 (+ 536870908 4) 536870912.) (chk 09 (+ 300000000 300000000) 600000000.) (chk 10 (+ 500000000 522334455) 1022334455.) (chk 11 (+ -500000000 522334455) 22334455.) (chk 12 (+ -536543210 -522334455) -1058877665.) (chk 13 (+ -1 -536870911) minint) (chk 14 (+ 268435456 268435456) 536870912.) (chk 15 (+ 0 0.) 0.) (chk 16 (+ 164. 78) 242.) (chk 17 (- 0 -536870911) 536870911) (chk 18 (- -300000000 300000000) -600000000.) (chk 19 (- -500000000 36870912) minint) (chk 20 (- 1 -536870911) 536870912.) (chk 21 (- -268435455 268435456) -536870911) (chk 22 (- -536870911 1) minint) (chk 23 (- -500000001 1) -500000002) (chk 24 (- 420000000 520000000) -100000000) (chk 25 (- -230000000 450000000) -680000000.) (chk 26 (- 11 60000000011.) -60000000000.) (chk 27 (- 536870911 643) 536870268) (chk 28 (- -536870911 643) -536871554.) (chk 29 (- 448000000 448000000) 0) (chk 30 (- 448000000. 448000000) 0.) (chk 31 (* -23000 -23000) 529000000) (chk 32 (* 59652323 9) 536870907) (chk 33 (* 8 100000000) 800000000.) (chk 34 (* 43210 12345) 533427450) (chk 35 (* 3000000 3000000) 9000000000000.) (chk 36 (* 2 268435456) 536870912.) (chk 37 (* -268435456 2) minint) (chk 38 (* -536870911 -1) 536870911) (chk 38 (* 4500 -60000) -270000000) (when (equal? arch "VAX") (chk 40 (catch-error (lambda () (/ 233545 zero))) "***** ????? Divide by zero") (chk 41 (catch-error (lambda ()(quotient 233 zero))) "***** ????? Divide by zero") (chk 42 (catch-error (lambda ()(/ 1. zero))) "***** ????? Divide by zero") (chk 43 (catch-error (lambda () (quotient 345 zeropt))) "***** ????? Divide by zero") (chk 44 (catch-error (lambda ()(* -02.9e-38 .1))) '(0.0)) (chk 45 (catch-error (lambda ()(* 1.27e38 10))) "***** ????? Overflow") (chk 46 (catch-error (lambda ()(* 6.e37 3))) "***** ????? Overflow")) (when (equal? arch "R2000") (chk 50 (catch-error (lambda () (/ 233545 zero))) "***** ????? Divide by zero") (chk 51 (catch-error (lambda () (quotient 233 zero))) "***** ????? Divide by zero") (chk 52 (number? (/ 1. zero)) #t) (chk 53 (number? (quotient 345 zeropt)) #t) (chk 54 (number? (* 1.e99 2.e99)) #t) (chk 55 (* 1 3.e99) 3.e99)) (chk 60 (- -536870912) 536870912.))) (chk 780 (TRUNCATE -2) -2) (chk 781 (TRUNCATE -1.6) -1.) (chk 782 (TRUNCATE -1.4) -1.) (chk 783 (TRUNCATE 0) 0) (chk 784 (TRUNCATE 0.) 0.) (chk 785 (TRUNCATE 1.6) 1.) (chk 786 (TRUNCATE 2) 2) (chk 787 (TRUNCATE 2.4) 2.) (chk 790 (ROUND -2) -2) (chk 791 (ROUND -1.6) -2.) (chk 792 (ROUND -1.4) -1.) (chk 793 (ROUND 0) 0) (chk 794 (ROUND 0.) 0.) (chk 795 (ROUND 1.6) 2.) (chk 796 (ROUND 2) 2) (chk 797 (ROUND 2.4) 2.) (chk 801 (exp 0) 1.) (chk 802 (exp 1) 2.7182818) (chk 811 (log (exp 1)) 1.0) (chk 821 (sin 0) 0.0) (chk 822 (sin 1) .841471) (chk 823 (+ (* (sin 1) (sin 1)) (* (cos 1) (cos 1))) 1.0) (chk 824 (/ (sin 1) (cos 1)) (tan 1)) (chk 830 (asin (sin 1)) 1.0) (chk 831 (acos (cos 1)) 1.0) (chk 832 (atan (tan 1)) 1.0) (chk 833 (atan 1 1) (atan 1)) (chk 840 (sqrt 25) 5) (chk 841 (sqrt (expt 2 40)) (exact->inexact (expt 2 20))) (chk 842 (exact? (expt 2 20)) #t) (chk 843 (expt 0 0) 1.0) (chk 850 (exact->inexact 23.0) 23.0) (chk 851 (exact->inexact 23) 23.0) (chk 860 (inexact->exact 23) 23) (chk 861 (inexact->exact 23.3) 23) (chk 865 (number->string -23 '(int)) "-23") (chk 866 (number->string -1.3333 '(int)) "-1") (chk 867 (number->string 2.7 '(int)) "3") (chk 868 (number->string 23 '(int)) "23") (chk 869 (number->string -23 '(fix 3)) "-23.000") (chk 870 (number->string -1.3333 '(fix 3)) "-1.333") (chk 871 (number->string 2.7 '(fix 3)) "2.700") (chk 872 (number->string 23 '(fix 3)) "23.000") (let ((x (number->string -23 '(sci 2)))) (if (= (string-length x) 9) (begin (chk 873 (number->string -23 '(sci 2)) "-2.3e+001") (chk 874 (number->string -1.3333 '(sci 2)) "-1.3e+000") (chk 875 (number->string 2.7 '(sci 2)) "2.7e+000") (chk 876 (number->string 23 '(sci 2)) "2.3e+001")) (begin (chk 873 (number->string -23 '(sci 2)) "-2.3e+01") (chk 874 (number->string -1.3333 '(sci 2)) "-1.3e+00") (chk 875 (number->string 2.7 '(sci 2)) "2.7e+00") (chk 876 (number->string 23 '(sci 2)) "2.3e+01")))) (chk 880 (number->string 23) "23") (chk 881 (number->string 23 2) "10111") (chk 882 (number->string 23 8) "27") (chk 883 (number->string 23 10) "23") (chk 884 (number->string 23 16) "17") (chk 885 (number->string -23.32) "-23.32") (chk 890 (string->number "") #f) (chk 891 (string->number "11") 11) (chk 892 (string->number "11" 2) 3) (chk 893 (string->number "11" 8) 9) (chk 894 (string->number "11" 10) 11) (chk 895 (string->number "11" 16) 17) (chk 896 (string->number "#b11" 10) 3) (chk 897 (string->number "-#b11" 10) -3)) scheme2c-2012.10.14/test/test12.sc000066400000000000000000000132521203736146400162340ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test12) (define-external (chk testnum result expected) testchk) (define (test12) ;;; 6.6 Characters (chk 1 (char? '()) #f) (chk 2 (char? '#()) #f) (chk 3 (char? '(1 2)) #f) (chk 4 (char? '#(1 2)) #f) (chk 5 (char? 'x) #f) (chk 6 (char? "x") #f) (chk 7 (char? #\a) #t) (chk 8 (char? (lambda (x) x)) #f) (chk 9 (char? #f) #f) (chk 10 (char? #t) #f) (chk 11 (char? -1) #f) (chk 12 (char? 0) #f) (chk 13 (char? 1) #f) (chk 14 (char? -2.5) #f) (chk 15 (char? 0.0) #f) (chk 16 (char? 1.5) #f) (chk 20 (char=? #\a #\A) #f) (chk 21 (char=? #\2 #\4) #f) (chk 22 (char=? #\a #\b) #f) (chk 23 (char=? #\b #\a) #f) (chk 24 (char=? #\c #\c) #t) (chk 30 (char? #\a #\A) #t) (chk 41 (char>? #\2 #\4) #f) (chk 42 (char>? #\a #\b) #f) (chk 43 (char>? #\b #\a) #t) (chk 44 (char>? #\c #\c) #f) (chk 50 (char<=? #\a #\A) #f) (chk 51 (char<=? #\2 #\4) #t) (chk 52 (char<=? #\a #\b) #t) (chk 53 (char<=? #\b #\a) #f) (chk 54 (char<=? #\c #\c) #t) (chk 60 (char>=? #\a #\A) #t) (chk 61 (char>=? #\2 #\4) #f) (chk 62 (char>=? #\a #\b) #f) (chk 63 (char>=? #\b #\a) #t) (chk 64 (char>=? #\c #\c) #t) (chk 70 (char-alphabetic? #\.) #f) (chk 71 (char-alphabetic? #\3) #f) (chk 72 (char-alphabetic? #\a) #t) (chk 73 (char-alphabetic? #\A) #t) (chk 74 (char-alphabetic? #\tab) #f) (chk 75 (char-alphabetic? #\space) #f) (chk 76 (char-alphabetic? #\newline) #f) (chk 80 (char-numeric? #\.) #f) (chk 81 (char-numeric? #\3) #t) (chk 82 (char-numeric? #\a) #f) (chk 83 (char-numeric? #\A) #f) (chk 84 (char-numeric? #\tab) #f) (chk 85 (char-numeric? #\space) #f) (chk 86 (char-numeric? #\newline) #f) (chk 90 (char-whitespace? #\.) #f) (chk 91 (char-whitespace? #\3) #f) (chk 92 (char-whitespace? #\a) #f) (chk 93 (char-whitespace? #\A) #f) (chk 94 (char-whitespace? #\tab) #t) (chk 95 (char-whitespace? #\space) #t) (chk 96 (char-whitespace? #\newline) #t) (chk 100 (char-upper-case? #\a) #f) (chk 101 (char-upper-case? #\A) #t) (chk 102 (char-upper-case? #\z) #f) (chk 103 (char-upper-case? #\Z) #t) (chk 110 (char-lower-case? #\a) #t) (chk 111 (char-lower-case? #\A) #f) (chk 112 (char-lower-case? #\z) #t) (chk 113 (char-lower-case? #\Z) #f) (chk 120 (char-upcase #\a) #\A) (chk 121 (char-upcase #\A) #\A) (chk 122 (char-upcase #\z) #\Z) (chk 123 (char-upcase #\Z) #\Z) (chk 124 (char-upcase #\space) #\space) (chk 130 (char-downcase #\a) #\a) (chk 131 (char-downcase #\A) #\a) (chk 132 (char-downcase #\z) #\z) (chk 133 (char-downcase #\Z) #\z) (chk 134 (char-downcase #\space) #\space) (chk 140 (char->integer #\space) 32) (chk 141 (char->integer #\A) 65) (chk 150 (integer->char 32) #\space) (chk 151 (integer->char 65) #\A) (chk 160 (char-ci=? #\a #\A) #t) (chk 161 (char-ci=? #\2 #\4) #f) (chk 162 (char-ci=? #\a #\b) #f) (chk 163 (char-ci=? #\b #\a) #f) (chk 164 (char-ci=? #\c #\c) #t) (chk 165 (char-ci=? #\C #\c) #t) (chk 170 (char-ci? #\a #\A) #f) (chk 181 (char-ci>? #\2 #\4) #f) (chk 182 (char-ci>? #\a #\b) #f) (chk 183 (char-ci>? #\b #\a) #t) (chk 184 (char-ci>? #\B #\a) #t) (chk 185 (char-ci>? #\b #\A) #t) (chk 186 (char-ci>? #\a #\B) #f) (chk 187 (char-ci>? #\c #\c) #f) (chk 190 (char-ci<=? #\a #\A) #t) (chk 191 (char-ci<=? #\2 #\4) #t) (chk 192 (char-ci<=? #\a #\b) #t) (chk 193 (char-ci<=? #\b #\a) #f) (chk 194 (char-ci<=? #\c #\c) #t) (chk 195 (char-ci<=? #\c #\D) #t) (chk 196 (char-ci<=? #\C #\a) #f) (chk 197 (char-ci<=? #\a #\1) #f) (chk 200 (char-ci>=? #\a #\A) #t) (chk 201 (char-ci>=? #\2 #\4) #f) (chk 202 (char-ci>=? #\a #\b) #f) (chk 203 (char-ci>=? #\b #\a) #t) (chk 204 (char-ci>=? #\C #\c) #t) (chk 205 (char-ci>=? #\c #\C) #t) (chk 206 (char-ci>=? #\C #\C) #t) (chk 207 (char-ci>=? #\c #\D) #f)) scheme2c-2012.10.14/test/test13.sc000066400000000000000000000143631203736146400162410ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test13) (define-external (chk testnum result expected) testchk) (define (test13) ;;; 6.7 Strings (chk 1 (string? '()) #f) (chk 2 (string? '#()) #f) (chk 3 (string? '(1 2)) #f) (chk 4 (string? '#(1 2)) #f) (chk 5 (string? 'x) #f) (chk 6 (string? "x") #t) (chk 7 (string? '#\a) #f) (chk 8 (string? (lambda (x) x)) #f) (chk 9 (string? #f) #f) (chk 10 (string? #t) #f) (chk 11 (string? -1) #f) (chk 12 (string? 0) #f) (chk 13 (string? 1) #f) (chk 14 (string? -2.5) #f) (chk 15 (string? 0.0) #f) (chk 16 (string? 1.5) #f) (chk 17 (string) "") (chk 18 (string #\a #\b #\c) "abc") (chk 20 (string-length (make-string 20)) 20) (chk 21 (make-string 20 #\$) "$$$$$$$$$$$$$$$$$$$$") (chk 22 (eqv? (make-string 0) "") #t) (chk 30 (string-length "") 0) (chk 31 (string-length "This string is 17") 17) (chk 32 (string-length (make-string 47)) 47) (chk 40 (string-ref "s" 0) #\s) (chk 41 (string-ref "same" 2) #\m) (chk 42 (string-ref "same" 3) #\e) (let* ((string "This is a sample") (xstring (string-copy string))) (chk 50 (string-set! xstring 4 #\*) #\*) (chk 51 (string-ref xstring 4) #\*) (chk 52 (string-set! xstring 7 #\*) #\*) (chk 53 (string-ref xstring 7) #\*) (chk 54 (string-set! xstring 9 #\*) #\*) (chk 55 (string-ref xstring 9) #\*) (chk 56 string "This is a sample") (chk 57 xstring "This*is*a*sample") (string-set! xstring 3 (integer->char 204)) (chk 58 (char->integer (string-ref xstring 3)) 204)) (chk 60 (string=? "" "zot") #f) (chk 61 (string=? "zot" "") #f) (chk 62 (string=? "a" "abc") #f) (chk 63 (string=? "Apple Core" "Apple") #f) (chk 64 (string=? "Zort 23" "Zort 23") #t) (chk 70 (string? "" "zot") #f) (chk 81 (string>? "zot" "") #t) (chk 82 (string>? "a" "abc") #f) (chk 83 (string>? "Apple Core" "Apple") #t) (chk 84 (string>? "Zort 23" "Zort 23") #f) (chk 90 (string<=? "" "zot") #t) (chk 91 (string<=? "zot" "") #f) (chk 92 (string<=? "a" "abc") #t) (chk 93 (string<=? "Apple Core" "Apple") #f) (chk 94 (string<=? "Zort 23" "Zort 23") #t) (chk 100 (string>=? "" "zot") #f) (chk 101 (string>=? "zot" "") #t) (chk 102 (string>=? "a" "abc") #f) (chk 103 (string>=? "Apple Core" "Apple") #t) (chk 104 (string>=? "Zort 23" "Zort 23") #t) (let ((xstring "This is a sample string")) (chk 110 (substring xstring 0 (string-length xstring)) (string-copy xstring)) (chk 111 (substring xstring 0 (string-length xstring)) xstring) (chk 112 (eq? (substring xstring 0 (string-length xstring)) xstring) #f) (chk 113 (substring xstring 4 8) " is ") (chk 114 (substring xstring 7 10) " a ")) (chk 120 (string-append "" "zot") "zot") (chk 121 (string-append "zot" "") "zot") (chk 122 (string-append "a" "abc") "aabc") (chk 123 (string-append "Apple Core" "Apple") "Apple CoreApple") (chk 124 (string-append "Zort 23" "Zort 23") "Zort 23Zort 23") (chk 130 (string->list "") '()) (chk 131 (string->list "a") '(#\a)) (chk 132 (string->list "This is a sample") '(#\T #\h #\i #\s #\space #\i #\s #\space #\a #\space #\s #\a #\m #\p #\l #\e)) (chk 140 (list->string '()) "") (chk 141 (list->string '(#\a)) "a") (chk 142 (list->string '(#\T #\h #\i #\s)) "This") (chk 150 (string-fill! (make-string 10) #\<) "<<<<<<<<<<") (chk 151 (string-fill! "" #\Z) "") (chk 160 (string-ci=? "" "zot") #f) (chk 161 (string-ci=? "zot" "") #f) (chk 162 (string-ci=? "a" "aBc") #f) (chk 163 (string-ci=? "Apple Core" "Apple") #f) (chk 164 (string-ci=? "Zort 23" "Zort 23") #t) (chk 165 (string-ci=? "Able was I ere I saw Elba" "able was i ere i saw elba") #t) (chk 170 (string-ci? "" "zot") #f) (chk 181 (string-ci>? "zot" "") #t) (chk 182 (string-ci>? "A" "abc") #f) (chk 183 (string-ci>? "APPLE Core" "apple") #t) (chk 184 (string-ci>? "Zort 23" "Zort 23") #f) (chk 185 (string-ci>? "zoRt 23" "ZoRt 22") #t) (chk 190 (string-ci<=? "" "zot") #t) (chk 191 (string-ci<=? "zot" "") #f) (chk 192 (string-ci<=? "a" "abc") #t) (chk 193 (string-ci<=? "Apple Core" "Apple") #f) (chk 194 (string-ci<=? "Zort 23" "Zort 23") #t) (chk 195 (string-ci<=? "zoRt 23" "ZoRt 24") #t) (chk 200 (string-ci>=? "" "zot") #f) (chk 201 (string-ci>=? "zot" "") #t) (chk 202 (string-ci>=? "a" "abc") #f) (chk 203 (string-ci>=? "Apple Core" "Apple") #t) (chk 204 (string-ci>=? "Zort 23" "Zort 23") #t) (chk 205 (string-ci>=? "zoRt 23" "ZoRt 22") #t)) scheme2c-2012.10.14/test/test14.sc000066400000000000000000000122011203736146400162270ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test14) (define-external (chk testnum result expected) testchk) (define (RR s) (set! %record-prefix-char #\~) (set! %record-read (lambda (port) (list->%record (read port)))) (read (open-input-string s))) (define (test14) ;;; 6.8 Vectors (chk 01 (vector? '()) #f) (chk 02 (vector? '#()) #t) (chk 03 (vector? '(1 2)) #f) (chk 04 (vector? '#(1 2)) #t) (chk 05 (vector? 'x) #f) (chk 06 (vector? "x") #f) (chk 07 (vector? '#\a) #f) (chk 08 (vector? (lambda (x) x)) #f) (chk 09 (vector? #f) #f) (chk 10 (vector? #t) #f) (chk 11 (vector? -1) #f) (chk 12 (vector? 0) #f) (chk 13 (vector? 1) #f) (chk 14 (vector? -2.5) #f) (chk 15 (vector? 0.0) #f) (chk 16 (vector? 1.5) #f) (chk 20 (vector-length (make-vector 20)) 20) (chk 21 (eq? (make-vector 0) '#()) #t) (chk 22 (make-vector 5 (make-vector 1 1)) '#(#(1) #(1) #(1) #(1) #(1))) (chk 30 (vector) '#()) (chk 31 (vector 0) '#(0)) (chk 32 (vector 0 1) '#(0 1)) (chk 31 (vector 0 1 2 3 4) '#(0 1 2 3 4)) (chk 40 (vector-length '#()) 0) (chk 41 (vector-length '#(1 2 3)) 3) (chk 42 (vector-length (make-vector 1000)) 1000) (chk 50 (vector-ref '#(zero one two three) 0) 'zero) (chk 51 (vector-ref '#(zero one two three) 1) 'one) (chk 52 (vector-ref '#(zero one two three) 3) 'three) (let ((xvector (make-vector 4))) (vector-set! xvector 0 'zero) (vector-set! xvector 1 'one) (vector-set! xvector 2 'two) (vector-set! xvector 3 'three) (chk 60 xvector '#(zero one two three))) (chk 70 (vector->list '#()) '()) (chk 71 (vector->list '#(zero one two three)) '(zero one two three)) (chk 80 (list->vector '()) '#()) (chk 81 (list->vector '(1)) '#(1)) (chk 82 (list->vector '(1 2 3 4)) '#(1 2 3 4)) (chk 90 (vector-fill! (make-vector 10) #t) '#(#t #t #t #t #t #t #t #t #t #t)) (chk 91 (vector-fill! '#() 1) '#()) ;;; *.* Records (chk 101 (%record? '()) #f) (chk 102 (%record? '#()) #f) (chk 103 (%record? '(1 2)) #f) (chk 104 (%record? '#(1 2)) #f) (chk 105 (%record? 'x) #f) (chk 106 (%record? "x") #f) (chk 107 (%record? '#\a) #f) (chk 108 (%record? (lambda (x) x)) #f) (chk 109 (%record? #f) #f) (chk 110 (%record? #t) #f) (chk 111 (%record? -1) #f) (chk 112 (%record? 0) #f) (chk 113 (%record? 1) #f) (chk 114 (%record? -2.5) #f) (chk 115 (%record? 0.0) #f) (chk 116 (%record? 1.5) #f) (chk 117 (%record? (make-%record 1)) #t) (chk 120 (%record-length (make-%record 20)) 20) (chk 121 (eq? (make-%record 0) (make-%record 0)) #f) (chk 122 (eq? (make-%record 0) (make-%record 0)) #f) (chk 123 (equal? (make-%record 0) (make-%record 0)) #f) (chk 124 (make-%record 0) (make-%record 0)) (chk 125 (make-%record 5 #t) (rr "#~(#t #t #t #t #t)")) (chk 130 (%record) (rr "#~()")) (chk 131 (%record 0) (rr "#~(0)")) (chk 132 (%record 0 1) (rr "#~(0 1)")) (chk 131 (%record 0 1 2 3 4) (rr "#~(0 1 2 3 4)")) (chk 140 (%record-length (rr "#~()")) 0) (chk 141 (%record-length (rr "#~(1 2 3)")) 3) (chk 142 (%record-length (make-%record 1000)) 1000) (chk 150 (%record-ref (rr "#~(zero one two three)") 0) 'zero) (chk 151 (%record-ref (rr "#~(zero one two three)") 1) 'one) (chk 152 (%record-ref (rr "#~(zero one two three)") 3) 'three) (let ((x%record (make-%record 4))) (%record-set! x%record 0 'zero) (%record-set! x%record 1 'one) (%record-set! x%record 2 'two) (%record-set! x%record 3 'three) (chk 160 x%record (rr "#~(zero one two three)"))) (chk 170 (%record->list (rr "#~()")) '()) (chk 171 (%record->list (rr "#~(zero one two three)")) '(zero one two three)) (chk 180 (list->%record '()) (rr "#~()")) (chk 181 (list->%record '(1)) (rr "#~(1)")) (chk 182 (list->%record '(1 2 3 4)) (rr "#~(1 2 3 4)"))) scheme2c-2012.10.14/test/test15.sc000066400000000000000000000134031203736146400162350ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test15) (define-external (chk testnum result expected) testchk) (define unknown #t) (define (test15) ;;; 6.9 Control features (chk 01 (procedure? '()) #f) (chk 02 (procedure? '#()) #f) (chk 03 (procedure? '(1 2)) #f) (chk 04 (procedure? '#(1 2)) #f) (chk 05 (procedure? 'x) #f) (chk 06 (procedure? "x") #f) (chk 07 (procedure? '#\a) #f) (chk 08 (procedure? (lambda (x) x)) #t) (chk 09 (procedure? #f) #f) (chk 10 (procedure? #f) #f) (chk 11 (procedure? -1) #f) (chk 12 (procedure? 0) #f) (chk 13 (procedure? 1) #f) (chk 14 (procedure? -2.5) #f) (chk 15 (procedure? 0.0) #f) (chk 16 (procedure? 1.5) #f) (chk 20 (apply (lambda () 1) '()) 1) (chk 21 (apply (lambda (x) x) '(1)) 1) (chk 22 (apply (lambda (x y) (+ x y)) '(1 2)) 3) (chk 23 (apply (lambda x x) '(1 2 3)) '(1 2 3)) (chk 24 (apply (lambda (x . y) (cons x y)) '(1 2 3 4)) '(1 2 3 4)) (chk 25 (apply + '(1 2 3 4)) 10) (chk 26 (apply + 1 2 3 4 '()) 10) (chk 27 (apply + 1 2 '(3 4)) 10) (let ((x '(a b c))) (chk 28 (eq? (apply list x) x) #f)) (chk 30 (map (lambda (x) (+ x 1)) '(0 1 2 3 4 5 6 7 8 9)) '(1 2 3 4 5 6 7 8 9 10)) (chk 31 (map + '(1 2 3 4 5) '(2 4 6 8 10)) '(3 6 9 12 15)) (chk 32 (map + '(1 2 3 4 5) '(10 20 30 40 50) '(100 200 300 400 500)) '(111 222 333 444 555)) (chk 33 (map + '(1 2 3 4 5) '(10 20 30 40 50) '(100 200 300 400 500) '(1000 2000 3000 4000 5000)) '(1111 2222 3333 4444 5555)) (let ((x (make-vector 10))) (for-each (lambda (i) (vector-set! x i (- 0 i))) '(0 1 2 3 4 5 6 7 8 9)) (chk 40 x '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)) (for-each (lambda (i j) (vector-set! x i (+ i j))) '(0 1 2 3 4 5 6 7 8 9) '(0 10 20 30 40 50 60 70 80 90)) (chk 41 x '#(0 11 22 33 44 55 66 77 88 99)) (for-each (lambda (i j k) (vector-set! x i (+ i j k))) '(0 1 2 3 4 5 6 7 8 9) '(0 10 20 30 40 50 60 70 80 90) '(0 100 200 300 400 500 600 700 800 900)) (chk 42 x '#(0 111 222 333 444 555 666 777 888 999)) (for-each (lambda (i j k l) (vector-set! x i (+ i j k l))) '(0 1 2 3 4 5 6 7 8 9) '(0 10 20 30 40 50 60 70 80 90) '(0 100 200 300 400 500 600 700 800 900) '(0 1000 2000 3000 4000 5000 6000 7000 8000 9000)) (chk 43 x '#(0 1111 2222 3333 4444 5555 6666 7777 8888 9999))) (chk 50 (with-output-to-string cwcc1) "12") (chk 51 (with-output-to-string cwcc2) "12") (chk 52 (with-output-to-string cwcc3) "hi") (chk 53 (with-output-to-string cwcc4) "HEY!") (chk 54 (with-output-to-string mondo-bizarro) "11213") (set! unknown (lambda () 'zero-args)) (chk 60 (unknown) 'zero-args) (set! unknown (lambda x x)) (chk 61 (unknown) '()) (chk 62 (unknown 1) '(1)) (chk 63 (unknown 1 2) '(1 2)) (chk 64 (unknown 1 2 3 4 5 6) '(1 2 3 4 5 6)) (set! unknown (lambda (x) x)) (chk 65 (unknown 23) 23) (set! unknown (lambda (x . y) (list x y))) (chk 66 (unknown 1) '(1 ())) (chk 67 (unknown 1 2) '(1 (2))) (chk 68 (unknown 1 2 3 4 5) '(1 (2 3 4 5))) (set! unknown (lambda (x y z) (list x y z))) (chk 69 (unknown 20 30 40) '(20 30 40)) (chk 70 (force (delay (string-length "abc"))) 3) (chk 71 (procedure? (delay (string-length "abc"))) #t) (let* ((y 0) (x (delay (begin (set! y (+ 1 y)) y)))) (chk 72 (force x) 1) (chk 73 (force x) 1))) (define (cwcc1) ;;; Normal return. (display (call-with-current-continuation (lambda (x) (display 1) 2)))) (define (cwcc2) ;;; Return value via the continuation. (display (call-with-current-continuation (lambda (x) (display 1) (x 2) (display 3))))) (define (cwcc3) ;;; Call the returned continuation. (Dybvig, pg 80) (display (let ((x (call-with-current-continuation (lambda (k) k)))) (x (lambda (ignore) "hi"))))) (define (cwcc4) ;;; Another trick (Dybvig, pg 81) (display (((call-with-current-continuation (lambda (k) k)) (lambda (x) x)) 'hey!))) (define (mondo-bizarro) ;;; Finally, a classic (Lisp Pointers I-2.27) (let ((k (call-with-current-continuation (lambda (c) c)))) (display 1) (call-with-current-continuation (lambda (c) (k c))) (display 2) (call-with-current-continuation (lambda (c) (k c))) (display 3))) (define (WITH-OUTPUT-TO-STRING func) (let ((port (open-output-string)) (save-current-output-port (current-output-port))) (set! scrt5_current-output-port-value port) (func) (set! scrt5_current-output-port-value save-current-output-port) (get-output-string port))) scheme2c-2012.10.14/test/test16.sc000066400000000000000000000116731203736146400162450ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test16) (define-external (chk testnum result expected) testchk) (define BIGENDIAN (not (eq? (c-byte-ref "A" (- 1 c-sizeof-tscp)) 1))) (define LSB-SHORT (if bigendian (/ c-sizeof-int 2) 0)) ; byte offset to lsb short (define MSB-SHORT (if bigendian 0 (/ c-sizeof-int 2))) ; byte offset to msb short (define (test16) ;;; *.* Extensions for accessing C structures. Byte order is computed (let ((s (make-string 10 #\*))) (c-byte-set! s 0 (char->integer #\S)) (c-byte-set! s 1 (char->integer #\c)) (c-byte-set! s 2 (char->integer #\h)) (c-byte-set! s 3 (char->integer #\e)) (c-byte-set! s 4 (char->integer #\m)) (c-byte-set! s 5 (char->integer #\e)) (c-byte-set! s 6 0.0) (c-byte-set! s 7 -1) (c-byte-set! s 8 255) (chk 1 (c-string->string s) "Scheme") (chk 2 (integer->char (c-byte-ref s 0)) #\S) (chk 3 (integer->char (c-byte-ref s 2)) #\h) (chk 4 (c-byte-ref s 7) 255) (chk 5 (c-byte-ref s 8) 255)) (let ((s (make-string 10 #\*))) (cond ((and (= c-sizeof-int 4) (= c-sizeof-short 2)) (c-int-set! s 0 #xffff) (chk 10 (c-int-ref s 0) #xffff) (chk 11 (c-shortunsigned-ref s lsb-short) #xffff) (chk 12 (c-shortunsigned-ref s msb-short) 0) (chk 13 (c-shortint-ref s lsb-short) -1) (chk 14 (c-shortint-ref s msb-short) 0) (c-shortint-set! s msb-short -1) (chk 15 (c-int-ref s 0) -1) (c-shortunsigned-set! s lsb-short #xfffe) (chk 16 (c-int-ref s 0) -2)) (else (format #t "Tests 10-16 omitted~%")))) (let ((s (make-string 20 #\*))) (cond ((and (= c-sizeof-int 4) (= c-sizeof-tscp 4)) (c-unsigned-set! s 0 (- (expt 2 32) 1)) (c-int-set! s 4 4) (chk 20 (c-int-ref s 0) -1) (chk 21 (c-unsigned-ref s 0) (- (expt 2 32) 1)) (chk 22 (c-int-ref s 4) 4) (chk 23 (c-unsigned-ref s 4) 4) (chk 24 (c-tscp-ref s 4) 1) (c-tscp-set! s 0 -1) (chk 25 (c-int-ref s 0) -4)) ((and (= c-sizeof-int 4) (= c-sizeof-tscp 8)) (c-unsigned-set! s 0 (- (expt 2 32) 1)) (c-int-set! s 4 4) (chk 20 (c-int-ref s 0) -1) (chk 21 (c-unsigned-ref s 0) (- (expt 2 32) 1)) (chk 22 (c-int-ref s 4) 4) (chk 23 (c-unsigned-ref s 4) 4) (c-int-set! s 8 -4) (c-unsigned-set! s 12 (- (expt 2 32) 1)) (chk 24 (c-tscp-ref s 8) -1) (c-tscp-set! s 0 -1) (chk 25 (c-int-ref s 0) -4)) (else (format #t "Tests 20-25 omitted~%")))) (let ((s (make-string 20))) (c-float-set! s 0 -1) (chk 30 (c-float-ref s 0) -1.0) (c-double-set! s 0 -1) (chk 31 (c-double-ref s 0) -1.0)) (let ((s (make-string 10 #\*)) (v (make-vector 10 -1))) (chk 40 (scheme-byte-ref s (if bigendian (- c-sizeof-tscp 2) 1)) 10) (chk 41 (scheme-byte-ref s c-sizeof-tscp) (char->integer #\*)) (chk 42 (scheme-byte-ref s (+ 10 c-sizeof-tscp)) 0) (scheme-byte-set! s (+ c-sizeof-tscp 1) (char->integer #\^)) (scheme-byte-set! s (+ c-sizeof-tscp 5) (char->integer #\^)) (chk 43 s "*^***^****") (chk 44 (scheme-s2cuint-ref s 0) (+ 2560 134)) (chk 45 (scheme-int-ref v c-sizeof-tscp) (if (and bigendian (= c-sizeof-int 2) (= c-sizeof-tscp 4)) -1 -4)) (scheme-int-set! v c-sizeof-tscp 4) (scheme-int-set! v (+ c-sizeof-int c-sizeof-tscp) 0) (chk 46 (scheme-tscp-ref v c-sizeof-tscp) (if (and bigendian (= c-sizeof-int 2) (= c-sizeof-tscp 4)) (expt 2 16) 1)) (chk 47 (scheme-int-ref v c-sizeof-tscp) 4) (scheme-tscp-set! v c-sizeof-tscp "This is the TSCP") (chk 48 (vector-ref v 0) "This is the TSCP")) ;;; *.* Bit operations (chk 50 (bit-and 1) 1) (chk 51 (bit-or 1) 1) (chk 52 (bit-xor 1) 1) (chk 53 (bit-not (bit-not 1)) 1) (chk 54 (bit-and 1 3 5) 1) (chk 55 (bit-or 1 3 5) 7) (chk 56 (bit-xor 1 3 5) 7) (chk 57 (bit-lsh 1 31) 2147483648.) (chk 58 (bit-rsh -1 31) 1)) scheme2c-2012.10.14/test/test17.sc000066400000000000000000000055761203736146400162530ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test17) (define-external (chk testnum result expected) testchk) (define (MAKE-COUNTER x) (lambda () (set! x (+ 1 x)))) ;;; This funny little function showed up on the Scheme mailing list. It ;;; creates an object which has state which never uses a SET!. The I/O ;;; statements in it are there for debugging purposes. (define (MAKE-CELL) (call-with-current-continuation (lambda (return-from-make-cell) (letrec ((state (call-with-current-continuation (lambda (return-new-state) (return-from-make-cell (lambda (op) ; (format (current-output-port) "OP is ~s~%" op) (case op ((set) (lambda (value) (call-with-current-continuation (lambda (return-from-access) (return-new-state (begin ; (format (current-output-port) ; "VALUE is ~s~%" value) (list value return-from-access))))))) ((get) (car state))))))))) ; (format (current-output-port) "STATE is ~s~%" state) ((cadr state) 'done))))) (define (test17) ;;; Exercise the display and call-with-current-continuation some more. (let* ((cntr1 (make-counter 0)) (cntr2 (make-counter 100)) (c1-1 (cntr1)) (c2-101 (cntr2)) (c1-2 (cntr1)) (c2-102 (cntr2))) (chk 1 (list c1-1 c2-101 c1-2 c2-102) '(1 101 2 102))) (let ((cell (make-cell))) ((cell 'set) 23) (chk 2 (cell 'get) 23))) scheme2c-2012.10.14/test/test18.sc000066400000000000000000000100701203736146400162350ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test18) (define-external (chk test-number result expected) testchk) (define (TEST18) ;;; 6.10 I/O tests. (chk 01 (input-port? '()) #f) (chk 02 (input-port? '#()) #f) (chk 03 (input-port? '(1 2)) #f) (chk 04 (input-port? '#(1 2)) #f) (chk 05 (input-port? 'x) #f) (chk 06 (input-port? "x") #f) (chk 07 (input-port? '#\a) #f) (chk 08 (input-port? (lambda (x) x)) #f) (chk 09 (input-port? #f) #f) (chk 10 (input-port? #t) #f) (chk 11 (input-port? -1) #f) (chk 12 (input-port? 0) #f) (chk 13 (input-port? 1) #f) (chk 14 (input-port? -1.5) #f) (chk 15 (input-port? 0.0) #f) (chk 16 (input-port? 1.5) #f) (chk 17 (input-port? stdin-port) #t) (chk 21 (output-port? '()) #f) (chk 22 (output-port? '#()) #f) (chk 23 (output-port? '(1 2)) #f) (chk 24 (output-port? '#(1 2)) #f) (chk 25 (output-port? 'x) #f) (chk 26 (output-port? "x") #f) (chk 27 (output-port? '#\a) #f) (chk 28 (output-port? (lambda (x) x)) #f) (chk 29 (output-port? #f) #f) (chk 30 (output-port? #t) #f) (chk 31 (output-port? -1) #f) (chk 32 (output-port? 0) #f) (chk 33 (output-port? 1) #f) (chk 34 (output-port? -1.5) #f) (chk 35 (output-port? 0.0) #f) (chk 36 (output-port? 1.5) #f) (chk 37 (output-port? stdout-port) #t) (chk 38 (output-port? stderr-port) #t) (chk 40 (call-with-output-file "test18.tmp" (lambda (port) (write "Test18 - 40" port) 'test-40)) 'test-40) (chk 43 (call-with-input-file "test18.tmp" (lambda (port) (chk 41 (read port) "Test18 - 40") (chk 42 (eof-object? (read port)) #t) 'test-43)) 'test-43) (chk 50 (with-output-to-file "test18.tmp" (lambda () (write "Test18 - 50") 'test-50)) 'test-50) (chk 53 (with-input-from-file "test18.tmp" (lambda () (chk 51 (read) "Test18 - 50") (chk 52 (eof-object? (read)) #t) 'test-53)) 'test-53) (let ((port (open-input-file "test18.tmp"))) (chk 60 (read port) "Test18 - 50") (chk 61 (eof-object? (read port)) #t) (close-input-port port)) (let ((port (open-output-file "test18.tmp"))) (write "Test18 - 70" port) (close-output-port port) (set! port (open-file "test18.tmp" "r")) (chk 70 (read port) "Test18 - 70") (chk 71 (eof-object? (read port)) #t) (chk 72 (eof-object? (read port)) #t) (close-port port)) (let ((port (open-input-string "1.2 (a b c)"))) (chk 80 (read port) 1.2) (chk 81 (read port) '(a b c)) (chk 82 (eof-object? (read port)) #t) (chk 83 (eof-object? (read port)) #t)) (let ((port (open-output-string))) (chk 90 (get-output-string port) "") (write '(a b c d) port) (chk 91 (get-output-string port) "(A B C D)") (chk 92 (get-output-string port) "") (write "This is a string" port) (chk 93 (get-output-string port) "\"This is a string\""))) scheme2c-2012.10.14/test/test19.sc000066400000000000000000000046161203736146400162470ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test19) (define-external (chk test-number result expected) testchk) (define (TEST19) ;;; 6.10 I/O tests. (let ((port (open-input-string "*"))) (chk 1 (peek-char port) #\*) (chk 2 (peek-char port) #\*) (chk 3 (read-char port) #\*) (chk 4 (eof-object? (read-char port)) #t) (chk 5 (eof-object? (peek-char port)) #t)) (with-output-to-file "test19.tmp" (lambda () (write-char #\*) (chk 10 (write-count) 1) (chk 11 (write-width) 80) (set-write-width! 132) (chk 12 (write-width) 132))) (with-input-from-file "test19.tmp" (lambda () (chk 21 (peek-char) #\*) (chk 22 (peek-char) #\*) (chk 23 (read-char) #\*) (chk 24 (eof-object? (read-char)) #t) (chk 25 (eof-object? (peek-char)) #t))) (with-output-to-file "test19.tmp" (lambda () (with-input-from-file "test19.tmp" (lambda () (display 'a) (chk 30 (eof-object? (read)) #t) (flush-buffer) (chk 31 (read) 'a))))) (chk 50 (format "~%") (list->string '(#\newline))) (chk 51 (format "~a~s" "a" "a") "a\"a\"") (chk 52 (format "~A~S" "a" "a") "a\"a\"") (chk 53 (format "~c~C" #\a #\a) "aa") (chk 54 (format "~~") "~") ) scheme2c-2012.10.14/test/test20-input.sc000066400000000000000000000020201203736146400173570ustar00rootroot00000000000000;;; ;;; readprint test script ;;; ;;; boolean #t #T #f #F ;;; identifier apple Apple \apple \1+ + - a.b ;;; number 1 -1 +1 +#b11 +#o11 +#xa1 #B11 #O11 #XA1 1.3 -1.3 1.3E2 -1.3E2 ;;; character #\a #\A #\tab #\newline #\linefeed #\formfeed #\return #\space #\SPAce #\\ #\ ;;; A space follows the \ #\ ;;; A tab follows the \ ;;; string "" "This is a string" "This is a string with \"embedded\" quote marks" "This string covers two lines" ;;; lists () (a) (a . b) (a b c d) (a . (b . (c . (d . ())))) ((a b)(c d)(e f)(g h)) ( 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 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 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 a b c d e f g h i j k l) ;;; vector #() #(1) #(1 2 3 4) #(#(1 2) #(2 3) #(3 4)) #( 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 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 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 a b c d e f g h i j k l) ;;; quote and quasiquote 'a '(1 2 3) ,b ,@c `(a b c) `(a ,b ,@c) scheme2c-2012.10.14/test/test20-make.sc000066400000000000000000000036221203736146400171460ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. ;;; This test function builds the test program for test 20, using a ;;; "known good" version of the Scheme->C interpreter. (define (TEST20-MAKE) (let ((in (open-input-file "test20-input.sc")) (out (open-output-file "test20.sc"))) (format out "(module test20)~%~%") (format out "(define (TEST20)~%") (format out " (with-input-from-file \"test20-input.sc\"~%") (format out " (lambda ()~%") (let loop ((form (read in)) (i 1)) (unless (eof-object? form) (format out " (chk ~s (read) '~s)~%" i form) (loop (read in) (+ i 1)))) (format out ")))~%") (close-input-port in) (close-output-port out))) scheme2c-2012.10.14/test/test20.sc000066400000000000000000000077561203736146400162470ustar00rootroot00000000000000(module test20) (define (TEST20) (with-input-from-file "test20-input.sc" (lambda () (chk 1 (read) '#T) (chk 2 (read) '#T) (chk 3 (read) '#F) (chk 4 (read) '#F) (chk 5 (read) 'APPLE) (chk 6 (read) 'APPLE) (chk 7 (read) '\aPPLE) (chk 8 (read) '\1+) (chk 9 (read) '+) (chk 10 (read) '-) (chk 11 (read) 'A.B) (chk 12 (read) '1) (chk 13 (read) '-1) (chk 14 (read) '1) (chk 15 (read) '3) (chk 16 (read) '9) (chk 17 (read) '161) (chk 18 (read) '3) (chk 19 (read) '9) (chk 20 (read) '161) (chk 21 (read) '1.3) (chk 22 (read) '-1.3) (chk 23 (read) '130.) (chk 24 (read) '-130.) (chk 25 (read) '#\a) (chk 26 (read) '#\A) (chk 27 (read) '#\tab) (chk 28 (read) '#\newline) (chk 29 (read) '#\newline) (chk 30 (read) '#\formfeed) (chk 31 (read) '#\return) (chk 32 (read) '#\space) (chk 33 (read) '#\space) (chk 34 (read) '#\\) (chk 35 (read) '#\space) (chk 36 (read) '#\tab) (chk 37 (read) '"") (chk 38 (read) '"This is a string") (chk 39 (read) '"This is a string with \"embedded\" quote marks") (chk 40 (read) '"This string covers two lines") (chk 41 (read) '()) (chk 42 (read) '(A)) (chk 43 (read) '(A . B)) (chk 44 (read) '(A B C D)) (chk 45 (read) '(A B C D)) (chk 46 (read) '((A B) (C D) (E F) (G H))) (chk 47 (read) '(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 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 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 A B C D E F G H I J K L)) (chk 48 (read) '#()) (chk 49 (read) '#(1)) (chk 50 (read) '#(1 2 3 4)) (chk 51 (read) '#(#(1 2) #(2 3) #(3 4))) (chk 52 (read) '#(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 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 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 A B C D E F G H I J K L)) (chk 53 (read) ''A) (chk 54 (read) ''(1 2 3)) (chk 55 (read) ',B) (chk 56 (read) ',@C) (chk 57 (read) '`(A B C)) (chk 58 (read) '`(A ,B ,@C)) ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. ))) scheme2c-2012.10.14/test/test21.sc000066400000000000000000000123401203736146400162310ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test21) (define-external (chk test-number result expected) testchk) ;;; An example of the use of nested defines from Abelson & Sussman. (define (SUM term a next b) (if (> a b) 0. (+ (term a) (sum term (next a) next b)))) (define (PI-SUM a b) (define (PI-TERM x) (/ 1. (* x (+ x 2)))) (define (PI-NEXT x) (+ x 4.)) (sum pi-term a pi-next b)) (define (CUBE x) (* x (* x x))) (define (INTEGRAL f a b dx) (define (ADD-DX x) (+ x dx)) (* (sum f (+ a (/ dx 2.)) add-dx b) dx)) (define TOP-TEST21 40) (define (TEST21) (chk 1 (integral cube 0 1 .01) 0.249987492) (chk 10 ((lambda () 10)) 10) (chk 11 ((lambda (x) x) 11) 11) (chk 12 ((lambda x x) 12) '(12)) (chk 13 ((lambda (x . y) (cons x y)) 1 3) '(1 3)) (chk 14 ((lambda (x y . z) (list x y z)) 1 2 3 4) '(1 2 (3 4))) (chk 20 (if #t #f) #f) (chk 21 (if #t #f #t) #f) (chk 22 (if #f #f #t) #t) (let ((get #f) (set #f)) (let ((value #f)) (set! get (lambda () value)) (set! set (lambda (x) (set! value x) x))) (chk 30 (get) #f) (chk 31 (set 31) 31) (chk 32 (get) 31)) (set! top-test21 40) (chk 40 top-test21 40) (let ((f (lambda (x) (cond ((eq? x 1) 'one) ((eq? x 2) 'two) ((if (number? x) x #f) => (lambda (x) (- x 1))) (else 'else))))) (chk 50 (f 1) 'one) (chk 51 (f 2) 'two) (chk 53 (f 10) 9) (chk 54 (f 20) 19) (chk 55 (f 'a) 'else)) (let ((f (lambda (x) (case x ((2 3 5 7) 'prime) ((1) 'one) ((a e i o u) 'vowel) (else 'mystery))))) (chk 60 (f 5) 'prime) (chk 61 (f 1) 'one) (chk 62 (f 'u) 'vowel) (chk 63 (f 'f) 'mystery)) (chk 70 (and (= 2 2) (> 2 1)) #t) (chk 71 (and (= 2 2) (< 2 1)) #f) (chk 72 (and 1 2 'c '(f g)) '(f g)) (chk 73 (and) #t) (chk 74 (and 1) 1) (chk 75 (and '()) '()) (chk 76 (and 1 2 '()) '()) (chk 77 (and (or #f '() (and (not #f) 1 2 3))) 3) (chk 78 (and '() 1 2) '()) (chk 80 (or (= 2 2) (> 2 1)) #t) (chk 81 (or (= 2 2) (< 2 1)) #t) (chk 82 (or #f #f #f) #f) (chk 83 (or (memq 'b '(a b c)) (char->integer 0)) '(b c)) (chk 84 (or) #f) (chk 85 (or 1) 1) (chk 86 (or '()) '()) (chk 87 (or (cdr '(a)) 0) 0) (chk 88 (or (cdr '(a)) 0 1) 0) (let ((x 'x) (y 'y) (z 'z)) (let ((x 'newx) (y x) (z y)) (chk 90 x 'newx) (chk 91 y 'x) (chk 92 z 'y)) (let* ((x 'newx) (y x) (z y)) (chk 90 x 'newx) (chk 91 y 'newx) (chk 92 z 'newx))) (letrec ((even*? (lambda (n) (if (zero? n) #t (odd*? (- n 1))))) (odd*? (lambda (n) (if (zero? n) #f (even*? (- n 1)))))) (chk 100 (even*? 88) #t) (chk 101 (odd*? 13) #t) (chk 102 (even*? 7) #f) (chk 103 (odd*? 14) #f)) (let ((x 1)) (begin (chk 110 x 1) (set! x 10) (chk 111 x 10))) (let ((x (do ((i 0 (+ 1 i)) (j 0) (k '() (cons i k))) ((= i 5) k)))) (chk 120 x '(4 3 2 1 0))) (do ((i 0 (+ 1 i)) (j (lambda (x) (x)))) ((= i 10)) (chk 130 (j (lambda () i)) i)) (do ((i 0 (+ i 1)) (j (lambda (x) (x))) (k 0 (+ k 1)) (l 0 (+ l 1)) (m '() (cons l m))) ((eq? i 5) (chk 140 m '(9 7 5 3 1))) (j (lambda () (list i k))) (chk 140 (* i 2) k) (chk 141 (* i 2) l) (set! k (+ k 1)) (set! l (+ l 1))) (do ((i 0 (+ 1 i))) ((eq? i 10)) (set! i (+ i 1)) (chk 150 (remainder i 2) 1)) (let loop ((l1 '(1 2 3 4)) (l2 '())) (if l1 (loop (cdr l1) (cons (car l1) l2)) (chk 160 l2 '(4 3 2 1)))) (chk 170 `(list ,(+ 1 2) 4) '(list 3 4)) (chk 171 (let ((name 'a)) `(list ,name ',name)) '(list a (quote a))) (chk 172 `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b) '(a 3 4 5 6 b)) (chk 173 `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))) '((foo 7) . cons)) (chk 174 `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)) (chk 175 (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) '(a `(b ,x ,'y d) e)) ) scheme2c-2012.10.14/test/test22.sc000066400000000000000000000122471203736146400162400ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test22) (define-external (chk test-number result expected) testchk) (define (FSM1 l) (letrec ((s1 (lambda (l c) (set! c (+ c 1)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 1 c)))))) (s2 (lambda (l c) (set! c (+ c 1)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 2 c)))))) (s3 (lambda (l c) (set! c (+ c 1)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 3 c)))))) (s4 (lambda (x) x))) (s1 l 0))) (define (FSM2 l) (letrec ((s1 (lambda (l c) (case (car l) ((a) (s1 (cdr l) (+ c 1))) ((b) (s2 (cdr l) (+ c 1))) ((c) (s3 (cdr l) (+ c 1))) (else (s4 (list 1 (+ c 1))))))) (s2 (lambda (l c) (case (car l) ((a) (s1 (cdr l) (+ c 1))) ((b) (s2 (cdr l) (+ c 1))) ((c) (s3 (cdr l) (+ c 1))) (else (s4 (list 2 (+ c 1))))))) (s3 (lambda (l c) (case (car l) ((a) (s1 (cdr l) (+ c 1))) ((b) (s2 (cdr l) (+ c 1))) ((c) (s3 (cdr l) (+ c 1))) (else (s4 (list 3 (+ c 1))))))) (s4 (lambda (x) x))) (s1 l 0))) (define (FSM3 l) (letrec ((s1 (lambda (l) (case (car l) ((a) (s1 (cdr l))) ((b) (s2 (cdr l))) ((c) (s3 (cdr l))) (else #f)))) (s2 (lambda (l) (case (car l) ((a) (s1 (cdr l))) ((b) (s2 (cdr l))) ((c) (s3 (cdr l))) (else #f)))) (s3 (lambda (l) (case (car l) ((a) (s1 (cdr l))) ((b) (s2 (cdr l))) ((c) (s3 (cdr l))) (else #t))))) (s1 l))) (define (FSM4 l) (letrec ((save '()) (s1 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () l)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 1 c)))))) (s2 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () l)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 2 c)))))) (s3 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () l)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 3 c)))))) (s4 (lambda (x) x))) (s1 l 0))) (define (FSM5 l) (letrec ((save '()) (s1 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () c)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 1 c)))))) (s2 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () c)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 2 c)))))) (s3 (lambda (l c) (set! c (+ c 1)) (set! save (lambda () c)) (case (car l) ((a) (s1 (cdr l) c)) ((b) (s2 (cdr l) c)) ((c) (s3 (cdr l) c)) (else (s4 (list 3 c)))))) (s4 (lambda (x) x))) (s1 l 0))) (define (TEST22) (chk 1 (fsm1 '(d)) '(1 1)) (chk 2 (fsm1 '(a b c d)) '(3 4)) (chk 10 (fsm2 '(d)) '(1 1)) (chk 11 (fsm2 '(a b c d)) '(3 4)) (chk 20 (fsm3 '(d)) #f) (chk 21 (fsm3 '(c d)) #t) (chk 30 (let l1 ((l '((1 2 3) (4 5 6 7) (8 9))) (m '())) (if l (let l2 ((sl (car (apply (lambda () l) '()))) (c 0)) (if sl (l2 (cdr sl) (+ (apply (lambda () c) '()) 1)) (l1 (cdr l) (append m (list c))))) m)) '(3 4 2)) (chk 40 (fsm4 '(d)) '(1 1)) (chk 41 (fsm4 '(a b c d)) '(3 4)) (chk 50 (fsm5 '(d)) '(1 1)) (chk 51 (fsm5 '(a b c d)) '(3 4)) ) scheme2c-2012.10.14/test/test23.sc000066400000000000000000000242761203736146400162460ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test23) (define-external (chk test-number result expected) testchk) (define (FSM23-1 c) (letrec ((s1 (lambda (c) (if (eq? c 0) #t (s2 (- c 1))))) (s2 (lambda (c) (if (eq? c 0) #f (s1 (- c 1)))))) (s1 c))) (eval-when (load) (define fsm23-1-trials 1000000)) (eval-when (eval) (define fsm23-1-trials 10000)) (define (FSM23-2 c) (letrec ((s1 (lambda (c) (if (car c) (s2 (cdr c)) (s3 (cdr c))))) (s2 (lambda (c) (if (car c) (s1 (cdr c)) (s3 (cdr c))))) (s3 (lambda (c) c))) (s1 c))) (define (FSM23-3 c) (letrec ((s1 (lambda (c) (if c (if (car c) (s2 (cdr c)) (s3 (cdr c))) 'done))) (s2 (lambda (c) (s3 c))) (s3 (lambda (c) (s1 c)))) (s1 c))) (define DEF1-23 (lambda () #f)) (define (DEF2-23) #f) ;;; The following test verifies that assignment to variables initially bound ;;; to functions is correctly handled. (define (NESTED23) (let ((f1 (lambda () 'first-f1))) (define (f2) 'first-f2) (define (f3) 'only-f3) (let ((result (list (f1) (f2) (f3)))) (set! f1 (lambda () 'second-f1)) (set! f2 (lambda () 'second-f2)) (append result (list (f1) (f2) (f3)))))) ;;; The following test verifies that the display is correctly preserved. (define (DISPLAY23) (let ((d1 (car '(a))) (d2 (car '(b))) (d3 (car '(c)))) (define (f1) d1) (define (f2) d2) (define (f3) d3) (chk 60 (f1) 'a) (chk 61 (f2) 'b) (chk 62 (f3) 'c) (chk 63 (display23-1) '(a-1 b-1 c-1)) (chk 64 (f1) 'a) (chk 65 (f2) 'b) (chk 66 (f3) 'c))) (define (DISPLAY23-1) (let ((d1 (car '(a-1)))) (define (f1) (let ((d2 (car '(b-1))) (d3 (car '(c-1)))) (define (f2) (list d1 d2 d3)) (f2) (f2))) (f1) (f1))) ;;; The following test assures that the variable 'a' is correctly allocated to ;;; the display. (define (JMD-DISPLAY23 a) (define (i1) a) (define (i2 x) (if x (i2 #f)) (i1)) (i2 #t)) ;;; The following test assures that the variables 'x' and 'y' are correctly ;;; handled in the display on a tail call. (define (BH-DISPLAY23 x y) (if (< x 10) (begin (input-port? (lambda () (list x y))) (set! y (+ y 1)) (bh-display23 (+ x 1) (+ y 1))) (list x y))) ; make-gen - Try to make Icon-style generator function in Scheme->C. ; David J. Slate; Mon Dec 18 05:10:32 CST 1989 ; make-gen is called with the generator function as its first argument, and ; the args to the generator as remaining args. make-gen returns ; a function object that is called with one of two messages: ; 'refresh - to re-initialize the generator. ; 'next - to get the next result. ; The generator function must take a leading extra arg through which the ; suspend function is passed. ; Results are returned only by (suspend result) calls. ; When generator is exhausted, it returns '(). (define (MAKE-GEN genfun . args) (let* ((savefun genfun) (savecal #f) (call/cc call-with-current-continuation) (suspnd (lambda (result) (call/cc (lambda (contin) (set! savefun contin) (savecal result))))) (gargs (cons suspnd args))) (lambda (msg) (cond ((eq? msg 'refresh) (set! savefun genfun) '() ) ((eq? msg 'next) (if savefun (call/cc (lambda (return) (set! savecal return) (if (eq? savefun genfun) (apply genfun gargs) (savefun '() )) (set! savefun #f) '() )) '() )) (else (display "No such msg!: ") (display msg) (newline)))))) ; gen-sequence illustrates the use of make-gen: (define GEN-SEQUENCE (lambda (suspnd n) (suspnd n) (gen-sequence suspnd (+ n 1)))) (define GENERATOR (make-gen gen-sequence 1)) ;;; Assure that lexical variable in an inline tail-call is detected. (define (interpret-query query item-identifier) (define (examine-each fn) (item-identifier 3)) (define (internal-interpret q) (case (car query) ((and) ; (AND ...) (map internal-interpret (cdr query))) ((contains?) (case (length query) ((2) (examine-each ; (CONTAINS? word) (lambda (record) 3))) ((3) ; (CONTAINS? word field) (examine-each (lambda (record) 3))))))) (internal-interpret query)) ;;; Force compilation of code to pass procedural arguments. (define-c-external (cfunc1 pointer) int "atoi") (define (DONT-CALL-THIS-TEST) (cfunc1 cfunc1)) ;;; Make sure the compiler finds all closed over variables. (define (BH-CLOSED23 x) (define (F1) (cons x x)) (define (F2) (f1)) (define (F3) (f1)) (define (F4) (lambda () (f2))) (f3) f4) ;;; Make sure that SQUARE generates correct C code. (define HC-JUNK (let ((SQUARE (lambda (x) (* x x)))) (lambda (a) (square (square a))))) ;;; Make sure that H as an argument generates correct C code. (define HC-F (lambda (x y) x)) (define HC-G (let ((h (lambda () #f))) (hc-f h (lambda () #f)))) ;;; Problem reported by Henry Cejtin, henry@math.nwu.edu. This procedure is ;;; incorrectly compiled. If the commented-out cont is not commented-out, ;;; then the routine is correctly compiled. (define (comp scan1 cont) (let loop ((scan2 scan1)) (scan2 (lambda () (comp do-2 (lambda (scan3) (scan3 not-called (lambda () ; cont (loop do-3)) should-not-be-called)))) (lambda () (cont scan2)) (lambda () (cont scan2))))) (define not-called (lambda ignored (error 'reg "NOT POSSIBLE"))) (define should-not-be-called (lambda ignored (error 'reg "BUG"))) (define do-1 (lambda (one two three) (one))) (define do-2 (lambda (one two three) (two))) (define do-3 (lambda (one two three) (three))) (define go (lambda () (comp do-1 (lambda ignored 'ok)))) ;;; Used to cause the compiler to loop. (define (bar) (define (index-of-char-in-string char string start-index length-of-string) (cond ((= start-index length-of-string) '()) ((char=? (string-ref string start-index) char) start-index) (#t (index-of-char-in-string char string (+ start-index 1) length-of-string)))) '()) ;;; Used to cause the compiler to crash. (define (CRASH) (define (F x) (+ x 1)) (define (G x) (+ (f x) (f x))) (define (H) (g 23))) ;;; Check top level variable declarations. (define-external TOP-LEVEL-X top-level) (define (TEST-TOP) (set! top-level-x 1) (set! top-level-y 2) (list 'top-level-x top-level-x 'top-level-y top-level-y)) ;;; Compiled constants and macros. (eval-when (load eval) (define-constant A-IS-23 23) (define-macro PLUS1 (lambda (f e) (e `(+ 1 ,(cadr f)) e)))) (eval-when (load compile eval) (define-constant A-CONSTANT-1 23)) (define-constant A-CONSTANT-2 a-constant-1) (define-constant A-CONSTANT-3 3) (define-constant A-CONSTANT-4 (* a-constant-3 a-constant-3)) ;;; Access to an external array. ;(define-c-external _\i\o\b* ARRAY "_iob") ;(eval-when (load) (define _iob _\i\o\b*)) ;(eval-when (eval) (define _iob 0)) ;;; Access to an external procedure pointer. (define-c-external (c-hypot double double) double "hypot") (eval-when (load) (define hypot c-hypot)) (eval-when (eval) (define hypot 0)) ;;; Incorrect optimization, used to result in bad C code. (define a-variable 3) (define (a-procedure) (let ((a-variable 4) (g (lambda (x) a-variable))) (g (g (display 1))))) ;;; Shared constant and top-level variable value, used to result in bad C ;;; code. (define-external some-x top-level) (define (TEST-SOME-X) `(some-x 1) (some-x)) (define (TEST23) (chk 1 (fsm23-1 fsm23-1-trials) #t) (chk 10 (fsm23-2 '(#t #f result)) '(result)) (chk 11 (fsm23-2 '(#f result)) '(result)) (chk 12 (fsm23-2 '(#t #t #f result)) '(result)) (chk 20 (fsm23-3 '(#t #f #t #f #f #t . #f)) 'done) (chk 30 (let l1 ((x 0)) (let l2 ((y 0)) (cond ((procedure? x) 'done) (y (l1 (lambda () y))) (else (l2 (lambda () x)))))) 'done) (chk 40 (def1-23) #f) (set! def1-23 (lambda () #t)) (chk 41 (def1-23) #t) (chk 42 (def2-23) #f) (set! def2-23 (lambda () #t)) (chk 43 (def2-23) #t) (chk 50 (nested23) '(first-f1 first-f2 only-f3 second-f1 second-f2 only-f3)) (display23) (chk 70 (jmd-display23 'jmd) 'jmd) (chk 71 (bh-display23 0 0) '(10 20)) (chk 80 (generator 'next) 1) (chk 81 (generator 'next) 2) (chk 82 (generator 'refresh) '()) (chk 83 (generator 'next) 1) (chk 90 (((bh-closed23 42))) '(42 . 42)) (chk 100 (go) 'ok) (chk 110 (test-top) '(top-level-x 1 top-level-y 2)) (chk 120 (expand 'a-is-23) 23) (chk 121 (expand '(plus1 a-is-23)) '(+ 1 23)) (chk 122 a-constant-2 23) (chk 123 (expand 'a-constant-1) 23) (chk 124 a-constant-3 3) (chk 125 a-constant-4 9) (chk 130 (string-ref "" 0) (integer->char #o21)) ; (chk 140 (number? _iob) #t) (chk 141 (number? hypot) #t) (chk 150 (letrec ((x 1)) (define x 2) x) 2) ) scheme2c-2012.10.14/test/test50.sc000066400000000000000000000052621203736146400162400ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test50 (main test50)) ;;; Memory management test (define (LISTTEST i l) (do ((next 1 (+ next 1)) (l l (cdr l))) ((or (null? l) (not (eq? (car l) next))) (if (or l (not (eq? next 10001))) (error 'listtest "Failed! ~s-~s~%" i next))))) (define (TEST50) (display "***** Starting Memory Test") (newline) (let ((old-obarray *obarray*)) (collect) (display "Successfully Garbage Collected initial image") (newline) (collect-all) (display "Collect-all of initial image") (newline) (if (not (equal? old-obarray *obarray*)) (error 'memtest "*OBARRAY* comparison failed"))) (display "1000 Lists of 10000 pairs each") (newline) (do ((i 0 (+ i 1))) ((= 1000 i)) (do ((j 10000 (- j 1)) (l '() (cons j l))) ((zero? j) (listtest i l))) (if (zero? (remainder i 100)) (begin (display i) (display " ") (flush-buffer)))) (newline) (display "1000 Vectors of 10000 entries each") (newline) (do ((i 0 (+ i 1))) ((= i 1000)) (make-vector 10000 i) (if (zero? (remainder i 100)) (begin (display i) (display " ") (flush-buffer)))) (newline) (display "1000 Strings of 10000 entries each") (newline) (do ((i 0 (+ i 1))) ((= i 1000)) (make-string 10000) (if (zero? (remainder i 100)) (begin (display i) (display " ") (flush-buffer)))) (newline) (display "***** Ending Memory Test") (newline)) scheme2c-2012.10.14/test/test51.sc000066400000000000000000000025161203736146400162400ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test51 (main test51)) (define (TEST51 clargs) (display "Hello world!") (newline)) scheme2c-2012.10.14/test/test52.sc000066400000000000000000000025451203736146400162430ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test52 (main test52)) ;;; Prints the command line arguments (define (TEST52 cl) (write cl) (newline)) scheme2c-2012.10.14/test/test53.sc000066400000000000000000000037421203736146400162440ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test53) ;;; Loops until a key is entered on the keyboard (define (KEY-LOOP) (let loop () (when (char-ready?) (read-char) (loop))) (display "Waiting for char (and a return) ...") (flush-buffer) (let loop ((cnt 0)) (unless (char-ready?) (if (zero? (modulo cnt 1000)) (begin (display ".") (loop 1))) (loop (+ cnt 1)))) (write (read-char)) (display " entered") (let loop () (when (char-ready?) (read-char) (loop))) (newline)) (define (CONTROL-C) (display "Hit control-c ...") (flush-buffer) (let loop ((cnt 1)) (if (zero? (modulo cnt 10000)) (begin (display ".") (flush-buffer) (loop 1)) (loop (+ cnt 1))))) (define (TEST53) (key-loop) (control-c)) scheme2c-2012.10.14/test/test54.sc000066400000000000000000000110511203736146400162350ustar00rootroot00000000000000;;; ;;; Scheme->C test program ;;; ;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test54 (main test54)) (define-external (chk testnum result expected) testchk) (define-c-external c1 char "c1") (define-c-external c2 char "c2") (define-c-external (fc1) char "fc1") (define-c-external (fc2) char "fc2") (define-c-external si1 shortint "si1") (define-c-external si2 shortint "si2") (define-c-external (fsi1) shortint "fsi1") (define-c-external (fsi2) shortint "fsi2") (define-c-external su1 shortunsigned "su1") (define-c-external su2 shortunsigned "su2") (define-c-external (fsu1) shortunsigned "fsu1") (define-c-external (fsu2) shortunsigned "fsu2") (define-c-external i1 int "i1") (define-c-external i2 int "i2") (define-c-external (fi1) int "fi1") (define-c-external (fi2) int "fi2") (define-c-external ui1 unsigned "ui1") (define-c-external ui2 unsigned "ui2") (define-c-external ui3 unsigned "ui3") (define-c-external (fui1) unsigned "fui1") (define-c-external (fui2) unsigned "fui2") (define-c-external (fui3) unsigned "fui3") (define-c-external f1 float "f1") (define-c-external (ff1) float "ff1") (define-c-external d1 double "d1") (define-c-external (fd1) double "fd1") (define-c-external ad1 array "ad1") (define-c-external (loop_pointer pointer) pointer "loop_pointer") (define-c-external (loop_array array) array "loop_array") (define-c-external (loop_char char) char "loop_char") (define-c-external (loop_shortint shortint) shortint "loop_shortint") (define-c-external (loop_shortunsigned shortunsigned) shortunsigned "loop_shortunsigned") (define-c-external (loop_int int) int "loop_int") (define-c-external (loop_unsigned unsigned) unsigned "loop_unsigned") (define-c-external (loop_longint longint) longint "loop_longint") (define-c-external (loop_longunsigned longunsigned) longunsigned "loop_longunsigned") (define-c-external (loop_float float) float "loop_float") (define-c-external (loop_double double) double "loop_double") (define (TEST54) (chk 1 c1 #\A) (chk 2 c2 #\c) (set! c1 #\B) (set! c2 #\d) (chk 3 (fc1) #\B) (chk 4 (fc2) #\d) (chk 10 si1 -4) (chk 11 si2 24) (set! si1 -6) (set! si2 26) (chk 12 (fsi1) -6) (chk 12 (fsi2) 26) (chk 20 su1 #xffff) (chk 21 su2 23) (set! su1 #xf000) (set! su2 25) (chk 22 (fsu1) #xf000) (chk 23 (fsu2) 25) (chk 30 i1 -2) (chk 31 i2 2) (set! i1 -4) (set! i2 4) (chk 32 (fi1) -4) (chk 33 (fi2) 4) (chk 40 ui1 #xffffffff) (chk 41 ui2 #x1fffffff) (chk 42 ui3 #xffff) (set! ui1 #xfffffff1) (set! ui2 #x1ffffff1) (set! ui3 #xfff1) (chk 43 (fui1) #xfffffff1) (chk 44 (fui2) #x1ffffff1) (chk 45 (fui3) #xfff1) (chk 50 f1 23.23) (set! f1 -24.24) (chk 51 (ff1) -24.24) (chk 60 d1 32.32) (set! d1 -33.33) (chk 61 (fd1) -33.33) (chk 70 (c-double-ref ad1 0) 0.0) (chk 71 (c-double-ref ad1 8) 1.0) (chk 72 (c-double-ref ad1 16) 2.0) (chk 80 (c-string->string (loop_pointer "Hi folks")) "Hi folks") (chk 81 (loop_array ad1) ad1) (chk 82 (loop_char #\a) #\a) (chk 83 (loop_shortint 1000) 1000) (chk 84 (loop_shortunsigned 1000) 1000) (chk 85 (loop_int -12345) -12345) (chk 86 (loop_unsigned 12345) 12345) (chk 87 (loop_longint -12345) -12345) (chk 88 (loop_longunsigned 12345) 12345) (chk 89 (loop_float 3.14) 3.14) (chk 90 (loop_double 3.14159) 3.14159)) scheme2c-2012.10.14/test/test54c.c000066400000000000000000000037141203736146400162240ustar00rootroot00000000000000/* Global variable access test */ char c1 = 'A', c2 = 'c'; short int si1 = -4, si2 = 24; short unsigned su1 = 0xFFFF, su2 = 23; int i1 = -2, i2 = 2; unsigned int ui1 = 0xFFFFFFFF, ui2 = 0x1FFFFFFF, ui3 = 0xFFFF; float f1 = 23.23; double d1 = 32.32, ad1[3] = {0.0, 1.0, 2.0}; /* Typed function returns */ char fc1() { return c1; } char fc2() { return c2; } short int fsi1() { return si1; } short int fsi2() { return si2; } short unsigned fsu1() { return su1; } short unsigned fsu2() { return su2; } int fi1() { return i1; } int fi2() { return i2; } unsigned int fui1() { return ui1; } unsigned int fui2() { return ui2; } unsigned int fui3() { return ui3; } float ff1() { return f1; } double fd1() { return d1; } /* Typed function arguments and return */ #ifndef __STDC__ char* loop_pointer( x ) char *x; { return x; } char* loop_array( x ) char *x; { return x; } char loop_char( x) char x; { return x; } short int loop_shortint( x ) short int x; { return x; } unsigned short int loop_shortunsigned( x ) unsigned short int x; { return x; } int loop_int( x ) int x; { return x; } unsigned int loop_unsigned( x ) unsigned int x; { return x; } long int loop_longint( x ) long int x; { return x; } unsigned long int loop_longunsigned( x ) unsigned long int x; { return x; } float loop_float( x ) float x; { return x; } double loop_double( x ) double x; { return x; } #else void* loop_pointer( void* x ) { return x; } void* loop_array( void* x ) { return x; } char loop_char( char x ) { return x; } short int loop_shortint( short int x ) { return x; } unsigned short int loop_shortunsigned( unsigned short int x ) { return x; } int loop_int( int x ) { return x; } unsigned int loop_unsigned( unsigned int x ) { return x; } long int loop_longint( long int x ) { return x; } unsigned long int loop_longunsigned( unsigned long int x ) { return x; } float loop_float( float x ) { return x; } double loop_double( double x ) { return x; } #endif scheme2c-2012.10.14/test/test55.sc000066400000000000000000000046361203736146400162510ustar00rootroot00000000000000;;; ;;; Test functions for basic Scheme functions. ;;; ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module test55 (main test55)) (define (TEST55) ;;; Write length and levels. (for-each (lambda (v n) (set-write-level! v) (set-write-length! n) (format #t "~s ~s ~s~%" v n '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz"))))) '(0 1 1 1 1 2 2 2 3 3 3 #f) '(1 1 2 3 4 1 2 3 2 3 4 #f)) (newline) ;;; Circularity detection. (set-write-circle! #t) (let* ((x (list 1 2 3 4 5)) (y (make-vector 5 x))) (set-cdr! (last-pair x) x) (vector-set! y 4 y) (write y)) (newline) (newline) ;;; Pretty-printing (set-write-pretty! #t) (write '(for-each (lambda (v n) (set-write-level! v) (set-write-length! n) (format #t "~s ~s ~s~%" v n '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz"))))) '(0 1 1 1 1 2 2 2 3 3 3 #f) '(1 1 2 3 4 1 2 3 2 3 4 #f))) (newline) (newline) (set-write-pretty! #f) (pp '(for-each (lambda (v n) (set-write-level! v) (set-write-length! n) (format #t "~s ~s ~s~%" v n '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz"))))) '(0 1 1 1 1 2 2 2 3 3 3 #f) '(1 1 2 3 4 1 2 3 2 3 4 #f))) (newline) #f) scheme2c-2012.10.14/test/testchk.sc000066400000000000000000000041301203736146400165520ustar00rootroot00000000000000;;; Test driver checking functions. ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. ;* All Rights Reserved ;* Permission is hereby granted, free of charge, to any person obtaining a ;* copy of this software and associated documentation files (the "Software"), ;* to deal in the Software without restriction, including without limitation ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, ;* and/or sell copies of the Software, and to permit persons to whom the ;* Software is furnished to do so, subject to the following conditions: ;* ;* The above copyright notice and this permission notice shall be included in ;* all copies or substantial portions of the Software. ;* ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;* DEALINGS IN THE SOFTWARE. (module testchk) (define TEST-ERRORS 0) (define *ACCURACY* 1.0e-7) (define (CHK test result expected) (unless (or (equal? result expected) (and (%record? result) (%record expected) (equal? (%record->list result) (%record->list expected))) (and (number? expected) (number? result) (inexact? expected) (<= (abs (- expected result)) (* (abs expected) *accuracy*)))) (format stdout-port " Test ~a failed~%" test) (format stdout-port " expected = ~s~%" expected) (format stdout-port " result = ~s~%" result) (set! test-errors (+ test-errors 1)))) (define (CHKQ test result expected) (unless (eq? result expected) (format stdout-port " Test ~a failed~%" test) (format stdout-port " expected = ~s~%" expected) (format stdout-port " result = ~s~%" result) (set! test-errors (+ test-errors 1)))) scheme2c-2012.10.14/xlib/000077500000000000000000000000001203736146400145375ustar00rootroot00000000000000scheme2c-2012.10.14/xlib/README000066400000000000000000000000421203736146400154130ustar00rootroot00000000000000Scheme->C interface to X11's Xlib scheme2c-2012.10.14/xlib/X.cdecl000066400000000000000000000456021203736146400157510ustar00rootroot00000000000000;;; X window system definitions for Scheme->C ;;; ;;; derived from: ;;; ;;; $XConsortium: X.h,v 1.66 88/09/06 15:55:56 jim Exp $ ;;; ;;; Definitions for the X window system likely to be used by applications ; Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ; and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ; ; All Rights Reserved ; ; Permission to use, copy, modify, and distribute this software and its ; documentation for any purpose and without fee is hereby granted, ; provided that the above copyright notice appear in all copies and that ; both that copyright notice and this permission notice appear in ; supporting documentation, and that the names of Digital or MIT not be ; used in advertising or publicity pertaining to distribution of the ; software without specific, written prior permission. ; ; DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ; DIGITAL BE LIABLE FOR ANY SPECIAL, 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. (const X_PROTOCOL 11) ; current protocol version (const X_PROTOCOL_REVISION 0) ; current minor version ;; New base types (typedef longunsigned unsignedlong) (typedef unsigned unsignedint) (typedef (unsigned 0) unsignedA) (typedef (unsignedlong 0) unsignedlongA) (typedef unsignedA unsignedintA) (typedef (unsignedA *) unsignedAP) (typedef (unsignedlongA *) unsignedlongAP) (typedef unsignedAP unsignedintAP) (typedef (unsigned *proc) unsignedPROC) (typedef (unsignedlong *proc) unsignedlongPROC) (typedef unsignedPROC unsignedintPROC) (typedef char unsignedchar) (typedef (char *) charP) (typedef (char 0) charA) (typedef (charA *) charAP) (typedef (charP 0) charPA) (typedef (charPA *) charPAP) (typedef shortint short) (typedef shortunsigned unsignedshort) (typedef longint long) (typedef (int *proc) intPROC) (typedef (int *) intP) (typedef (int 0) intA) (typedef (intA *) intAP) ;; Resources (typedef unsignedlong XID) (typedef XID Window) (typedef XID Drawable) (typedef XID Font) (typedef XID Pixmap) (typedef XID Cursor) (typedef XID Colormap) (typedef unsignedA ColormapA) (typedef unsignedAP ColormapAP) (typedef XID GContext) (typedef XID KeySym) (typedef unsignedA KeySymA) (typedef unsignedAP KeySymAP) (typedef unsignedA WindowA) (typedef unsignedAP WindowAP) (typedef unsignedlong Mask) (typedef unsignedlong Atom) (typedef unsignedA AtomA) (typedef unsignedAP AtomAP) (typedef unsignedlong VisualID) (typedef unsignedlong Time) (typedef unsignedchar KeyCode) ;;*************************************************************** ;; RESERVED RESOURCE AND CONSTANT DEFINITIONS ;;**************************************************************** (const None 0) ;; universal null resource or null atom (const ParentRelative 1) ;; background pixmap in CreateWindow ;; and ChangeWindowAttributes (const CopyFromParent 0) ;; border pixmap in CreateWindow ;; and ChangeWindowAttributes ;; special VisualID and special window ;; class passed to CreateWindow (const PointerWindow 0) ;; destination window in SendEvent (const InputFocus 1) ;; destination window in SendEvent (const PointerRoot 1) ;; focus window in SetInputFocus (const AnyPropertyType 0) ;; special Atom, passed to GetProperty (const AnyKey 0) ;; special Key Code, passed to GrabKey (const AnyButton 0) ;; special Button Code, passed to GrabButton (const AllTemporary 0) ;; special Resource ID passed to KillClient (const CurrentTime 0) ;; special Time (const NoSymbol 0) ;; special KeySym ;;**************************************************************** ;;* EVENT DEFINITIONS ;;**************************************************************** ;; Input Event Masks. Used as event-mask window attribute and as arguments ;; to Grab requests. Not to be confused with event names. (const NoEventMask 0) (const KeyPressMask (expt 2 0)) (const KeyReleaseMask (expt 2 1)) (const ButtonPressMask (expt 2 2)) (const ButtonReleaseMask (expt 2 3)) (const EnterWindowMask (expt 2 4)) (const LeaveWindowMask (expt 2 5)) (const PointerMotionMask (expt 2 6)) (const PointerMotionHintMask (expt 2 7)) (const Button1MotionMask (expt 2 8)) (const Button2MotionMask (expt 2 9)) (const Button3MotionMask (expt 2 10)) (const Button4MotionMask (expt 2 11)) (const Button5MotionMask (expt 2 12)) (const ButtonMotionMask (expt 2 13)) (const KeymapStateMask (expt 2 14)) (const ExposureMask (expt 2 15)) (const VisibilityChangeMask (expt 2 16)) (const StructureNotifyMask (expt 2 17)) (const ResizeRedirectMask (expt 2 18)) (const SubstructureNotifyMask (expt 2 19)) (const SubstructureRedirectMask (expt 2 20)) (const FocusChangeMask (expt 2 21)) (const PropertyChangeMask (expt 2 22)) (const ColormapChangeMask (expt 2 23)) (const OwnerGrabButtonMask (expt 2 24)) ;; Event names. Used in "type" field in XEvent structures. Not to be ;; confused with event masks above. They start from 2 because 0 and 1 ;; are reserved in the protocol for errors and replies. (const KeyPress 2) (const KeyRelease 3) (const ButtonPress 4) (const ButtonRelease 5) (const MotionNotify 6) (const EnterNotify 7) (const LeaveNotify 8) (const FocusIn 9) (const FocusOut 10) (const KeymapNotify 11) (const Expose 12) (const GraphicsExpose 13) (const NoExpose 14) (const VisibilityNotify 15) (const CreateNotify 16) (const DestroyNotify 17) (const UnmapNotify 18) (const MapNotify 19) (const MapRequest 20) (const ReparentNotify 21) (const ConfigureNotify 22) (const ConfigureRequest 23) (const GravityNotify 24) (const ResizeRequest 25) (const CirculateNotify 26) (const CirculateRequest 27) (const PropertyNotify 28) (const SelectionClear 29) (const SelectionRequest 30) (const SelectionNotify 31) (const ColormapNotify 32) (const ClientMessage 33) (const MappingNotify 34) (const LASTEvent 35) ;; must be bigger than any event # ;; Key masks. Used as modifiers to GrabButton and GrabKey, results of ;; QueryPointer, state in various key-, mouse-, and button-related events. (const ShiftMask (expt 2 0)) (const LockMask (expt 2 1)) (const ControlMask (expt 2 2)) (const Mod1Mask (expt 2 3)) (const Mod2Mask (expt 2 4)) (const Mod3Mask (expt 2 5)) (const Mod4Mask (expt 2 6)) (const Mod5Mask (expt 2 7)) ;; modifier names. Used to build a SetModifierMapping request or ;; to read a GetModifierMapping request. These correspond to the ;; masks defined above. (const ShiftMapIndex 0) (const LockMapIndex 1) (const ControlMapIndex 2) (const Mod1MapIndex 3) (const Mod2MapIndex 4) (const Mod3MapIndex 5) (const Mod4MapIndex 6) (const Mod5MapIndex 7) ;; button masks. Used in same manner as Key masks above. Not to be confused ;; with button names below. (const Button1Mask (expt 2 8)) (const Button2Mask (expt 2 9)) (const Button3Mask (expt 2 10)) (const Button4Mask (expt 2 11)) (const Button5Mask (expt 2 12)) (const AnyModifier (expt 2 15)) ;; used in GrabButton, GrabKey ;; button names. Used as arguments to GrabButton and as detail in ButtonPress ;; and ButtonRelease events. Not to be confused with button masks above. ;; Note that 0 is already defined above as "AnyButton". (const Button1 1) (const Button2 2) (const Button3 3) (const Button4 4) (const Button5 5) ;; Notify modes (const NotifyNormal 0) (const NotifyGrab 1) (const NotifyUngrab 2) (const NotifyWhileGrabbed 3) (const NotifyHint 1) ;; for MotionNotify events ;; Notify detail (const NotifyAncestor 0) (const NotifyVirtual 1) (const NotifyInferior 2) (const NotifyNonlinear 3) (const NotifyNonlinearVirtual 4) (const NotifyPointer 5) (const NotifyPointerRoot 6) (const NotifyDetailNone 7) ;; Visibility notify (const VisibilityUnobscured 0) (const VisibilityPartiallyObscured 1) (const VisibilityFullyObscured 2) ;; Circulation request (const PlaceOnTop 0) (const PlaceOnBottom 1) ;; protocol families (const FamilyInternet 0) (const FamilyDECnet 1) (const FamilyChaos 2) ;; Property notification (const PropertyNewValue 0) (const PropertyDelete 1) ;; Color Map notification (const ColormapUninstalled 0) (const ColormapInstalled 1) ;; GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes (const GrabModeSync 0) (const GrabModeAsync 1) ;; GrabPointer, GrabKeyboard reply status (const GrabSuccess 0) (const AlreadyGrabbed 1) (const GrabInvalidTime 2) (const GrabNotViewable 3) (const GrabFrozen 4) ;; AllowEvents modes (const AsyncPointer 0) (const SyncPointer 1) (const ReplayPointer 2) (const AsyncKeyboard 3) (const SyncKeyboard 4) (const ReplayKeyboard 5) (const AsyncBoth 6) (const SyncBoth 7) ;; Used in SetInputFocus, GetInputFocus (const RevertToNone None) (const RevertToPointerRoot PointerRoot) (const RevertToParent 2) ;;**************************************************************** ;;* ERROR CODES ;;**************************************************************** (const Success 0) ;; everything's okay (const BadRequest 1) ;; bad request code (const BadValue 2) ;; int parameter out of range (const BadWindow 3) ;; parameter not a Window (const BadPixmap 4) ;; parameter not a Pixmap (const BadAtom 5) ;; parameter not an Atom (const BadCursor 6) ;; parameter not a Cursor (const BadFont 7) ;; parameter not a Font (const BadMatch 8) ;; parameter mismatch (const BadDrawable 9) ;; parameter not a Pixmap or Window (const BadAccess 10) ;; depending on context: ;; - key/button already grabbed ;; - attempt to free an illegal ;; cmap entry ;; - attempt to store into a read-only ;; color map entry. ;; - attempt to modify the access control ;; list from other than the local host. (const BadAlloc 11) ;; insufficient resources (const BadColor 12) ;; no such colormap (const BadGC 13) ;; parameter not a GC (const BadIDChoice 14) ;; choice not in range or already used (const BadName 15) ;; font or color name doesn't exist (const BadLength 16) ;; Request length incorrect (const BadImplementation 17) ;; server is defective (const FirstExtensionError 128) (const LastExtensionError 255) ;;**************************************************************** ;;* WINDOW DEFINITIONS ;;**************************************************************** ;; Window classes used by CreateWindow ;; Note that CopyFromParent is already defined as 0 above (const InputOutput 1) (const InputOnly 2) ;; Window attributes for CreateWindow and ChangeWindowAttributes (const CWBackPixmap (expt 2 0)) (const CWBackPixel (expt 2 1)) (const CWBorderPixmap (expt 2 2)) (const CWBorderPixel (expt 2 3)) (const CWBitGravity (expt 2 4)) (const CWWinGravity (expt 2 5)) (const CWBackingStore (expt 2 6)) (const CWBackingPlanes (expt 2 7)) (const CWBackingPixel (expt 2 8)) (const CWOverrideRedirect (expt 2 9)) (const CWSaveUnder (expt 2 10)) (const CWEventMask (expt 2 11)) (const CWDontPropagate (expt 2 12)) (const CWColormap (expt 2 13)) (const CWCursor (expt 2 14)) ;; ConfigureWindow structure (const CWX (expt 2 0)) (const CWY (expt 2 1)) (const CWWidth (expt 2 2)) (const CWHeight (expt 2 3)) (const CWBorderWidth (expt 2 4)) (const CWSibling (expt 2 5)) (const CWStackMode (expt 2 6)) ;; Bit Gravity (const ForgetGravity 0) (const NorthWestGravity 1) (const NorthGravity 2) (const NorthEastGravity 3) (const WestGravity 4) (const CenterGravity 5) (const EastGravity 6) (const SouthWestGravity 7) (const SouthGravity 8) (const SouthEastGravity 9) (const StaticGravity 10) ;; Window gravity + bit gravity above (const UnmapGravity 0) ;; Used in CreateWindow for backing-store hint (const NotUseful 0) (const WhenMapped 1) (const Always 2) ;; Used in GetWindowAttributes reply (const IsUnmapped 0) (const IsUnviewable 1) (const IsViewable 2) ;; Used in ChangeSaveSet (const SetModeInsert 0) (const SetModeDelete 1) ;; Used in ChangeCloseDownMode (const DestroyAll 0) (const RetainPermanent 1) (const RetainTemporary 2) ;; Window stacking method (in configureWindow) (const Above 0) (const Below 1) (const TopIf 2) (const BottomIf 3) (const Opposite 4) ;; Circulation direction (const RaiseLowest 0) (const LowerHighest 1) ;; Property modes (const PropModeReplace 0) (const PropModePrepend 1) (const PropModeAppend 2) ;;**************************************************************** ;;* GRAPHICS DEFINITIONS ;;**************************************************************** ;; graphics functions, as in GC.alu (const GXclear #x0) ;; 0 (const GXand #x1) ;; src AND dst (const GXandReverse #x2) ;; src AND NOT dst (const GXcopy #x3) ;; src (const GXandInverted #x4) ;; NOT src AND dst (const GXnoop #x5) ;; dst (const GXxor #x6) ;; src XOR dst (const GXor #x7) ;; src OR dst (const GXnor #x8) ;; NOT src AND NOT dst (const GXequiv #x9) ;; NOT src XOR dst (const GXinvert #xa) ;; NOT dst (const GXorReverse #xb) ;; src OR NOT dst (const GXcopyInverted #xc) ;; NOT src (const GXorInverted #xd) ;; NOT src OR dst (const GXnand #xe) ;; NOT src OR NOT dst (const GXset #xf) ;; 1 ;; LineStyle (const LineSolid 0) (const LineOnOffDash 1) (const LineDoubleDash 2) ;; capStyle (const CapNotLast 0) (const CapButt 1) (const CapRound 2) (const CapProjecting 3) ;; joinStyle (const JoinMiter 0) (const JoinRound 1) (const JoinBevel 2) ;; fillStyle (const FillSolid 0) (const FillTiled 1) (const FillStippled 2) (const FillOpaqueStippled 3) ;; fillRule (const EvenOddRule 0) (const WindingRule 1) ;; subwindow mode (const ClipByChildren 0) (const IncludeInferiors 1) ;; SetClipRectangles ordering (const Unsorted 0) (const YSorted 1) (const YXSorted 2) (const YXBanded 3) ;; CoordinateMode for drawing routines (const CoordModeOrigin 0) ;; relative to the origin (const CoordModePrevious 1) ;; relative to previous point ;; Polygon shapes (const Complex 0) ;; paths may intersect (const Nonconvex 1) ;; no paths intersect, but not convex (const Convex 2) ;; wholly convex ;; Arc modes for PolyFillArc (const ArcChord 0) ;; join endpoints of arc (const ArcPieSlice 1) ;; join endpoints to center of arc ;; GC components: masks used in CreateGC, CopyGC, ChangeGC, OR'ed into ;; GC.stateChanges (const GCFunction (expt 2 0)) (const GCPlaneMask (expt 2 1)) (const GCForeground (expt 2 2)) (const GCBackground (expt 2 3)) (const GCLineWidth (expt 2 4)) (const GCLineStyle (expt 2 5)) (const GCCapStyle (expt 2 6)) (const GCJoinStyle (expt 2 7)) (const GCFillStyle (expt 2 8)) (const GCFillRule (expt 2 9)) (const GCTile (expt 2 10)) (const GCStipple (expt 2 11)) (const GCTileStipXOrigin (expt 2 12)) (const GCTileStipYOrigin (expt 2 13)) (const GCFont (expt 2 14)) (const GCSubwindowMode (expt 2 15)) (const GCGraphicsExposures (expt 2 16)) (const GCClipXOrigin (expt 2 17)) (const GCClipYOrigin (expt 2 18)) (const GCClipMask (expt 2 19)) (const GCDashOffset (expt 2 20)) (const GCDashList (expt 2 21)) (const GCArcMode (expt 2 22)) (const GCLastBit 22) ;;**************************************************************** ;;* FONTS ;;**************************************************************** ;; used in QueryFont -- draw direction (const FontLeftToRight 0) (const FontRightToLeft 1) (const FontChange 255) ;;**************************************************************** ;;* IMAGING ;;**************************************************************** ;; ImageFormat -- PutImage, GetImage (const XYBitmap 0) ;; depth 1, XYFormat (const XYPixmap 1) ;; depth == drawable depth (const ZPixmap 2) ;; depth == drawable depth ;;**************************************************************** ;;* COLOR MAP STUFF ;;**************************************************************** ;; For CreateColormap (const AllocNone 0) ;; create map with no entries (const AllocAll 1) ;; allocate entire map writeable ;; Flags used in StoreNamedColor, StoreColors (const DoRed (expt 2 0)) (const DoGreen (expt 2 1)) (const DoBlue (expt 2 2)) ;;**************************************************************** ;;* CURSOR STUFF ;;**************************************************************** ;; QueryBestSize Class (const CursorShape 0) ;; largest size that can be displayed (const TileShape 1) ;; size tiled fastest (const StippleShape 2) ;; size stippled fastest ;;**************************************************************** ;;* KEYBOARD/POINTER STUFF ;;**************************************************************** (const AutoRepeatModeOff 0) (const AutoRepeatModeOn 1) (const AutoRepeatModeDefault 2) (const LedModeOff 0) (const LedModeOn 1) ;; masks for ChangeKeyboardControl (const KBKeyClickPercent (expt 2 0)) (const KBBellPercent (expt 2 1)) (const KBBellPitch (expt 2 2)) (const KBBellDuration (expt 2 3)) (const KBLed (expt 2 4)) (const KBLedMode (expt 2 5)) (const KBKey (expt 2 6)) (const KBAutoRepeatMode (expt 2 7)) (const MappingSuccess 0) (const MappingBusy 1) (const MappingFailed 2) (const MappingModifier 0) (const MappingKeyboard 1) (const MappingPointer 2) ;;**************************************************************** ;;* SCREEN SAVER STUFF ;;**************************************************************** (const DontPreferBlanking 0) (const PreferBlanking 1) (const DefaultBlanking 2) (const DisableScreenSaver 0) (const DisableScreenInterval 0) (const DontAllowExposures 0) (const AllowExposures 1) (const DefaultExposures 2) ;; for ForceScreenSaver (const ScreenSaverReset 0) (const ScreenSaverActive 1) ;;**************************************************************** ;;* HOSTS AND CONNECTIONS ;;**************************************************************** ;; for ChangeHosts (const HostInsert 0) (const HostDelete 1) ;; for ChangeAccessControl (const EnableAccess 1) (const DisableAccess 0) ;; Display classes used in opening the connection ;; * Note that the statically allocated ones are even numbered and the ;; * dynamically changeable ones are odd numbered (const StaticGray 0) (const GrayScale 1) (const StaticColor 2) (const PseudoColor 3) (const TrueColor 4) (const DirectColor 5) ;; Byte order used in imageByteOrder and bitmapBitOrder (const LSBFirst 0) (const MSBFirst 1) scheme2c-2012.10.14/xlib/Xatom.cdecl000066400000000000000000000033671203736146400166340ustar00rootroot00000000000000;;; X11 Xatom.h file for use by Scheme->C (const XA_PRIMARY 1) (const XA_SECONDARY 2) (const XA_ARC 3) (const XA_ATOM 4) (const XA_BITMAP 5) (const XA_CARDINAL 6) (const XA_COLORMAP 7) (const XA_CURSOR 8) (const XA_CUT_BUFFER0 9) (const XA_CUT_BUFFER1 10) (const XA_CUT_BUFFER2 11) (const XA_CUT_BUFFER3 12) (const XA_CUT_BUFFER4 13) (const XA_CUT_BUFFER5 14) (const XA_CUT_BUFFER6 15) (const XA_CUT_BUFFER7 16) (const XA_DRAWABLE 17) (const XA_FONT 18) (const XA_INTEGER 19) (const XA_PIXMAP 20) (const XA_POINT 21) (const XA_RECTANGLE 22) (const XA_RESOURCE_MANAGER 23) (const XA_RGB_COLOR_MAP 24) (const XA_RGB_BEST_MAP 25) (const XA_RGB_BLUE_MAP 26) (const XA_RGB_DEFAULT_MAP 27) (const XA_RGB_GRAY_MAP 28) (const XA_RGB_GREEN_MAP 29) (const XA_RGB_RED_MAP 30) (const XA_STRING 31) (const XA_VISUALID 32) (const XA_WINDOW 33) (const XA_WM_COMMAND 34) (const XA_WM_HINTS 35) (const XA_WM_CLIENT_MACHINE 36) (const XA_WM_ICON_NAME 37) (const XA_WM_ICON_SIZE 38) (const XA_WM_NAME 39) (const XA_WM_NORMAL_HINTS 40) (const XA_WM_SIZE_HINTS 41) (const XA_WM_ZOOM_HINTS 42) (const XA_MIN_SPACE 43) (const XA_NORM_SPACE 44) (const XA_MAX_SPACE 45) (const XA_END_SPACE 46) (const XA_SUPERSCRIPT_X 47) (const XA_SUPERSCRIPT_Y 48) (const XA_SUBSCRIPT_X 49) (const XA_SUBSCRIPT_Y 50) (const XA_UNDERLINE_POSITION 51) (const XA_UNDERLINE_THICKNESS 52) (const XA_STRIKEOUT_ASCENT 53) (const XA_STRIKEOUT_DESCENT 54) (const XA_ITALIC_ANGLE 55) (const XA_X_HEIGHT 56) (const XA_QUAD_WIDTH 57) (const XA_WEIGHT 58) (const XA_POINT_SIZE 59) (const XA_RESOLUTION 60) (const XA_COPYRIGHT 61) (const XA_NOTICE 62) (const XA_FONT_NAME 63) (const XA_FAMILY_NAME 64) (const XA_FULL_NAME 65) (const XA_CAP_HEIGHT 66) (const XA_WM_CLASS 67) (const XA_WM_TRANSIENT_FOR 68) (const XA_LAST_PREDEFINED 68) scheme2c-2012.10.14/xlib/Xcursorfont.cdecl000066400000000000000000000037731203736146400201010ustar00rootroot00000000000000;;; /* $Header: Xcursorfont.cdecl,v 1.1 92/12/28 13:29:14 bartlett Locked $ */ (const XC_num_glyphs 154) (const XC_X_cursor 0) (const XC_arrow 2) (const XC_based_arrow_down 4) (const XC_based_arrow_up 6) (const XC_boat 8) (const XC_bogosity 10) (const XC_bottom_left_corner 12) (const XC_bottom_right_corner 14) (const XC_bottom_side 16) (const XC_bottom_tee 18) (const XC_box_spiral 20) (const XC_center_ptr 22) (const XC_circle 24) (const XC_clock 26) (const XC_coffee_mug 28) (const XC_cross 30) (const XC_cross_reverse 32) (const XC_crosshair 34) (const XC_diamond_cross 36) (const XC_dot 38) (const XC_dotbox 40) (const XC_double_arrow 42) (const XC_draft_large 44) (const XC_draft_small 46) (const XC_draped_box 48) (const XC_exchange 50) (const XC_fleur 52) (const XC_gobbler 54) (const XC_gumby 56) (const XC_hand1 58) (const XC_hand2 60) (const XC_heart 62) (const XC_icon 64) (const XC_iron_cross 66) (const XC_left_ptr 68) (const XC_left_side 70) (const XC_left_tee 72) (const XC_leftbutton 74) (const XC_ll_angle 76) (const XC_lr_angle 78) (const XC_man 80) (const XC_middlebutton 82) (const XC_mouse 84) (const XC_pencil 86) (const XC_pirate 88) (const XC_plus 90) (const XC_question_arrow 92) (const XC_right_ptr 94) (const XC_right_side 96) (const XC_right_tee 98) (const XC_rightbutton 100) (const XC_rtl_logo 102) (const XC_sailboat 104) (const XC_sb_down_arrow 106) (const XC_sb_h_double_arrow 108) (const XC_sb_left_arrow 110) (const XC_sb_right_arrow 112) (const XC_sb_up_arrow 114) (const XC_sb_v_double_arrow 116) (const XC_shuttle 118) (const XC_sizing 120) (const XC_spider 122) (const XC_spraycan 124) (const XC_star 126) (const XC_target 128) (const XC_tcross 130) (const XC_top_left_arrow 132) (const XC_top_left_corner 134) (const XC_top_right_corner 136) (const XC_top_side 138) (const XC_top_tee 140) (const XC_trek 142) (const XC_ul_angle 144) (const XC_umbrella 146) (const XC_ur_angle 148) (const XC_watch 150) (const XC_xterm 152) scheme2c-2012.10.14/xlib/Xkeysym.cdecl000066400000000000000000000335161203736146400172140ustar00rootroot00000000000000; Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ; and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ; ; All Rights Reserved ; ; Permission to use, copy, modify, and distribute this software and its ; documentation for any purpose and without fee is hereby granted, ; provided that the above copyright notice appear in all copies and that ; both that copyright notice and this permission notice appear in ; supporting documentation, and that the names of Digital or MIT not be ; used in advertising or publicity pertaining to distribution of the ; software without specific, written prior permission. ; ; DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ; DIGITAL BE LIABLE FOR ANY SPECIAL, 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. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; N.B. Contains XK_MISCELLANY,XK_LATIN1, and DXK_PRIVATE ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;* ;* TTY Functions, cleverly chosen to map to ascii, for convenience of ;* programming, but could have been arbitrary (at the cost of lookup ;* tables in client code. ;* (const XK_BackSpace #xFF08) ;; back space, back char (const XK_Tab #xFF09) (const XK_Linefeed #xFF0A) ;; Linefeed, LF (const XK_Clear #xFF0B) (const XK_Return #xFF0D) ;; Return, enter (const XK_Pause #xFF13) ;; Pause, hold, scroll lock (const XK_Escape #xFF1B) (const XK_Delete #xFFFF) ;; Delete, rubout ;; International & multi-key character composition (const XK_Multi_key #xFF20) ;; Multi-key character compose (const XK_Kanji #xFF21) ;; Kanji, Kanji convert ;; Cursor control & motion (const XK_Home #xFF50) (const XK_Left #xFF51) ;; Move left, left arrow (const XK_Up #xFF52) ;; Move up, up arrow (const XK_Right #xFF53) ;; Move right, right arrow (const XK_Down #xFF54) ;; Move down, down arrow (const XK_Prior #xFF55) ;; Prior, previous (const XK_Next #xFF56) ;; Next (const XK_End #xFF57) ;; EOL (const XK_Begin #xFF58) ;; BOL ;; Misc Functions (const XK_Select #xFF60) ;; Select, mark (const XK_Print #xFF61) (const XK_Execute #xFF62) ;; Execute, run, do (const XK_Insert #xFF63) ;; Insert, insert here (const XK_Undo #xFF65) ;; Undo, oops (const XK_Redo #xFF66) ;; redo, again (const XK_Menu #xFF67) (const XK_Find #xFF68) ;; Find, search (const XK_Cancel #xFF69) ;; Cancel, stop, abort, exit (const XK_Help #xFF6A) ;; Help, ? (const XK_Break #xFF6B) (const XK_Mode_switch #xFF7E) ;; Character set switch (const XK_script_switch #xFF7E) ;; Alias for mode_switch (const XK_Num_Lock #xFF7F) ;; Keypad Functions, keypad numbers cleverly chosen to map to ascii (const XK_KP_Space #xFF80) ;; space (const XK_KP_Tab #xFF89) (const XK_KP_Enter #xFF8D) ;; enter (const XK_KP_F1 #xFF91) ;; PF1, KP_A, ... (const XK_KP_F2 #xFF92) (const XK_KP_F3 #xFF93) (const XK_KP_F4 #xFF94) (const XK_KP_Equal #xFFBD) ;; equals (const XK_KP_Multiply #xFFAA) (const XK_KP_Add #xFFAB) (const XK_KP_Separator #xFFAC) ;; separator, often comma (const XK_KP_Subtract #xFFAD) (const XK_KP_Decimal #xFFAE) (const XK_KP_Divide #xFFAF) (const XK_KP_0 #xFFB0) (const XK_KP_1 #xFFB1) (const XK_KP_2 #xFFB2) (const XK_KP_3 #xFFB3) (const XK_KP_4 #xFFB4) (const XK_KP_5 #xFFB5) (const XK_KP_6 #xFFB6) (const XK_KP_7 #xFFB7) (const XK_KP_8 #xFFB8) (const XK_KP_9 #xFFB9) ;* ;* Auxilliary Functions; note the duplicate definitions for left and right ;* function keys; Sun keyboards and a few other manufactures have such ;* function key groups on the left and/or right sides of the keyboard. ;* We've not found a keyboard with more than 35 function keys total. ;* (const XK_F1 #xFFBE) (const XK_F2 #xFFBF) (const XK_F3 #xFFC0) (const XK_F4 #xFFC1) (const XK_F5 #xFFC2) (const XK_F6 #xFFC3) (const XK_F7 #xFFC4) (const XK_F8 #xFFC5) (const XK_F9 #xFFC6) (const XK_F10 #xFFC7) (const XK_F11 #xFFC8) (const XK_L1 #xFFC8) (const XK_F12 #xFFC9) (const XK_L2 #xFFC9) (const XK_F13 #xFFCA) (const XK_L3 #xFFCA) (const XK_F14 #xFFCB) (const XK_L4 #xFFCB) (const XK_F15 #xFFCC) (const XK_L5 #xFFCC) (const XK_F16 #xFFCD) (const XK_L6 #xFFCD) (const XK_F17 #xFFCE) (const XK_L7 #xFFCE) (const XK_F18 #xFFCF) (const XK_L8 #xFFCF) (const XK_F19 #xFFD0) (const XK_L9 #xFFD0) (const XK_F20 #xFFD1) (const XK_L10 #xFFD1) (const XK_F21 #xFFD2) (const XK_R1 #xFFD2) (const XK_F22 #xFFD3) (const XK_R2 #xFFD3) (const XK_F23 #xFFD4) (const XK_R3 #xFFD4) (const XK_F24 #xFFD5) (const XK_R4 #xFFD5) (const XK_F25 #xFFD6) (const XK_R5 #xFFD6) (const XK_F26 #xFFD7) (const XK_R6 #xFFD7) (const XK_F27 #xFFD8) (const XK_R7 #xFFD8) (const XK_F28 #xFFD9) (const XK_R8 #xFFD9) (const XK_F29 #xFFDA) (const XK_R9 #xFFDA) (const XK_F30 #xFFDB) (const XK_R10 #xFFDB) (const XK_F31 #xFFDC) (const XK_R11 #xFFDC) (const XK_F32 #xFFDD) (const XK_R12 #xFFDD) (const XK_R13 #xFFDE) (const XK_F33 #xFFDE) (const XK_F34 #xFFDF) (const XK_R14 #xFFDF) (const XK_F35 #xFFE0) (const XK_R15 #xFFE0) ;; Modifiers (const XK_Shift_L #xFFE1) ;; Left shift (const XK_Shift_R #xFFE2) ;; Right shift (const XK_Control_L #xFFE3) ;; Left control (const XK_Control_R #xFFE4) ;; Right control (const XK_Caps_Lock #xFFE5) ;; Caps lock (const XK_Shift_Lock #xFFE6) ;; Shift lock (const XK_Meta_L #xFFE7) ;; Left meta (const XK_Meta_R #xFFE8) ;; Right meta (const XK_Alt_L #xFFE9) ;; Left alt (const XK_Alt_R #xFFEA) ;; Right alt (const XK_Super_L #xFFEB) ;; Left super (const XK_Super_R #xFFEC) ;; Right super (const XK_Hyper_L #xFFED) ;; Left hyper (const XK_Hyper_R #xFFEE) ;; Right hyper ;* ;* Latin 1 ;* Byte 3 = 0 ;* (const XK_space #x020) (const XK_exclam #x021) (const XK_quotedbl #x022) (const XK_numbersign #x023) (const XK_dollar #x024) (const XK_percent #x025) (const XK_ampersand #x026) (const XK_quoteright #x027) (const XK_parenleft #x028) (const XK_parenright #x029) (const XK_asterisk #x02a) (const XK_plus #x02b) (const XK_comma #x02c) (const XK_minus #x02d) (const XK_period #x02e) (const XK_slash #x02f) (const XK_0 #x030) (const XK_1 #x031) (const XK_2 #x032) (const XK_3 #x033) (const XK_4 #x034) (const XK_5 #x035) (const XK_6 #x036) (const XK_7 #x037) (const XK_8 #x038) (const XK_9 #x039) (const XK_colon #x03a) (const XK_semicolon #x03b) (const XK_less #x03c) (const XK_equal #x03d) (const XK_greater #x03e) (const XK_question #x03f) (const XK_at #x040) (const XK_A #x041) (const XK_B #x042) (const XK_C #x043) (const XK_D #x044) (const XK_E #x045) (const XK_F #x046) (const XK_G #x047) (const XK_H #x048) (const XK_I #x049) (const XK_J #x04a) (const XK_K #x04b) (const XK_L #x04c) (const XK_M #x04d) (const XK_N #x04e) (const XK_O #x04f) (const XK_P #x050) (const XK_Q #x051) (const XK_R #x052) (const XK_S #x053) (const XK_T #x054) (const XK_U #x055) (const XK_V #x056) (const XK_W #x057) (const XK_X #x058) (const XK_Y #x059) (const XK_Z #x05a) (const XK_bracketleft #x05b) (const XK_backslash #x05c) (const XK_bracketright #x05d) (const XK_asciicircum #x05e) (const XK_underscore #x05f) (const XK_quoteleft #x060) (const XK_lca #x061) (const XK_lcb #x062) (const XK_lcc #x063) (const XK_lcd #x064) (const XK_lce #x065) (const XK_lcf #x066) (const XK_lcg #x067) (const XK_lch #x068) (const XK_lci #x069) (const XK_lcj #x06a) (const XK_lck #x06b) (const XK_lcl #x06c) (const XK_lcm #x06d) (const XK_lcn #x06e) (const XK_lco #x06f) (const XK_lcp #x070) (const XK_lcq #x071) (const XK_lcr #x072) (const XK_lcs #x073) (const XK_lct #x074) (const XK_lcu #x075) (const XK_lcv #x076) (const XK_lcw #x077) (const XK_lcx #x078) (const XK_lcy #x079) (const XK_lcz #x07a) (const XK_braceleft #x07b) (const XK_bar #x07c) (const XK_braceright #x07d) (const XK_asciitilde #x07e) (const XK_nobreakspace #x0a0) (const XK_exclamdown #x0a1) (const XK_cent #x0a2) (const XK_sterling #x0a3) (const XK_currency #x0a4) (const XK_yen #x0a5) (const XK_brokenbar #x0a6) (const XK_section #x0a7) (const XK_diaeresis #x0a8) (const XK_copyright #x0a9) (const XK_ordfeminine #x0aa) (const XK_guillemotleft #x0ab) ;; left angle quotation mark (const XK_notsign #x0ac) (const XK_hyphen #x0ad) (const XK_registered #x0ae) (const XK_macron #x0af) (const XK_degree #x0b0) (const XK_plusminus #x0b1) (const XK_twosuperior #x0b2) (const XK_threesuperior #x0b3) (const XK_acute #x0b4) (const XK_mu #x0b5) (const XK_paragraph #x0b6) (const XK_periodcentered #x0b7) (const XK_cedilla #x0b8) (const XK_onesuperior #x0b9) (const XK_masculine #x0ba) (const XK_guillemotright #x0bb) ;; right angle quotation mark (const XK_onequarter #x0bc) (const XK_onehalf #x0bd) (const XK_threequarters #x0be) (const XK_questiondown #x0bf) (const XK_Agrave #x0c0) (const XK_Aacute #x0c1) (const XK_Acircumflex #x0c2) (const XK_Atilde #x0c3) (const XK_Adiaeresis #x0c4) (const XK_Aring #x0c5) (const XK_AE #x0c6) (const XK_Ccedilla #x0c7) (const XK_Egrave #x0c8) (const XK_Eacute #x0c9) (const XK_Ecircumflex #x0ca) (const XK_Ediaeresis #x0cb) (const XK_Igrave #x0cc) (const XK_Iacute #x0cd) (const XK_Icircumflex #x0ce) (const XK_Idiaeresis #x0cf) (const XK_Eth #x0d0) (const XK_Ntilde #x0d1) (const XK_Ograve #x0d2) (const XK_Oacute #x0d3) (const XK_Ocircumflex #x0d4) (const XK_Otilde #x0d5) (const XK_Odiaeresis #x0d6) (const XK_multiply #x0d7) (const XK_Ooblique #x0d8) (const XK_Ugrave #x0d9) (const XK_Uacute #x0da) (const XK_Ucircumflex #x0db) (const XK_Udiaeresis #x0dc) (const XK_Yacute #x0dd) (const XK_Thorn #x0de) (const XK_ssharp #x0df) (const XK_lcagrave #x0e0) (const XK_lcaacute #x0e1) (const XK_lcacircumflex #x0e2) (const XK_lcatilde #x0e3) (const XK_lcadiaeresis #x0e4) (const XK_lcaring #x0e5) (const XK_lcae #x0e6) (const XK_lcccedilla #x0e7) (const XK_lcegrave #x0e8) (const XK_lceacute #x0e9) (const XK_lcecircumflex #x0ea) (const XK_lcediaeresis #x0eb) (const XK_lcigrave #x0ec) (const XK_lciacute #x0ed) (const XK_lcicircumflex #x0ee) (const XK_lcidiaeresis #x0ef) (const XK_lceth #x0f0) (const XK_lcntilde #x0f1) (const XK_lcograve #x0f2) (const XK_lcoacute #x0f3) (const XK_lcocircumflex #x0f4) (const XK_lcotilde #x0f5) (const XK_lcodiaeresis #x0f6) (const XK_division #x0f7) (const XK_oslash #x0f8) (const XK_lcugrave #x0f9) (const XK_lcuacute #x0fa) (const XK_lcucircumflex #x0fb) (const XK_lcudiaeresis #x0fc) (const XK_lcyacute #x0fd) (const XK_lcthorn #x0fe) (const XK_ydiaeresis #x0ff) ;* ;* DEC private keysyms ;* (29th bit set) ;* ;* two-key compose sequence initiators, chosen to map to Latin1 characters (const DXK_ring_accent #x1000FEB0) (const DXK_circumflex_accent #x1000FE5E) (const DXK_cedilla_accent #x1000FE2C) (const DXK_acute_accent #x1000FE27) (const DXK_grave_accent #x1000FE60) (const DXK_tilde #x1000FE7E) (const DXK_diaeresis #x1000FE22) ;* special keysym for LK2** "Remove" key on editing keypad (const DXK_Remove #x1000FF00) scheme2c-2012.10.14/xlib/Xlib.cdecl000066400000000000000000000733351203736146400164440ustar00rootroot00000000000000;; C declaration file for /usr/include/X11/Xlib.h ; Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ; and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ; ; All Rights Reserved ; ; Permission to use, copy, modify, and distribute this software and its ; documentation for any purpose and without fee is hereby granted, ; provided that the above copyright notice appear in all copies and that ; both that copyright notice and this permission notice appear in ; supporting documentation, and that the names of Digital or MIT not be ; used in advertising or publicity pertaining to distribution of the ; software without specific, written prior permission. ; ; DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ; DIGITAL BE LIABLE FOR ANY SPECIAL, 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. ; * Xlib.h - Header definition and support file for the C subroutine ; * interface library (Xlib) to the X Window System Protocol (V11). ; * Structures and symbols starting with "_" are private to the library. (const QueuedAlready 0) (const QueuedAfterReading 1) (const QueuedAfterFlush 2) (const AllPlanes -1) (typedef int Bool) (typedef (Bool *proc) BoolPROC) (typedef int Status) ; * Extensions need a way to hang private data on some structures. (typedef (struct) XExtData) (typedef (XExtData *) XExtDataP) ; * Data structure for setting graphics context. (typedef (struct (int function) ;; logical operation (unsignedlong plane_mask) ;; plane mask (unsignedlong foreground) ;; foreground pixel (unsignedlong background) ;; background pixel (int line_width) ;; line width (int line_style) ;; LineSolid, LineOnOffDash, LineDoubleDash (int cap_style) ;; CapNotLast, CapButt, ;; CapRound, CapProjecting (int join_style) ;; JoinMiter, JoinRound, JoinBevel (int fill_style) ;; FillSolid, FillTiled, ;; FillStippled, FillOpaeueStippled (int fill_rule) ;; EvenOddRule, WindingRule (int arc_mode) ;; ArcChord, ArcPieSlice (Pixmap tile) ;; tile pixmap for tiling operations (Pixmap stipple) ;; stipple 1 plane pixmap for stipping (int ts_x_origin) ;; offset for tile or stipple operations (int ts_y_origin) (Font font) ;; default text font for text operations (int subwindow_mode) ;; ClipByChildren, IncludeInferiors (int graphics_exposures) ;; boolean, should exposures be generated (int clip_x_origin) ;; origin for clipping (int clip_y_origin) (Pixmap clip_mask) ;; bitmap clipping; other calls for rects (int dash_offset) ;; patterned/dashed line information (char dashes) ) XGCValues) (typedef (XGCValues *) XGCValuesP) ; * Graphics context. All Xlib routines deal in this rather than ; * in raw protocol GContext ID's. This is so that the library can keep ; * a "shadow" set of values, and thus avoid passing values over the ; * wire which are not in fact changing. (typedef (struct) _XGC) (typedef (_XGC *) GC) ; * Visual structure; contains information about colormapping possible. (typedef (struct (XExtDataP ext_data) ;; hook for extension to hang data (VisualID visualid) ;; visual id of this visual (int class) ;; class of screen (monochrome, etc.) (unsignedlong red_mask) ;; mask values (unsignedlong green_mask) (unsignedlong blue_mask) (int bits_per_rgb) ;; log base 2 of distinct color values (int map_entries) ;; color map entries ) Visual) (typedef (Visual *) VisualP) ; * Depth structure; contains information for each possible depth. (typedef (struct (int depth) ;; this depth (Z) of the depth (int nvisuals) ;; number of Visual types at this depth (VisualP visuals) ;; list of visuals possible at this depth ) Depth) (typedef (Depth *) DepthP) ; * Information about the screen. (typedef (struct (XExtDataP ext_data) ;; hook for extension to hang data (DisplayP display) ;; back pointer to display structure (Window root) ;; Root window id. (int width) ;; width and height of screen (int height) (int mwidth) ;; width and height of in millimeters (int mheight) (int ndepths) ;; number of depths possible (DepthP depths) ;; list of allowable depths on the screen (int root_depth) ;; bits per pixel (VisualP root_visual);; root visual (GC default_gc) ;; GC for the root root visual (Colormap cmap) ;; default color map (unsignedlong white_pixel) (unsignedlong black_pixel) ;; White and Black pixel values (int max_maps) (int min_maps) ;; max and min color maps (int backing_store) ;; Never, WhenMapped, Always (int save_unders) (long root_input_mask) ;; initial root input mask ) Screen) (typedef (Screen *) ScreenP) ; * Format structure; describes ZFormat data the screen will understand. (typedef (struct (XExtDataP ext_data) ;; hook for extension to hang data (int depth) ;; depth of this image format (int bits_per_pixel) ;; bits/pixel at this depth (int scanline_pad) ;; scanline must padded to this multiple ) ScreenFormat) (define-only ScreenFormat) ; * Data structure for setting window attributes. (typedef (struct (Pixmap background_pixmap) ;; background or None or ParentRelative (unsignedlong background_pixel) ;; background pixel (Pixmap border_pixmap) ;; border of the window (unsignedlong border_pixel) ;; border pixel value (int bit_gravity) ;; one of bit gravity values (int win_gravity) ;; one of the window gravity values (int backing_store) ;; NotUseful, WhenMapped, Always (unsignedlong backing_planes);;; planes to be preseved if possible (unsignedlong backing_pixel);;; value to use in restoring planes (int save_under) ;; should bits under be saved? (popups) (long event_mask) ;; set of events that should be saved (long do_not_propagate_mask);; set of events that should not propagate (int override_redirect) ;; boolean value for override-redirect (Colormap colormap) ;; color map to be associated with window (Cursor cursor) ;; cursor to be displayed (or None) ) XSetWindowAttributes) (typedef (XSetWindowAttributes *) XSetWindowAttributesP) (typedef (struct (int x) (int y) ;; location of window (int width) (int height) ;; width and height of window (int border_width) ;; border width of window (int depth) ;; depth of window (VisualP visual) ;; the associated visual structure (Window root) ;; root of screen containing window (int class) ;; InputOutput, InputOnly (int bit_gravity) ;; one of bit gravity values (int win_gravity) ;; one of the window gravity values (int backing_store) ;; NotUseful, WhenMapped, Always (unsignedlong backing_planes);; planes to be preserved if possible (unsignedlong backing_pixel);; value to be used when restoring planes (int save_under) ;; boolean, should bits under be saved? (Colormap colormap) ;; color map to be associated with window (int map_installed) ;; boolean, is color map currently installed (int map_state) ;; IsUnmapped, IsUnviewable, IsViewable (long all_event_masks) ;; set of events all people have interest in (long your_event_mask) ;; my event mask (long do_not_propagate_mask) ;; set of events that should not propagate (int override_redirect) ;; boolean value for override-redirect (ScreenP screen) ;; back pointer to correct screen ) XWindowAttributes) (typedef (XWindowAttributes *) XWindowAttributesP) ; * Data structure for host setting; getting routines. (typedef (struct (int family) ;; for example AF_DNET (int length) ;; length of address, in bytes (charP address) ;; pointer to where to find the bytes ) XHostAddress) (typedef (XHostAddress *) XHostAddressP) (typedef (XHostAddress 0) XHostAddressA) (typedef (XHostAddressA *) XHostAddressAP) ; * Data structure for "image" data, used by image manipulation routines. (typedef (struct (int width) ;; size of image (int height) (int xoffset) ;; number of pixels offset in X direction (int format) ;; XYBitmap, XYPixmap, ZPixmap (charAP data) ;; pointer to image data (int byte_order) ;; data byte order, LSBFirst, MSBFirst (int bitmap_unit) ;; quant. of scanline 8, 16, 32 (int bitmap_bit_order) ;; LSBFirst, MSBFirst (int bitmap_pad) ;; 8, 16, 32 either XY or ZPixmap (int depth) ;; depth of image (int bytes_per_line) ;; accelarator to next line (int bits_per_pixel) ;; bits per pixel (ZPixmap) (unsignedlong red_mask) ;; bits in z arrangment (unsignedlong green_mask) (unsignedlong blue_mask) (charP obdata) ;; hook for the object routines to hang on ((struct ;; image manipulation routines (XImagePROC create_image) (intPROC destroy_image) (unsignedlongPROC get_pixel) (intPROC put_pixel) (XImagePROC sub_image) (intPROC add_pixel)) f) ) XImage) (typedef (XImage *) XImageP) (typedef (XImage *proc) XImagePROC) ; * Data structure for XReconfigureWindow (typedef (struct (int x) (int y) (int width) (int height) (int border_width) (Window sibling) (int stack_mode) ) XWindowChanges) (typedef (XWindowChanges *) XWindowChangesP) ; * Data structure used by color operations (typedef (struct (unsignedlong pixel) (unsignedshort red) (unsignedshort green) (unsignedshort blue) (char flags) ;; do_red, do_green, do_blue (char pad) ) XColor) (typedef (XColor *) XColorP) (typedef (XColor 0) XColorA) (typedef (XColorA *) XColorAP) ; * Data structures for graphics operations. On most machines, these are ; * congruent with the wire protocol structures, so reformatting the data ; * can be avoided on these architectures. (typedef (struct (short x1) (short y1) (short x2) (short y2) ) XSegment) (typedef (XSegment *) XSegmentP) (typedef (XSegment 0) XSegmentA) (typedef (XSegmentA *) XSegmentAP) (typedef (struct (short x) (short y) ) XPoint) (typedef (XPoint *) XPointP) (typedef (XPoint 0) XPointA) (typedef (XPointA *) XPointAP) (typedef (struct (short x) (short y) (unsignedshort width) (unsignedshort height) ) XRectangle) (typedef (XRectangle *) XRectangleP) (typedef (XRectangle 0) XRectangleA) (typedef (XRectangleA *) XRectangleAP) (typedef (struct (short x) (short y) (unsignedshort width) (unsignedshort height) (short angle1) (short angle2) ) XArc) (typedef (XArc *) XArcP) (typedef (XArc 0) XArcA) (typedef (XArcA *) XArcAP) ;; Data structure for XChangeKeyboardControl (typedef (struct (int key_click_percent) (int bell_percent) (int bell_pitch) (int bell_duration) (int led) (int led_mode) (int key) (int auto_repeat_mode) ;; On, Off, Default ) XKeyboardControl) (typedef (XKeyboardControl *) XKeyboardControlP) ;; Data structure for XGetKeyboardControl (typedef (struct (int key_click_percent) (int bell_percent) (unsignedint bell_pitch) (unsignedint bell_duration) (unsignedlong led_mask) (int global_auto_repeat) ((char 32) auto_repeats) ) XKeyboardState) (typedef (XKeyboardState *) XKeyboardStateP) ;; Data structure returned by XQueryKeymap. (typedef (char 32) XQKeymap) (typedef (XQKeymap *) XQKeymapP) ;; Data structure for XGetMotionEvents. (typedef (struct (Time time) (short x) (short y) ) XTimeCoord) (typedef (XTimeCoord *) XTimeCoordP) (typedef (XTimeCoord 0) XTimeCoordA) (typedef (XTimeCoordA *) XTimeCoordAP) ;; Data structure for X{Set,Get}ModifierMapping (typedef (struct (int max_keypermod) ;; The server's max # of keys per modifier (KeyCode *modifiermap) ;; An 8 by max_keypermod array of modifiers ) XModifierKeymap) (typedef (XModifierKeymap *) XModifierKeymapP) (typedef (XModifierKeymap *proc) XNewModifiermap) (typedef (XModifierKeymap *proc) XGetModifierMapping) (typedef (XModifierKeymap *proc) XDeleteModifiermapEntry) (typedef (XModifierKeymap *proc) XInsertModifiermapEntry) (typedef (struct (intPROC proc) (unsignedlongP data) ) EventsData) ; * Display datatype maintaining display specific data. N.B. Structure is ; * internal to Xlib. (typedef (struct) Display) (typedef (Display *) DisplayP) ; * A "XEvent" structure always has type as the first entry. This ; * uniquely identifies what kind of event it is. The second entry ; * is always a pointer to the display the event was read from. ; * The third entry is always a window of one type or another, ; * carefully selected to be useful to toolkit dispatchers. (Except ; * for keymap events, which have no window.) You ; * must not change the order of the three elements or toolkits will ; * break! The pointer to the generic event must be cast before use to ; * access any other information in the structure. ; * Definitions of specific events. (typedef (struct (int type) ;; of event (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) ;; "event" window it is reported relative to (Window root) ;; root window that the event occured on (Window subwindow) ;; child window (Time time) ;; milliseconds (int x) (int y) ;; pointer x, y coordinates in event window (int x_root) (int y_root) ;; coordinates relative to root (unsignedint state) ;; key or button mask (unsignedint keycode) ;; detail (int same_screen) ;; same screen flag ) XKeyEvent) ; (typedef XKeyEvent XKeyPressedEvent) ; (typedef XKeyEvent XKeyReleasedEvent) (typedef (struct (int type) ;; of event (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) ;; "event" window it is reported relative to (Window root) ;; root window that the event occured on (Window subwindow) ;; child window (Time time) ;; milliseconds (int x) (int y) ;; pointer x, y coordinates in event window (int x_root) (int y_root) ;; coordinates relative to root (unsignedint state) ;; key or button mask (unsignedint button) ;; detail (int same_screen) ;; same screen flag ) XButtonEvent) ; (typedef XButtonEvent XButtonPressedEvent) ; (typedef XButtonEvent XButtonReleasedEvent) (typedef (struct (int type) ;; of event (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) ;; "event" window reported relative to (Window root) ;; root window that the event occured on (Window subwindow) ;; child window (Time time) ;; milliseconds (int x) (int y) ;; pointer x, y coordinates in event window (int x_root) (int y_root) ;; coordinates relative to root (unsignedint state) ;; key or button mask (char is_hint) ;; detail (int same_screen) ;; same screen flag ) XMotionEvent) ; (typedef XMotionEvent XPointerMovedEvent) (typedef (struct (int type) ;; of event (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) ;; "event" window reported relative to (Window root) ;; root window that the event occured on (Window subwindow) ;; child window (Time time) ;; milliseconds (int x) (int y) ;; pointer x, y coordinates in event window (int x_root) (int y_root) ;; coordinates relative to root (int mode) ;; NotifyNormal, NotifyGrab, NotifyUngrab (int detail) ; * NotifyAncestor, NotifyVirtual, NotifyInferior, ; * NotifyNonLinear,NotifyNonLinearVirtual (int same_screen) ;; same screen flag (int focus) ;; boolean focus (unsignedint state) ;; key or button mask ) XCrossingEvent) ; (typedef XCrossingEvent XEnterWindowEvent) ; (typedef XCrossingEvent XLeaveWindowEvent) (typedef (struct (int type) ;; FocusIn or FocusOut (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) ;; window of event (int mode) ;; NotifyNormal, NotifyGrab, NotifyUngrab (int detail) ;* NotifyAncestor, NotifyVirtual, NotifyInferior, ;* NotifyNonLinear,NotifyNonLinearVirtual, NotifyPointer, ;* NotifyPointerRoot, NotifyDetailNone ) XFocusChangeEvent) ; (typedef XFocusChangeEvent XFocusInEvent) ; (typedef XFocusChangeEvent XFocusOutEvent) ; * generated on EnterWindow and FocusIn when KeyMapState selected (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) ((char 32) key_vector) ) XKeymapEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) (int x) (int y) (int width) (int height) (int count) ;; if non-zero, at least this many more ) XExposeEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Drawable drawable) (int x) (int y) (int width) (int height) (int count) ;; if non-zero, at least this many more (int major_code) ;; core is CopyArea or CopyPlane (int minor_code) ;; not defined in the core ) XGraphicsExposeEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Drawable drawable) (int major_code) ;; core is CopyArea or CopyPlane (int minor_code) ;; not defined in the core ) XNoExposeEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) (int state) ;; either Obscured or UnObscured ) XVisibilityEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window parent) ;; parent of the window (Window window) ;; window id of window created (int x) (int y) ;; window location (int width) (int height) ;; size of window (int border_width) ;; border width (int override_redirect) ;; creation should be overridden ) XCreateWindowEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window event) (Window window) ) XDestroyWindowEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window event) (Window window) (int from_configure) ) XUnmapEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window event) (Window window) (int override_redirect) ;; boolean, is override set... ) XMapEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window parent) (Window window) ) XMapRequestEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window event) (Window window) (Window parent) (int x) (int y) (int override_redirect) ) XReparentEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window event) (Window window) (int x) (int y) (int width) (int height) (int border_width) (Window above) (int override_redirect) ) XConfigureEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window event) (Window window) (int x) (int y) ) XGravityEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) (int width) (int height) ) XResizeRequestEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window parent) (Window window) (int x) (int y) (int width) (int height) (int border_width) (Window above) (int detail) ;; Above, Below, TopIf, BottomIf, Opposite (unsignedlong value_mask) ) XConfigureRequestEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window event) (Window window) (int place) ;; PlaceOnTop, PlaceOnBottom ) XCirculateEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window parent) (Window window) (int place) ;; PlaceOnTop, PlaceOnBottom ) XCirculateRequestEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) (Atom atom) (Time time) (int state) ;; NewValue, Deleted ) XPropertyEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) (Atom selection) (Time time) ) XSelectionClearEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window owner) ;; must be next after type (Window requestor) (Atom selection) (Atom target) (Atom property) (Time time) ) XSelectionRequestEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window requestor) ;; must be next after type (Atom selection) (Atom target) (Atom property) ;; ATOM or None (Time time) ) XSelectionEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) (Colormap colormap) ;; COLORMAP or None (int new) (int state) ;; ColormapInstalled, ColormapUninstalled ) XColormapEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) (Atom message_type) (int format) ((union ((char 20) b) ((short 10) s) ((long 5) l)) data) ) XClientMessageEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display) ;; Display the event was read from (Window window) ;; unused (int request) ;; one of MappingModifier, MappingKeyboard, ;; MappingPointer (int first_keycode) ;; first keycode (int count) ;; defines range of change w. first_keycode ) XMappingEvent) (typedef (struct (int type) (DisplayP display) ;; Display the event was read from (XID resourceid) ;; resource id (int serial) ;; serial number of failed request (unsignedchar error_code) ;; error code of failed request (unsignedchar request_code) ;; Major op-code of failed request (unsignedchar minor_code) ;; Minor op-code of failed request ) XErrorEvent) (typedef (struct (int type) (unsignedlong serial) ;; # of last request processed by server (int send_event) ;; true if this came from a SendEvent request (DisplayP display);; Display the event was read from (Window window) ;; window on which event was requested in event mask ) XAnyEvent) ; * this union is defined so Xlib can always use the same sized ; * event structure internally, to avoid memory fragmentation. (typedef (union (int type) ;; must not be changed; first element (XAnyEvent xany) (XKeyEvent xkey) (XButtonEvent xbutton) (XMotionEvent xmotion) (XCrossingEvent xcrossing) (XFocusChangeEvent xfocus) (XExposeEvent xexpose) (XGraphicsExposeEvent xgraphicsexpose) (XNoExposeEvent xnoexpose) (XVisibilityEvent xvisibility) (XCreateWindowEvent xcreatewindow) (XDestroyWindowEvent xdestroywindow) (XUnmapEvent xunmap) (XMapEvent xmap) (XMapRequestEvent xmaprequest) (XReparentEvent xreparent) (XConfigureEvent xconfigure) (XGravityEvent xgravity) (XResizeRequestEvent xresizerequest) (XConfigureRequestEvent xconfigurerequest) (XCirculateEvent xcirculate) (XCirculateRequestEvent xcirculaterequest) (XPropertyEvent xproperty) (XSelectionClearEvent xselectionclear) (XSelectionRequestEvent xselectionrequest) (XSelectionEvent xselection) (XColormapEvent xcolormap) (XClientMessageEvent xclient) (XMappingEvent xmapping) (XErrorEvent xerror) (XKeymapEvent xkeymap) ((long 24) pad) ) XEvent) (typedef (XEvent *) XEventP) (read-only XEvent) (define-only XAnyEvent XKeyEvent XButtonEvent XMotionEvent XCrossingEvent XFocusChangeEvent XExposeEvent XGraphicsExposeEvent XNoExposeEvent XVisibilityEvent XCreateWindowEvent XDestroyWindowEvent XUnmapEvent XMapEvent XMapRequestEvent XReparentEvent XConfigureEvent XGravityEvent XResizeRequestEvent XConfigureRequestEvent XCirculateEvent XCirculateRequestEvent XPropertyEvent XSelectionClearEvent XSelectionRequestEvent XSelectionEvent XColormapEvent XClientMessageEvent XMappingEvent XErrorEvent XKeymapEvent) ; * per character font metric information. (typedef (struct (short lbearing) ;; origin to left edge of raster (short rbearing) ;; origin to right edge of raster (short width) ;; advance to next char's origin (short ascent) ;; baseline to top edge of raster (short descent) ;; baseline to bottom edge of raster (unsignedshort attributes) ;; per char flags (not predefined) ) XCharStruct) (typedef (XCharStruct *) XCharStructP) ; * To allow arbitrary information with fonts, there are additional properties ; * returned. (typedef (struct (Atom name) (unsignedlong card32) ) XFontProp) (typedef (XFontProp *) XFontPropP) (typedef (struct (XExtDataP ext_data) ;; hook for extension to hang data (Font fid) ;; Font id for this font (unsigned direction) ;; hint about direction the font is painted (unsigned min_char_or_byte2);; first character (unsigned max_char_or_byte2);; last character (unsigned min_byte1) ;; first row that exists (unsigned max_byte1) ;; last row that exists (int all_chars_exist) ;; flag if all characters have non-zero size (unsigned default_char) ;; char to print for undefined character (int n_properties) ;; how many properties there are (XFontPropP properties) ;; pointer to array of additional properties (XCharStruct min_bounds) ;; minimum bounds over all existing char (XCharStruct max_bounds) ;; maximum bounds over all existing char (XCharStructP per_char) ;; first_char to last_char information (int ascent) ;; log. extent above baseline for spacing (int descent) ;; log. descent below baseline for spacing ) XFontStruct) (typedef (XFontStruct *) XFontStructP) (typedef (XFontStruct 0) XFontStructA) (typedef (XFontStructA *) XFontStructAP) ; * PolyText routines take these as arguments. (typedef (struct (charP chars) ;; pointer to string (int nchars) ;; number of characters (int delta) ;; delta between strings (Font font) ;; font to print it in, None don't change ) XTextItem) (typedef (XTextItem *) XTextItemP) (typedef (XTextItem 0) XTextItemA) (typedef (XTextItemA *) XTextItemAP) (typedef (struct ;; normal 16 bit characters are two bytes (unsignedchar byte1) (unsignedchar byte2) ) XChar2b) (typedef (XChar2b *) XChar2bP) (typedef (XChar2b 0) XChar2bA) (typedef (XChar2bA *) XChar2bAP) (typedef (struct (XChar2bP chars) ;; two byte characters (int nchars) ;; number of characters (int delta) ;; delta between strings (Font font) ;; font to print it in, None don't change ) XTextItem16) (typedef (XTextItem16 *) XTextItem16P) scheme2c-2012.10.14/xlib/Xr4.cdecl000066400000000000000000000007111203736146400162070ustar00rootroot00000000000000;;; Additional data structures for X11 R4. (typedef (struct (int depth) (int bits_per_pixel) (int scanline_pad) ) XPixmapFormatValues) (typedef (XPixmapFormatValues *) XPixmapFormatValuesP) (typedef (XPixmapFormatValues 0) XPixmapFormatValuesA) (typedef (XPixmapFormatValuesA *) XPixmapFormatValuesAP) (typedef (struct (Charp value) (Atom encoding) (int format) (unsignedlong nitems) ) XTextProperty) (typedef (XTextProperty *) XTextPropertyP) scheme2c-2012.10.14/xlib/Xresource.cdecl000066400000000000000000000204071203736146400175150ustar00rootroot00000000000000; Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ; and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ; ; All Rights Reserved ; ; Permission to use, copy, modify, and distribute this software and its ; documentation for any purpose and without fee is hereby granted, ; provided that the above copyright notice appear in all copies and that ; both that copyright notice and this permission notice appear in ; supporting documentation, and that the names of Digital or MIT not be ; used in advertising or publicity pertaining to distribution of the ; software without specific, written prior permission. ; ; DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ; DIGITAL BE LIABLE FOR ANY SPECIAL, 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. ;;*************************************************************** ;**************************************************************** ;*** *** ;*** *** ;*** X Resource Manager Intrinsics *** ;*** *** ;*** *** ;**************************************************************** ;*************************************************************** ;;*************************************************************** ;* ;* Miscellaneous definitions ;* ;*************************************************************** (typedef charAP caddr_t) (const NULL 0) ;;*************************************************************** ;* ;* ||| Memory Management (move out of here!) ;* ;*************************************************************** ;extern char *Xpermalloc(); ;; unsigned int size; ;;*************************************************************** ;* ;* Quark Management ;* ;*************************************************************** (typedef int XrmQuark) (typedef intAP XrmQuarkList) (const NULLQUARK 0) (typedef charAP XrmString) (const NULLSTRING 0) ;; find quark for string, create new quark if none already exists ;extern XrmQuark XrmStringToQuark(); ;; name ;; XrmString name; ;; find string for quark ;extern XrmString XrmQuarkToString(); ;; quark ;; XrmQuark name; ;extern XrmQuark XrmUniqueQuark(); ;define XrmStringsEqual(a1, a2) (strcmp(a1, a2) == 0) ;;*************************************************************** ;* ;* Conversion of Strings to Lists ;* ;*************************************************************** ;extern void XrmStringToQuarkList(); ;; char *name; ;; XrmQuarkList quarks; ;; RETURN ;extern void XrmStringToBindingQuarkList(); ;; char *name; ;; XrmBindingList bindings; ;; RETURN ;; XrmQuarkList quarks; ;; RETURN ;;*************************************************************** ;* ;* Name and Class lists. ;* ;*************************************************************** (typedef XrmQuark XrmName) (typedef XrmQuarkList XrmNameList) ;#define XrmNameToString(name) XrmQuarkToString(name) ;#define XrmStringToName(string) XrmStringToQuark(string) ;#define XrmStringToNameList(str, name) XrmStringToQuarkList(str, name) (typedef XrmQuark XrmClass) (typedef XrmQuarkList XrmClassList) ;#define XrmClassToString(class) XrmQuarkToString(class) ;#define XrmStringToClass(class) XrmStringToQuark(class) ;#define XrmStringToClassList(str,class) XrmStringToQuarkList(str, class) ;;*************************************************************** ;* ;* Resource Representation Types and Values ;* ;*************************************************************** (typedef XrmQuark XrmRepresentation) ;#define XrmStringToRepresentation(string) XrmStringToQuark(string) ;#define XrmRepresentationToString(type) XrmQuarkToString(type) (typedef (struct (unsignedint size) (caddr_t addr) ) XrmValue) (typedef (XrmValue *) XrmValuePtr) ;;*************************************************************** ;* ;* Resource Manager Functions ;* ;*************************************************************** (const XrmBindTightly 0) (const XrmBindLoosely 1) (typedef int XrmBinding) (typedef intAP XrmBindingList) (typedef (struct) _XrmHashBucketRec) (typedef (_XrmHashBucketRec *) XrmHashBucket) (typedef (XrmHashBucket *) XrmHashTable) (typedef (XrmHashTable 1) XrmSearchList) (typedef (_XrmHashBucketRec *) XrmDatabase) (typedef (XrmDatabase *) XrmDatabaseP) ;extern void XrmInitialize(); ;extern void XrmQPutResource(); ;; XrmDatabase *pdb; ;; XrmBindingList bindings; ;; XrmQuarkList quarks; ;; XrmRepresentation type; ;; XrmValue *value; ;extern void XrmPutResource(); ;; XrmDatabase *pdb; ;; char *specifier; ;; char *type; ;; XrmValue *value; ;extern void XrmQPutStringResource(); ;; XrmDatabase *pdb; ;; XrmBindingList bindings; ;; XrmQuarkList quarks; ;; char *str; ;extern void XrmPutStringResource(); ;; XrmDatabase *pdb; ;; char *specifier; ;; char *str; ;extern void XrmPutLineResource(); ;; XrmDatabase *pdb; ;; char *line; ;extern XrmQGetResource(); ;; XrmDatabase db; ;; XrmNameList names; ;; XrmClassList classes; ;; XrmRepresentation *type; ;; RETURN ;; XrmValue *value; ;; RETURN ;extern Bool XrmGetResource(); ;; XrmDatabase db; ;; char *name_str; ;; char *class_str; ;; char *type; ;; RETURN ;; XrmValue *value; ;; RETURN ;extern Bool XrmQGetSearchList(); ;; XrmDatabase db; ;; XrmNameList names; ;; XrmClassList classes; ;; XrmSearchList searchList; ;; RETURN ;; int listLength; ;extern Bool XrmQGetSearchResource(); ;; SearchList searchList; ;; XrmName name; ;; XrmClass class; ;; XrmRepresentation *type; ;; RETURN ;; XrmValue *value; ;; RETURN ;;*************************************************************** ;* ;* Resource Database Management ;* ;*************************************************************** ;extern XrmDatabase XrmGetFileDatabase(); ;; char *filename; ;extern XrmDatabase XrmGetStringDatabase(); ;; char *data; ;; null terminated string ;extern void XrmPutFileDatabase(); ;; XrmDatabase db; ;; char *filename ;extern void XrmMergeDatabases(); ;; XrmDatabase new; ;; XrmDatabase *into; ;; RETURN ;;*************************************************************** ;* ;* Command line option mapping to resource entries ;* ;*************************************************************** (const XrmoptionNoArg 0) ;; Value is specified in OptionDescRec.value (const XrmoptionIsArg 1) ;; Value is the option string itself (const XrmoptionStickyArg 2);; Value is characters immediately following option (const XrmoptionSepArg 3) ;; Value is next argument in argv (const XrmoptionResArg 4) ;; Resource and value in next argument in argv (const XrmoptionSkipArg 5) ;; Ignore this option and the next argument in argv (const XrmoptionSkipLine 6) ;; Ignore this option and the rest of argv (typedef int XrmOptionKind) (typedef (struct (charP option) ;; Option abbreviation in argv (charP specifier) ;; Resource specifier (XrmOptionKind argKind) ;; Which style of option it is (caddr_t value) ;; Value to provide if XrmoptionNoArg ) XrmOptionDescRec) (typedef (XrmOptionDescRec *) XrmOptionDescList) ;extern void XrmParseCommand(); ;; XrmDatabase *pdb; ;; XrmOptionDescList options; ;; int num_options; ;; char *prefix; ;; int *argc; ;; char **argv; scheme2c-2012.10.14/xlib/Xutil.cdecl000066400000000000000000000161111203736146400166400ustar00rootroot00000000000000; Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ; and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ; ; All Rights Reserved ; ; Permission to use, copy, modify, and distribute this software and its ; documentation for any purpose and without fee is hereby granted, ; provided that the above copyright notice appear in all copies and that ; both that copyright notice and this permission notice appear in ; supporting documentation, and that the names of Digital or MIT not be ; used in advertising or publicity pertaining to distribution of the ; software without specific, written prior permission. ; ; DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ; DIGITAL BE LIABLE FOR ANY SPECIAL, 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. ;; Bitmask returned by XParseGeometry(). Each bit tells if the corresponding ;; value (x, y, width, height) was found in the parsed string. (const NoValue #x0000) (const XValue #x0001) (const YValue #x0002) (const WidthValue #x0004) (const HeightValue #x0008) (const AllValues #x000F) (const XNegative #x0010) (const YNegative #x0020) (typedef (struct (long flags) ;; marks which fields in this structure are defined (int x) (int y) (int width) (int height) (int min_width) (int min_height) (int max_width) (int max_height) (int width_inc) (int height_inc) ((struct (int x) ;; numerator (int y) ;; denominator ) min_aspect) ((struct (int x) ;; numerator (int y) ;; denominator ) max_aspect) ) XSizeHints) (typedef (XSizeHints *) XSizeHintsP) ;; The next block of definitions are for window manager properties that ;; clients and applications use for communication. ;; flags argument in size hints (const USPosition (expt 2 0)) ;; user specified x, y (const USSize (expt 2 1)) ;; user specified width, height (const PPosition (expt 2 2)) ;; program specified position (const PSize (expt 2 3)) ;; program specified size (const PMinSize (expt 2 4)) ;; program specified minimum size (const PMaxSize (expt 2 5)) ;; program specified maximum size (const PResizeInc (expt 2 6)) ;; program specified resize increments (const PAspect (expt 2 7)) ;; program specified min and max aspect ratios (const PAllHints (+ PPosition (+ PSize (+ PMinSize (+ PMaxSize (+ PResizeInc PAspect)))))) (typedef (struct (long flags) ;; marks which fields in this structure are defined (Bool input) ;; does this application rely on the window manager ;; to get keyboard input? (int initial_state) ;; see below (Pixmap icon_pixmap) ;; pixmap to be used as icon (Window icon_window) ;; window to be used as icon (int icon_x) ;; initial position of icon (int icon_y) (Pixmap icon_mask) ;; icon mask bitmap (XID window_group) ;; id of related window group ;; this structure may be extended in the future ) XWMHints) (typedef (XWMHints *) XWMHintsP) ;; definition for flags of XWMHints (const InputHint (expt 2 0)) (const StateHint (expt 2 1)) (const IconPixmapHint (expt 2 2)) (const IconWindowHint (expt 2 3)) (const IconPositionHint (expt 2 4)) (const IconMaskHint (expt 2 5)) (const WindowGroupHint (expt 2 6)) (const AllHints (+ InputHint (+ StateHint (+ IconPixmapHint (+ IconWindowHint (+ IconPositionHint (+ IconMaskHint WindowGroupHint))))))) ;; definitions for initial window state (const DontCareState 0) ;; don't know or care (const NormalState 1) ;; most applications want to start this way (const ZoomState 2) ;; application wants to start zoomed (const IconicState 3) ;; application wants to start as an icon (const InactiveState 4) ;; application believes it is seldom used; some ;; wm's may put it on inactive menu (typedef (struct (int min_width) (int min_height) (int max_width) (int max_height) (int width_inc) (int height_inc) ) XIconSize) (typedef (XIconSize *) XIconSizeP) (typedef (struct (charP res_name) (charP res_class) ) XClassHint) (typedef (XClassHint *) XClassHintP) ;; Compose sequence status structure, used in calling XLookupString. (typedef (struct (charP compose_ptr) ;; state table pointer (int chars_matched) ;; match state ) XComposeStatus) (typedef (XComposeStatus *) XComposeStatusP) ;; opaque reference to Region data type (typedef (struct) _XRegion) (typedef (_XRegion *) Region) ;; Return values from XRectInRegion() (const RectangleOut 0) (const RectangleIn 1) (const RectanglePart 2) ;; Information used by the visual utility routines to find desired visual ;; type from the many visuals a display may support. (typedef (struct (VisualP visual) (VisualID visualid) (int screen) (int depth) (int class) (unsignedlong red_mask) (unsignedlong green_mask) (unsignedlong blue_mask) (int colormap_size) (int bits_per_rgb) ) XVisualInfo) (typedef (XVisualInfo *) XVisualInfoP) (const VisualNoMask #x0) (const VisualIDMask #x1) (const VisualScreenMask #x2) (const VisualDepthMask #x4) (const VisualClassMask #x8) (const VisualRedMaskMask #x10) (const VisualGreenMaskMask #x20) (const VisualBlueMaskMask #x40) (const VisualColormapSizeMask #x80) (const VisualBitsPerRGBMask #x100) (const VisualAllMask #x1FF) ;; This defines a window manager property that clients may use to ;; share standard color maps: (typedef (struct (Colormap colormap) (unsignedlong red_max) (unsignedlong red_mult) (unsignedlong green_max) (unsignedlong green_mult) (unsignedlong blue_max) (unsignedlong blue_mult) (unsignedlong base_pixel) ) XStandardColormap) (typedef (XStandardColormap *) XStandardColormapP) ;; return codes for XReadBitmapFile and XWriteBitmapFile (const BitmapSuccess 0) (const BitmapOpenFailed 1) (const BitmapFileInvalid 2) (const BitmapNoMemory 3) ;; Declare the routines that don't return int. ;;*************************************************************** ;; ;; Context Management ;; ;;************************************************************** ;; Associative lookup table return codes (const XCSUCCESS 0) ;; No error. (const XCNOMEM 1) ;; Out of memory (const XCNOENT 2) ;; No entry in table (typedef int XContext) ;#define XStringToContext(atom) ((XContext) XrmStringToQuark(atom)) ;extern int XUniqueContext(); ;extern int XSaveContext(); ;; window, context, data ;; Window window; ;; XContext context; ;; caddr_t data; ;extern int XFindContext(); ;; display, window, context, data ;; Display *display; ;; Window window; ;; XContext context; ;; caddr_t *data; RETURN ;extern int XDeleteContext(); ;; window, context ;; Window window; ;; XContext context; ; XWMHints *XGetWMHints(); ; Region XCreateRegion(), XPolygonRegion(); ; XImage *XCreateImage(); ; XVisualInfo *XGetVisualInfo(); scheme2c-2012.10.14/xlib/clear.sc000066400000000000000000000036471203736146400161660ustar00rootroot00000000000000;;; Creates a clear window which covers the display. Then writes speckles ;;; in it. A mouse click causes it to go away. (module clear (main main) (with xlib)) (define-c-external (rand) int "rand") (define (RANDOM) (quotient (rand) 4096)) (define (CLEAR display-name) (let* ((dpy (let ((x (xopendisplay display-name))) (if (null-pointer? x) (error 'hello-world "DISPLAY is not defined")) x)) (screen (xdefaultscreen dpy)) (attributes (let ((x (make-xsetwindowattributes))) (xsetwindowattributes-override_redirect! x 1) (xsetwindowattributes-background_pixmap! x none) x)) (height (xdisplayheight dpy screen)) (width (xdisplaywidth dpy screen)) (window (xcreatewindow dpy (xdefaultrootwindow dpy) 0 0 width height 0 copyfromparent copyfromparent (type/value->pointer 'visualp copyfromparent) (+ cwbackpixmap cwoverrideredirect) attributes)) (gc (xcreategc dpy window 0 (make-xgcvalues))) (event (make-xevent)) (old-reset reset)) (set! reset (lambda () (xclosedisplay dpy) (set! reset old-reset) (reset))) (xsetforeground dpy gc (xblackpixel dpy screen)) (xselectinput dpy window (+ buttonpressmask exposuremask)) (xmapraised dpy window) (let loop () (ynextevent dpy event) (cond ((eq? (xevent-type event) expose) (let loop () (xfillrectangle dpy window gc (remainder (random) width) (remainder (random) height) 1 1) (if (eq? (xeventsqueued dpy queuedafterflush) 0) (loop))) (loop)) ((eq? (xevent-type event) buttonpress) (set! reset old-reset) (xfreegc dpy gc) (xdestroywindow dpy window) (xclosedisplay dpy)) (else (loop)))))) (define (MAIN clargs) (if (and (= (length clargs) 3) (equal? (cadr clargs) "-display")) (clear (caddr clargs)) (clear ""))) scheme2c-2012.10.14/xlib/doc.txt000066400000000000000000000363561203736146400160620ustar00rootroot00000000000000Using the X11 C library from Scheme->C -------------------------------------- One of the goals of the Scheme->C project has been to produce a Lisp which is able to co-exist with other languages. One use for such a language is as "glue" for constructing X window applications. As a first step down this path, a set of interfaces to X11's Xlib have been generated. These allow a Scheme programmer to execute X applications written in Scheme within the Scheme interpreter, or as stand-alone Scheme programs. An Example ---------- Before going into any detail, an example is in order. This example is a Scheme version of the initial sample program from Oliver Jones' book, "Introduction to the X Window System": (module hello (main main) (with xlib)) (define (HELLO-WORLD) (let* ((hello "Hello, World") (hi "Hi!") (dpy (let ((x (xopendisplay ""))) (if (null-pointer? x) (error 'hello-world "DISPLAY is not defined")) x)) (screen (xdefaultscreen dpy)) (background (xwhitepixel dpy screen)) (foreground (xblackpixel dpy screen)) (window (xcreatesimplewindow dpy (xdefaultrootwindow dpy) 200 300 350 250 5 foreground background)) (gc (xcreategc dpy window 0 (make-xgcvalues))) (event (make-xevent))) (xstorename dpy window "Hello, World in Scheme->C using Xlib") (xseticonname dpy window "hello") (xsetbackground dpy gc background) (xsetforeground dpy gc foreground) (xselectinput dpy window (+ buttonpressmask (+ keypressmask exposuremask))) (xmapraised dpy window) (let loop () (ynextevent dpy event) (cond ((eq? (xevent-type event) expose) (xdrawimagestring (xevent-xexpose-display event) (xevent-xexpose-window event) gc 50 50 hello (string-length hello)) (loop)) ((eq? (xevent-type event) mappingnotify) (xrefreshkeyboardmapping event) (loop)) ((eq? (xevent-type event) buttonpress) (xdrawimagestring (xevent-xbutton-display event) (xevent-xbutton-window event) gc (xevent-xbutton-x event) (xevent-xbutton-y event) hi (string-length hi)) (loop)) ((and (eq? (xevent-type event) keypress) (equal? (ylookupstring+ event) "q")) (xfreegc dpy gc) (xdestroywindow dpy window) (xclosedisplay dpy)) (else (loop)))))) (define (MAIN clargs) (hello-world)) The window system operations are confined to the procedure HELLO-WORLD. It starts with a LET* construct which sequentially binds variables. DPY is bound to the display pointer returned by xopendisplay, which is an interface procedure to XOpenDisplay. As with other Xlib interfaces to Scheme, the caller provides a Scheme string when a null-terminated string is expected. Since XOpenDisplay returns a single value, it is returned as the value of xopendisplay. Where possible, the values returned by the Xlib interfaces are type tagged to allow runtime type checking. Thus on a successful call to xopendisplay, one gets back a dotted-pair of the form: (DISPLAYP . 272961004). If the display couldn't be opened, then xopendisplay would return (DISPLAYP . 0) and the predicate NULL-POINTER? would return #T. The creation of the graphics context GC shows two more facets of the Xlib interface. First, since all interfaces are type checked as much as possible, xcreategc wants not just any pointer, but a pointer to an XGCValues struct as one of its arguments. In order to create an instance of that struct, one calls make-xgcvalues which returns a dotted pair of the form: (XGCVALUESP . ""). There, the identifier identifies the type of object, and the string is the object. Following the creation of an XEvent struct, the window is decorated, events selected, and then the window is mapped. In the call to xselectevent, one can see the one-to-one translation between Xlib constants and case-insensitive Scheme globals. Following this setup is the event loop. Here, one can see structure access in action. The function xevent-type extracts the type from an XEvent structure. Once the particular event type has been discovered, the appropriate access functions can be used. Thus on a button press event, the coordinates of the button can be extracted by xevent-xbutton-x and xevent-xbutton-y. It also contains one example of the use of an augmented interface, the call to ylookupstring. Here, a simplified version of XLookupString returns the key string in a straight-forward manner. To differentiate such functions from the standard Xlib interfaces, they have the x in their name replaced by y. Xlib Constants -------------- Having given a flavor of the Xlib interfaces in this example, it is now appropriate to examine their translation to Scheme in detail. The simplest items are those which are unsigned integer constants. These are found in such files as X.h, Xatom.h, and Xutil.h. These are translated on a one-to-one basis to top level Scheme values which have the same name and value. Inspite of the fact that Scheme is insensitive to case, this translation has only caused problems in translating the constants found in Xkeysym.h. There, there are symbols for upper case letters of the form XK_A and symbols for lower case letters of the form XK_a. In order to get around this, XK_A is represented as xk_a and XK_a is represented as xk_lca. Simple Data Types ----------------- Many objects in Xlib are defined by the type XID which in turn is defined as an unsigned long value. Examples of such objects are Window, Drawable, Font, Pixmap, Cursor, Colormap, GContext, and KeySym. These are represented in Scheme as positive integers. Unions and Structs ------------------ The Scheme interfaces provide functions to create and access user visible Xlib structs and unions. For example, Xcolor which is defined as: typedef struct{ unsigned long pixel; unsigned short red, green, blue; char flags; char pad; } XColor; is handled within Scheme as follows. An instance of an XColor struct is represented by a pair consisting of the type tag XCOLORP (denoting a pointer to an XColor struct) and either a string or a number. The first form is used to represent an XColor structure within the Scheme system, and the second is used to denote one within Xlib. An instance of XColor is created by the function: (MAKE-XCOLOR) which returns a pair of the form: (XCOLORP . ""). Any object may be tested to see if it is a pointer to an XColor struct by: (ISA-XCOLORP? ) For example, (ISA-XCOLORP? (MAKE-XCOLOR)) evaluates to #T. Fields within an XColor struct may be accessed by the following functions: (XCOLOR-PIXEL ) (XCOLOR-RED ) (XCOLOR-GREEN ) (XCOLOR-BLUE ) (XCOLOR-FLAGS ) (XCOLOR-PAD ) Fields within an XColor struct may be set by: (XCOLOR-PIXEL! ) (XCOLOR-RED! ) (XCOLOR-GREEN! ) (XCOLOR-BLUE! ) (XCOLOR-FLAGS! ) (XCOLOR-PAD! ) Simple Arrays ------------- A simple array is an array whose elements are not union or struct objects. Such array types have names ending in A. For example, UNSIGNEDA is type of an array of unsigned integers. One can make an new instance of an array of unsigned integers by: (MAKE-UNSIGNEDA ) test if an object is a pointer to such an array by: (ISA-UNSIGNEDAP? ) and determine the number of objects in the array by: (UNSIGNEDA-LENGTH ) Entries in such an array can be accessed by: (UNSIGNEDA ) and values set in entries by: (UNSIGNEDA! ) Finally, one can convert between lists and arrays by: (UNSIGNEDA->UNSIGNED-LIST ) (UNSIGNED-LIST->UNSIGNEDA ) Another type of array often used with Xlib is CHARA which is an array of unsigned 8-bit integers. Similar creation and access procedures exist for it. Arrays of Struct and Union types -------------------------------- Functions for operating on arrays of structures are defined in a similar manner. Here though, functions are not defined which allow access to fields in the structures while they are in the array. Thus for the type XColor, the following functions are defined: (XCOLORA-LENGTH ) (XCOLORA->XCOLOR-LIST ) (XCOLOR-LIST->XCOLORA ) Available X11 Data Definitions ------------------------------ Using these techniques, the data definitions found in the following files have been converted: X.h Xatom.h Xlib.h Xresource.h Xutil.h cursorfont.h keysymdef.h (LATIN1 and DEC Private are only options) Utility Functions ----------------- Several utility functions have been constructed to assist the user in manipulating pointers and bit masks for the Xlib interfaces. They are: (NULL-POINTER? ) predicate which returns #T iff is a null pointer. (POINTER-TYPE ) returns the type name of the pointer . (POINTER-VALUE ) returns the pointer value of the pointer . (TYPE/VALUE->POINTER type value) constructs a pointer with type and value . This function is commonly used to construct "magic" pointer values, such as visual pointer with the value copyfromparent for a call to xcreatewindow. Xlib Procedure Interfaces ------------------------- Having described the data representation conventions, it is now appropriate to turn to the procedure interfaces. Using a few simple conventions, access to all procedures defined in the book "X Window System" by Gettys, Newman, and Scheifler has been provided from Scheme. Efforts have been made to not change how these functions act so that existing documentation can be used. The argument passing conventions are: - Xlib arguments which are null terminated strings can be supplied as Scheme strings. - Xlib arguments which return a value of known size are omitted. For example, one does not call xnextevent with a pointer to an XEvent object. However, one must provide the the return arguments for XAllocColorCells as the array and its length are computed at runtime. - Xlib arguments which are pointers to some object must be of the correct object type. The value return conventions are: - Xlib procedures which do not return a value, return #F. - Xlib procedures which return a single value, return it. - Xlib procedures which return multiple values return them as a list. - Xlib procedures which return a pointer to a null terminated string return a Scheme string, unless the user must call to XFree to return the string in which case a charAP pointer is returned. Augmented Xlib Procedure Interfaces ----------------------------------- As earlier noted, a few functions have been augmented by adding additional procedural interfaces. These procedures are identified by the fact that their names start with Y rather than X. In some cases, the Xlib versions still exist, but in others they do not as the interface was not appropriate for access from Scheme. The functions that exist to date are: (YFREE ) returns storage, where is either a tagged or untagged pointer. (YQUERYTREE ) returns a list of three elements: the root window, the parent window of , and a list of the children of . (YGETATOMNAME ) returns a string which is the name of . (YLISTPROPERTIES ) returns a list of atoms which indicate the properties that are associated with . (YLISTFONTS ) returns a list of font names (less than or equal to in length) which match . (YLISTFONTSWITHINFO ) returns a list of lists (less than or equal to in length) which match . Each list element is a list of a font name and an XFontstruct. (YSETFONTPATH ) sets the font search path to the list of strings . (YGETFONTPATH ) returns the list of directories which is the current font search path. (YLISTINSTALLEDCOLORMAPS ) returns a list of the currently installed colormaps. (YNEXTEVENT ) returns the next event in the event structure . (YSELECT ... ) waits up to for events for or input on one of the 's. If events arrive then is returned, if input arrives then the appropriate is returned, otherwise #F is returned. (YGETMOTIONEVENTS ) returns a list of motion events. Each event is a list of three elements: time, x-position, and y-position. (YSETSTANDARDPROPERTIES ) sets the 's standard properties. Arguments are as expected by XSetStandardProperties, except that is a list of strings. (YFETCHNAME ) returns the 's name or #F if it is unnamed. (YGETICONNAME ) returns the icon's name or #F if it is unnamed. (YSETCOMMAND ) sets the 's commands to the list of strings . (YGETWMHINTS ) returns either the XWMHints for or #F when no hints have been provided. (YSETICONSIZES ) sets the icon sizes to the list of XIconSize structures. (YGETICONSIZES ) returns either a list of XIconSize hints, or #F when no hints have been provided. (YSETCLASSHINT ) sets the class hint to the list of two strings . (YGETCLASSHINT ) returns either a list of name and class, or #F when no class hints have been supplied. (YLOOKUPSTRING ) returns the keyboard string associated with the event. (YLOOKUPSTRING #T) (YLOOKUPSTRING #T ) returns a list consisting of the keyboard string and the KeySym associated with the event. (YLOOKUPSTRING #F ) returns a list of the keyboard string associated with the event and #F. (YRMGETRESOUCE ) return #F if the item is not in the database, or its value. Only String values are supported. (YRMMERGEDATABASES ) merges two databases and returns the resulting database. Primitive Xlib Interface ------------------------ When you want to get your hands directly on the C interface to Xlib, you may. For each Xlib procedure Proc, Proc* is the name of the primitive procedure. Availability ------------ The Xlib interfaces are found in Scheme->C interpreters named s2cixl. Libraries containing the interfaces libs2cxl.a. In order to correctly link with the interfaces, a compiled program must include a (with xlib) clause in its module expression. When a program is compiled which uses these interfaces, warnings will be generated as there are no external declarations. Stand-alone programs produced in this manner are large as they contain all the Xlib interfaces. Smaller programs can be produced by having the application include the inline versions of the interfaces found in the .sch files and then linking with the appropriate object files. scheme2c-2012.10.14/xlib/hello.sc000066400000000000000000000033411203736146400161720ustar00rootroot00000000000000;;; Hello, World example from Oliver Jones' book in Scheme->C (module hello (main main) (with xlib)) (define (HELLO-WORLD) (let* ((hello "Hello, World") (hi "Hi!") (dpy (let ((x (xopendisplay ""))) (if (null-pointer? x) (error 'hello-world "DISPLAY is not defined")) x)) (screen (xdefaultscreen dpy)) (background (xwhitepixel dpy screen)) (foreground (xblackpixel dpy screen)) (window (xcreatesimplewindow dpy (xdefaultrootwindow dpy) 200 300 350 250 5 foreground background)) (gc (xcreategc dpy window 0 (make-xgcvalues))) (event (make-xevent))) (xstorename dpy window "Hello, World in Scheme->C using X11's Xlib") (xseticonname dpy window "hello") (xsetbackground dpy gc background) (xsetforeground dpy gc foreground) (xselectinput dpy window (bit-or buttonpressmask keypressmask exposuremask)) (xmapraised dpy window) (let loop () (ynextevent dpy event) (cond ((eq? (xevent-type event) expose) (xdrawimagestring (xevent-xexpose-display event) (xevent-xexpose-window event) gc 50 50 hello (string-length hello)) (loop)) ((eq? (xevent-type event) mappingnotify) (xrefreshkeyboardmapping event) (loop)) ((eq? (xevent-type event) buttonpress) (xdrawimagestring (xevent-xbutton-display event) (xevent-xbutton-window event) gc (xevent-xbutton-x event) (xevent-xbutton-y event) hi (string-length hi)) (loop)) ((and (eq? (xevent-type event) keypress) (equal? (ylookupstring event) "q")) (xfreegc dpy gc) (xdestroywindow dpy window) (xclosedisplay dpy)) (else (loop)))))) (define (MAIN clargs) (hello-world)) scheme2c-2012.10.14/xlib/hello2.sc000066400000000000000000000041161203736146400162550ustar00rootroot00000000000000;;; Hello, World example from Oliver Jones' book in Scheme->C (define (HELLO-WORLD rootx rooty) (let* ((hello "Hello, World") (hi "Hi!") (dpy (let ((x (xopendisplay ""))) (if (null-pointer? x) (error 'hello-world "DISPLAY is not defined")) x)) (screen (xdefaultscreen dpy)) (background (xwhitepixel dpy screen)) (foreground (xblackpixel dpy screen)) (window (xcreatesimplewindow dpy (xdefaultrootwindow dpy) rootx rooty 400 250 5 foreground background)) (gc (xcreategc dpy window 0 (make-xgcvalues))) (event (make-xevent)) (system-file (xconnectionnumber dpy))) (define (DISPLAY-TASK) (let loop () (ynextevent dpy event) (cond ((eq? (xevent-type event) expose) (xdrawimagestring (xevent-xexpose-display event) (xevent-xexpose-window event) gc 50 50 hello (string-length hello))) ((eq? (xevent-type event) mappingnotify) (xrefreshkeyboardmapping event)) ((eq? (xevent-type event) buttonpress) (xdrawimagestring (xevent-xbutton-display event) (xevent-xbutton-window event) gc (xevent-xbutton-x event) (xevent-xbutton-y event) hi (string-length hi))) ((and (eq? (xevent-type event) keypress) (equal? (ylookupstring event) "q")) (xfreegc dpy gc) (xdestroywindow dpy window) (xflush dpy) (define-system-file-task system-file #f #f) (set! system-file #f))) (unless (zero? (xeventsqueued dpy queuedafterreading)) (loop)))) (xstorename dpy window "Hello, World in Scheme->C using X11's Xlib") (xseticonname dpy window "hello") (xsetbackground dpy gc background) (xsetforeground dpy gc foreground) (xselectinput dpy window (bit-or buttonpressmask keypressmask exposuremask)) (xmapraised dpy window) (define-system-file-task system-file (lambda () (xflush dpy)) display-task) system-file)) (define (TEST) (hello-world 100 100) (hello-world 400 400) (hello-world 400 100) (enable-system-file-tasks #t)) scheme2c-2012.10.14/xlib/makefile000066400000000000000000000137701203736146400162470ustar00rootroot00000000000000prefix=/usr/local LIBDIR=${prefix}/lib BINDIR=${prefix}/bin LIBSUBDIR=scheme2c DOCDIR=$(prefix)/doc/scheme2c MANDIR=$(prefix)/man INSTALL = install INSTALL_DATA = ${INSTALL} -m 644 INSTALL_PROGRAM = ${INSTALL} INSTALL_SCRIPT = ${INSTALL} .SUFFIXES: .SUFFIXES: .sc .cdecl .o .c .sch CDECL = ../cdecl/s2cdecl SIZEOF = ../cdecl/s2csizeof SCH = ../cdecl/s2ch SRCDIR = ../../xlib SCC = ../scsc/Xs2cc SCXLIB = libs2cxl.a XD = X.cdecl Xatom.cdecl Xlib.cdecl Xresource.cdecl Xutil.cdecl \ Xkeysym.cdecl Xcursorfont.cdecl Xr4.cdecl XDP = xws2.cdecl xws3.cdecl xws4.cdecl xws5.cdecl xws6.cdecl xws7.cdecl \ xws8.cdecl xws9.cdecl xws10.cdecl xwsr4.cdecl XMISC = doc.txt xwss.sc xlib.sc clear.sc hello.sc hello2.sc puzzle.sc \ npuzzle.sc xdsc = depth.sc screen.sc visual.sc xarc.sc xchar2b.sc xcharstruct.sc \ xclasshint.sc xcomposestatus.sc xcolor.sc xlibCONSTANTS.sc xevent.sc \ xfontprop.sc xfontstruct.sc xgcvalues.sc xhostaddress.sc xiconsize.sc \ ximage.sc xkeyboardcontrol.sc xkeyboardstate.sc xmodifierkeymap.sc \ xpoint.sc xrectangle.sc xrmoptiondescrec.sc xrmvalue.sc xsegment.sc \ xsetwindowattributes.sc xsizehints.sc xstandardcolormap.sc \ xlibSTUBS.sc xtextitem.sc xtextitem16.sc xtimecoord.sc xlibTYPES.sc \ xvisualinfo.sc xwindowattributes.sc xwindowchanges.sc xwmhints.sc \ xpixmapformatvalues.sc xtextproperty.sc xdschextra = xws2.sch xws3.sch xws4.sch xws5.sch xws6.sch xws7.sch \ xws8.sch xws9.sch xws10.sch xwsr4.sch xdsch = depth.sch screen.sch visual.sch xarc.sch xchar2b.sch xcharstruct.sch \ xclasshint.sch xcomposestatus.sch xcolor.sch xlibCONSTANTS.sch \ xevent.sch xfontprop.sch xfontstruct.sch xgcvalues.sch \ xhostaddress.sch xiconsize.sch ximage.sch xkeyboardcontrol.sch \ xkeyboardstate.sch xmodifierkeymap.sch xpoint.sch xrectangle.sch \ xrmoptiondescrec.sch xrmvalue.sch xsegment.sch \ xsetwindowattributes.sch xsizehints.sch xstandardcolormap.sch \ xlibSTUBS.sch xtextitem.sch xtextitem16.sch xtimecoord.sch \ xlibTYPES.sch xvisualinfo.sch xwindowattributes.sch \ xwindowchanges.sch xwmhints.sch xpixmapformatvalues.sch \ xtextproperty.sch $(xdschextra) xdc = depth.c screen.c visual.c xarc.c xchar2b.c xcharstruct.c \ xclasshint.c xcomposestatus.c xcolor.c xlibCONSTANTS.c xevent.c \ xfontprop.c xfontstruct.c xgcvalues.c xhostaddress.c xiconsize.c \ ximage.c xkeyboardcontrol.c xkeyboardstate.c xmodifierkeymap.c \ xpoint.c xrectangle.c xrmoptiondescrec.c xrmvalue.c xsegment.c \ xsetwindowattributes.c xsizehints.c xstandardcolormap.c \ xlibSTUBS.c xtextitem.c xtextitem16.c xtimecoord.c xlibTYPES.c \ xvisualinfo.c xwindowattributes.c xwindowchanges.c xwmhints.c \ xpixmapformatvalues.c xtextproperty.c xdo = depth.o screen.o visual.o xarc.o xchar2b.o xcharstruct.o \ xclasshint.o xcomposestatus.o xcolor.o xlibCONSTANTS.o xevent.o \ xfontprop.o xfontstruct.o xgcvalues.o xhostaddress.o xiconsize.o \ ximage.o xkeyboardcontrol.o xkeyboardstate.o xmodifierkeymap.o \ xpoint.o xrectangle.o xrmoptiondescrec.o xrmvalue.o xsegment.o \ xsetwindowattributes.o xsizehints.o xstandardcolormap.o \ xlibSTUBS.o xtextitem.o xtextitem16.o xtimecoord.o xlibTYPES.o \ xvisualinfo.o xwindowattributes.o xwindowchanges.o xwmhints.o \ xpixmapformatvalues.o xtextproperty.o xdpsc = xws2.sc xws3.sc xws4.sc xws5.sc xws6.sc xws7.sc \ xws8.sc xws9.sc xws10.sc xwsr4.sc xdpsch = xws2.sch xws3.sch xws4.sch xws5.sch xws6.sch xws7.sch \ xws8.sch xws9.sch xws10.sch xwsr4.sch xdpc = xws2.c xws3.c xws4.c xws5.c xws6.c xws7.c xws8.c xws9.c xws10.c \ xwsr4.c xwssc = xwss.sc xws2.sc xws3.sc xws4.sc xws5.sc xws6.sc xws7.sc xws8.sc \ xws9.sc xws10.sc xwsr4.sc xwsc = xwss.c xws2.c xws3.c xws4.c xws5.c xws6.c xws7.c xws8.c xws9.c xws10.c \ xlib.c xwsr4.c xwso = xwss.o xws2.o xws3.o xws4.o xws5.o xws6.o xws7.o xws8.o xws9.o xws10.o \ xlib.o xwsr4.o all: s2cixl ${SCXLIB} sizeof.cdecl: ${SIZEOF} > sizeof.cdecl xlibTYPES.sc: sizeof.cdecl ${XD} ${CDECL} xlib -const sizeof.cdecl ${XD} ${CDECL} xlib -typedef sizeof.cdecl ${XD} ${CDECL} xlib -stubs sizeof.cdecl ${XD} ${XDP} xlibTYPES.c: xlibTYPES.sc ${SCC} -C -Og -sch 16 ${xdsc} xlibTYPES.o: xlibTYPES.c ${SCC} -c ${XLIBCFLAGS} ${xdc} ${xwssc}: xlibTYPES.c .cdecl.sc: ${CDECL} xlib -extern sizeof.cdecl ${XD} $*.cdecl .sc.c: ${SCC} -C $*.sc .c.o: ${SCC} -c ${XLIBCFLAGS} $*.c .sc.sch: ${SCH} $*.sc s2cixl: xlibTYPES.o ${xwssc} ${xwsc} ${xwso} ${SCC} ${CFLAGS} ${LDFLAGS} -o s2cixl -i -m xlib ${xwso} ${xdo} ${XLIB} ${SCXLIB}: xlibTYPES.o ${xwssc} ${xwsc} ${xwso} rm -f ${SCXLIB} ar q ${SCXLIB} ${xdo} ${xwso} ${RANLIB} ${SCXLIB} ## Would like to replace with this, but messes up parallel make... # ${SCXLIB}: ${SCXLIB}(${xdo} ${xwso}) clear: ${SCC} ${CFLAGS} ${LDFLAGS} -o clear clear.sc ${SCXLIB} ${XLIB} hello: ${SCC} ${CFLAGS} ${LDFLAGS} -o hello hello.sc ${SCXLIB} ${XLIB} puzzle: ${SCC} ${CFLAGS} ${LDFLAGS} -o puzzle puzzle.sc ${SCXLIB} ${XLIB} install: install-prog install-docs install-examples install-prog: ${xdsch} sizeof.cdecl ${SCXLIB} s2cixl ${INSTALL} -d ${DESTDIR}${LIBDIR}/${LIBSUBDIR} ${INSTALL_DATA} ${SCXLIB} ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ ln -sf ${SCXLIB} ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/scxl.a ${INSTALL_DATA} ${xdsch} sizeof.cdecl ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ ${INSTALL} -d ${DESTDIR}${BINDIR} ${INSTALL_PROGRAM} s2cixl ${DESTDIR}${BINDIR}/ ln -sf s2cixl ${DESTDIR}${BINDIR}/scixl install-docs: ${INSTALL} -d ${DESTDIR}${DOCDIR} ${INSTALL_DATA} doc.txt ${DESTDIR}${DOCDIR}/xlib-doc.txt install-examples: ${INSTALL} -d ${DESTDIR}${DOCDIR}/examples ${INSTALL_DATA} hello.sc clear.sc puzzle.sc npuzzle.sc ${DESTDIR}${DOCDIR}/examples/ ${INSTALL_DATA} makefile-example ${DESTDIR}${DOCDIR}/examples/makefile clean: rm -f *.BAK *.CKP core noprogs: rm -f *.o s2cixl ${SCXLIB} hello puzzle clear clean-cdecl: rm -f ${xdsc} ${xdsch} ${xdc} ${xdpsc} ${xdpsch} ${xdpc} sizeof.cdecl clean-sc-to-c: rm -f ${xdc} ${xdpc} xlib.c xwss.c clear.c hello.c hello2.c \ puzzle.c npuzzle.c gensource: $(MAKE) ${xwssc} ${xwsc} srclinks: for x in ${XD} ${XDP} ${XMISC} makefile-example; \ do ln -s ${SRCDIR}/$$x $$x; \ done scheme2c-2012.10.14/xlib/makefile-example000066400000000000000000000002211203736146400176630ustar00rootroot00000000000000all: clear hello npuzzle puzzle S2CC=s2cc S2CDIR=/usr/lib/scheme2c S2C_LIBES=$(S2CDIR)/libs2cxl.a -lX11 %: %.sc $(S2CC) -o $@ $< $(S2C_LIBES) scheme2c-2012.10.14/xlib/npuzzle.sc000066400000000000000000000130271203736146400166000ustar00rootroot00000000000000;;; A simple 4x4 puzzle game. Click on a tile to move it into the ;;; adjacent empty space. Type control-c to exit. (module puzzle (main main) (with xlib)) (define (MAIN clargs) (puzzle)) (define XDEBUG 0) ;;; Set to 1 to synchronize requests. (define (PUZZLE) (let* ((dpy (let ((x (xopendisplay ""))) (if (null-pointer? x) (error 'hello-world "DISPLAY is not defined")) x)) (old-reset (let ((old-reset reset)) (set! reset (lambda () (xclosedisplay dpy) (set! reset old-reset) (reset))) (xsynchronize dpy xdebug) (clear-window-methods) old-reset)) (top-window (make-windows dpy)) (control-c (list->string (list (integer->char 3)))) (event (make-xevent))) (define (NEXTEVENT) (ynextevent dpy event) (let ((event-type (xevent-xany-type event)) (event-window (xevent-xany-window event))) (cond ((and (eq? event-type expose) (zero? (xevent-xexpose-count event))) (send event-window 'expose event) #t) ((eq? event-type buttonpress) (send event-window 'buttonpress event) #t) ((and (eq? event-type keypress) (equal? (ylookupstring event) control-c)) (set! reset old-reset) (xclosedisplay dpy) #f) (else #t)))) (define (STRIP-WHITE) (let loop () (when (and (char-ready?) (char-whitespace? (peek-char))) (read-char) (loop)))) (xmapsubwindows dpy top-window) (xmapraised dpy top-window) (let loop () (strip-white) (let ((pending (yselect dpy (current-input-port) 100000 0))) (if (eq? pending dpy) (if (nextevent) (loop)) (begin (strip-white) (read-eval-print) (loop))))))) (define (MAKE-WINDOWS dpy) (let* ((font-struct (xloadqueryfont dpy "8x13bold")) (tile-border 5) (tile-size (* 2 (xtextwidth font-struct "XX" 2))) (top-size (+ (* tile-border 5) (* tile-size 4))) (tile-numbers '(10 15 12 3 13 8 7 1 2 14 6 4 9 5 11)) (screen (xdefaultscreen dpy)) (white (xwhitepixel dpy screen)) (black (xblackpixel dpy screen)) (top-window (xcreatesimplewindow dpy (xdefaultrootwindow dpy) 100 100 top-size top-size 5 black white))) (xstorename dpy top-window "puzzle") (xseticonname dpy top-window "puzzle") (xsetnormalhints dpy top-window (let ((hints (make-xsizehints))) (xsizehints-min_width! hints top-size) (xsizehints-max_width! hints top-size) (xsizehints-min_height! hints top-size) (xsizehints-max_height! hints top-size) (xsizehints-flags! hints (+ pminsize pmaxsize)) hints)) (xselectinput dpy top-window (+ keypressmask exposuremask)) (make-zero-tile dpy font-struct tile-size tile-border top-window black white) (let loop ((tiles tile-numbers) (x 0) (y 1)) (unless (= x 4) (cond ((= y 4) (loop tiles (+ x 1) 0)) (else (make-tile dpy font-struct tile-size tile-border top-window x y (car tiles) black white) (loop (cdr tiles) x (+ y 1)))))) (set-window-method! top-window 'expose (lambda (event) (xclearwindow dpy top-window))) top-window)) (define ZERO-X 0) (define ZERO-Y 0) (define ZERO-WINDOW #f) (define (MAKE-ZERO-TILE dpy font-struct tile-size tile-border top-window black white) (let ((window (xcreatesimplewindow dpy top-window tile-border tile-border tile-size tile-size 0 white white))) (xselectinput dpy window (+ keypressmask exposuremask)) (set! zero-x 0) (set! zero-y 0) (set! zero-window window) (set-window-method! window 'expose (lambda (event) (xclearwindow dpy window))))) (define (MAKE-TILE dpy font-struct tile-size tile-border top-window x y tile-number black white) (define (TILE->PIXEL x) (+ tile-border (* x (+ tile-border tile-size)))) (let* ((window (xcreatesimplewindow dpy top-window (tile->pixel x) (tile->pixel y) tile-size tile-size 0 black black)) (gc (xcreategc dpy window 0 (make-xgcvalues))) (text (format "~s" tile-number)) (text-width (xtextwidth font-struct text (string-length text))) (text-height (quotient (cadr (xgetfontproperty font-struct xa_point_size)) 10)) (text-x (quotient (- tile-size text-width) 2)) (text-y (+ text-height (quotient (- tile-size text-height) 2)))) (xselectinput dpy window (+ keypressmask (+ exposuremask buttonpressmask))) (xsetbackground dpy gc black) (xsetforeground dpy gc white) (xsetfont dpy gc (xfontstruct-fid font-struct)) (set-window-method! window 'expose (lambda (event) (xclearwindow dpy window) (xdrawstring dpy window gc text-x text-y text (string-length text)))) (set-window-method! window 'buttonpress (lambda (event) (when (= (+ (abs (- x zero-x)) (abs (- y zero-y))) 1) (xmovewindow dpy window (tile->pixel zero-x) (tile->pixel zero-y)) (xmovewindow dpy zero-window (tile->pixel x) (tile->pixel y)) (let ((zx zero-x) (zy zero-y)) (set! zero-x x) (set! zero-y y) (set! x zx) (set! y zy))))))) (define WINDOW-METHODS '()) (define (CLEAR-WINDOW-METHODS) (set! window-methods '())) (define (SET-WINDOW-METHOD! window event-type method) (set! window-methods (cons (list (cons window event-type) method) window-methods))) (define (SEND window event-type event) (let ((x (assoc (cons window event-type) window-methods))) (if x (apply (cadr x) (list event))))) scheme2c-2012.10.14/xlib/puzzle.sc000066400000000000000000000121631203736146400164220ustar00rootroot00000000000000;;; A simple 4x4 puzzle game. Click on a tile to move it into the ;;; adjacent empty space. Type control-c to exit. (module puzzle (main main) (with xlib)) (define (MAIN clargs) (puzzle)) (define XDEBUG 0) ;;; Set to 1 to synchronize requests. (define (PUZZLE) (let* ((dpy (let ((x (xopendisplay ""))) (if (null-pointer? x) (error 'hello-world "DISPLAY is not defined")) x)) (old-reset (let ((old-reset reset)) (set! reset (lambda () (xclosedisplay dpy) (set! reset old-reset) (reset))) (xsynchronize dpy xdebug) (clear-window-methods) old-reset)) (top-window (make-windows dpy)) (control-c (list->string (list (integer->char 3)))) (event (make-xevent))) (xmapsubwindows dpy top-window) (xmapraised dpy top-window) (let loop () (ynextevent dpy event) (let ((event-type (xevent-xany-type event)) (event-window (xevent-xany-window event))) (cond ((and (eq? event-type expose) (zero? (xevent-xexpose-count event))) (send event-window 'expose event) (loop)) ((eq? event-type buttonpress) (send event-window 'buttonpress event) (loop)) ((and (eq? event-type keypress) (equal? (ylookupstring event) control-c)) (set! reset old-reset) (xclosedisplay dpy)) (else (loop))))))) (define (MAKE-WINDOWS dpy) (let* ((font-struct (xloadqueryfont dpy "8x13bold")) (tile-border 5) (tile-size (* 2 (xtextwidth font-struct "XX" 2))) (top-size (+ (* tile-border 5) (* tile-size 4))) (tile-numbers '(10 15 12 3 13 8 7 1 2 14 6 4 9 5 11)) (screen (xdefaultscreen dpy)) (white (xwhitepixel dpy screen)) (black (xblackpixel dpy screen)) (top-window (xcreatesimplewindow dpy (xdefaultrootwindow dpy) 100 100 top-size top-size 5 black white))) (xstorename dpy top-window "puzzle") (xseticonname dpy top-window "puzzle") (xsetnormalhints dpy top-window (let ((hints (make-xsizehints))) (xsizehints-min_width! hints top-size) (xsizehints-max_width! hints top-size) (xsizehints-min_height! hints top-size) (xsizehints-max_height! hints top-size) (xsizehints-flags! hints (+ pminsize pmaxsize)) hints)) (xselectinput dpy top-window (+ keypressmask exposuremask)) (make-zero-tile dpy font-struct tile-size tile-border top-window black white) (let loop ((tiles tile-numbers) (x 0) (y 1)) (unless (= x 4) (cond ((= y 4) (loop tiles (+ x 1) 0)) (else (make-tile dpy font-struct tile-size tile-border top-window x y (car tiles) black white) (loop (cdr tiles) x (+ y 1)))))) (set-window-method! top-window 'expose (lambda (event) (xclearwindow dpy top-window))) top-window)) (define ZERO-X 0) (define ZERO-Y 0) (define ZERO-WINDOW #f) (define (MAKE-ZERO-TILE dpy font-struct tile-size tile-border top-window black white) (let ((window (xcreatesimplewindow dpy top-window tile-border tile-border tile-size tile-size 0 white white))) (xselectinput dpy window (+ keypressmask exposuremask)) (set! zero-x 0) (set! zero-y 0) (set! zero-window window) (set-window-method! window 'expose (lambda (event) (xclearwindow dpy window))))) (define (MAKE-TILE dpy font-struct tile-size tile-border top-window x y tile-number black white) (define (TILE->PIXEL x) (+ tile-border (* x (+ tile-border tile-size)))) (let* ((window (xcreatesimplewindow dpy top-window (tile->pixel x) (tile->pixel y) tile-size tile-size 0 black black)) (gc (xcreategc dpy window 0 (make-xgcvalues))) (text (format "~s" tile-number)) (text-width (xtextwidth font-struct text (string-length text))) (text-height (quotient (cadr (xgetfontproperty font-struct xa_point_size)) 10)) (text-x (quotient (- tile-size text-width) 2)) (text-y (+ text-height (quotient (- tile-size text-height) 2)))) (xselectinput dpy window (+ keypressmask (+ exposuremask buttonpressmask))) (xsetbackground dpy gc black) (xsetforeground dpy gc white) (xsetfont dpy gc (xfontstruct-fid font-struct)) (set-window-method! window 'expose (lambda (event) (xclearwindow dpy window) (xdrawstring dpy window gc text-x text-y text (string-length text)))) (set-window-method! window 'buttonpress (lambda (event) (when (= (+ (abs (- x zero-x)) (abs (- y zero-y))) 1) (xmovewindow dpy window (tile->pixel zero-x) (tile->pixel zero-y)) (xmovewindow dpy zero-window (tile->pixel x) (tile->pixel y)) (let ((zx zero-x) (zy zero-y)) (set! zero-x x) (set! zero-y y) (set! x zx) (set! y zy))))))) (define WINDOW-METHODS '()) (define (CLEAR-WINDOW-METHODS) (set! window-methods '())) (define (SET-WINDOW-METHOD! window event-type method) (set! window-methods (cons (list (cons window event-type) method) window-methods))) (define (SEND window event-type event) (let ((x (assoc (cons window event-type) window-methods))) (if x (apply (cadr x) (list event))))) scheme2c-2012.10.14/xlib/xlib.sc000066400000000000000000000011161203736146400160230ustar00rootroot00000000000000(module xlib (with depth screen visual xarc xchar2b xcharstruct xclasshint xcolor xcomposestatus xevent xfontprop xfontstruct xgcvalues xhostaddress xiconsize ximage xkeyboardcontrol xkeyboardstate xlibCONSTANTS xlibTYPES xlibSTUBS xmodifierkeymap xpixmapformatvalues xpoint xrectangle xrmoptiondescrec xrmvalue xsegment xsetwindowattributes xsizehints xstandardcolormap xtextitem xtextitem16 xtextproperty xtimecoord xvisualinfo xwindowattributes xwindowchanges xwmhints xws10 xws2 xws3 xws4 xws5 xws6 xws7 xws8 xws9 xwsr4 xwss )) scheme2c-2012.10.14/xlib/xws10.cdecl000066400000000000000000000165601203736146400165250ustar00rootroot00000000000000;;; 10.1 Keyboard Event Functions (extern KeySym "XLookupKeysym" (XEventP event) (int col)) (extern void "XRefreshKeyboardMapping" (XEventP event)) (extern int "XLookupString" (XEventP event) (charAP buffer) (int bytes_buffer) (out KeySym keysym_return) (XComposeStatusP status)) (extern void "XRebindKeysym" (DisplayP dpy) (KeySym keysym) (KeySymAP mlist) (int nm) (string str) (int nbytes)) (extern KeySym "XStringToKeysym" (string s)) (extern string "XKeysymToString" (KeySym ks)) (extern KeySym "XKeycodeToKeysym" (DisplayP dpy) (KeyCode kc) (int col)) (extern KeyCode "XKeysymToKeycode" (DisplayP dpy) (KeySym ks)) ;;; 10.2 Obtaining the X Environment Defaults (extern string "XGetDefault" (DisplayP dpy) (string prog) (string name)) (extern string "XResourceManagerString" (DisplayP dpy)) ;;; 10.3 Parsing the Window Geometry (extern int "XParseGeometry" (string string) (out int x) (out int y) (out unsignedint width) (out unsignedint height)) (extern int "XGeometry" (DisplayP dpy) (int screen) (string pos) (string def) (unsignedint bwidth) (unsignedint fwidth) (unsignedint fheight) (int xadd) (int yadd) (out int x) (out int y) (out int width) (out int height)) ;;; 10.4 Parsing the Color Specifications (extern Status "XParseColor" (DisplayP dpy) (Colormap cmap) (string spec) (out XColor def)) ;;; 10.5 Generating Regions (extern Region "XPolygonRegion" (XPointAP Pts) (int Count) (int rule)) (extern void "XClipBox" (Region r) (out XRectangle rect)) ;;; 10.6.1 Creating, Copying, or Destroying Regions (extern Region "XCreateRegion") (extern void "XSetRegion" (DisplayP dpy) (GC gc) (Region r)) (extern void "XDestroyRegion" (Region r)) ;;; 10.6.2 Moving or Shrinking Regions (extern void "XOffsetRegion" (Region pRegion) (int x) (int y)) (extern void "XShrinkRegion" (Region r) (int dx) (int dy)) ;;; 10.6.3 Computing with Regions (extern void "XIntersectRegion" (Region reg1) (Region reg2) (out Region newReg)) (extern void "XUnionRegion" (Region reg1) (Region reg2) (out Region newReg)) (extern void "XUnionRectWithRegion" (XRectangleP rect) (Region source) (out Region dest)) (extern void "XSubtractRegion" (Region regM) (Region regS) (out Region regD)) (extern void "XXorRegion" (Region sra) (Region srb) (out Region dr)) ;;; 10.6.4 Determining if Regions are Empty or Equal (extern int "XEmptyRegion" (Region r)) (extern int "XEqualRegion" (Region r1) (Region r2)) ;;; 10.6.5 Locating a Point or a Rectangle in a Region (extern int "XPointInRegion" (Region pRegion) (int x) (int y)) (extern int "XRectInRegion" (Region region) (int rx) (int ry) (unsignedint rwidth) (unsignedint rheight)) ;;; 10.7 Using the Cut and Paste Buffers (extern void "XStoreBytes" (DisplayP dpy) (charAP bytes) (int nbytes)) (extern void "XStoreBuffer" (DisplayP dpy) (charAP bytes) (int nbytes) (int buffer)) (extern charAP "XFetchBytes" (DisplayP dpy) (out int nbytes)) (extern charAP "XFetchBuffer" (DisplayP dpy) (out int nbytes) (int buffer)) (extern void "XRotateBuffers" (DisplayP dpy) (int rotate)) ;;; 10.8 Determining the Appropriate Visual Type (extern XVisualInfoP "XGetVisualInfo" (DisplayP dpy) (long visual_info_mask) (XVisualInfoP visual_info_template) (out int nitems)) (extern Status "XMatchVisualInfo" (DisplayP dpy) (int screen) (int depth) (int class) (out XVisualInfo visual_info)) ;;; 10.9 Manipulating Images (extern XImageP "XCreateImage" (DisplayP dpy) (VisualP visual) (unsignedint depth) (int format) (int offset) (charP data) (unsignedint width) (unsignedint height) (int xpad) (int image_bytes_per_line)) (extern long "XGetPixel" (XImageP ximage) (int x) (int y)) (extern int "XPutPixel" (XImageP ximage) (int x) (int y) (unsignedlong pixel)) (extern XImageP "XSubImage" (XImageP ximage) (int x) (int y) (unsignedint width) (unsignedint height)) (extern void "XAddPixel" (XImageP ximage) (unsignedlong value)) (extern int "XDestroyImage" (XImageP ximage)) ;;; 10.10 Manipulating Bitmaps (extern int "XReadBitmapFile" (DisplayP display) (Drawable d) (string filename) (out unsignedint width) (out unsignedint height) (out Pixmap pixmap) (out int x_hot) (out int y_hot)) (extern int "XWriteBitmapFile" (DisplayP display) (string filename) (Pixmap bitmap) (unsignedint width) (unsignedint height) (int x_hot) (int y_hot)) (extern Pixmap "XCreatePixmapFromBitmapData" (DisplayP display) (Drawable d) (charP data) (unsignedint width) (unsignedint height) (unsignedlong fg) (unsignedlong bg) (unsignedint depth)) (extern Pixmap "XCreateBitmapFromData" (DisplayP display) (Drawable d) (charP data) (unsignedint width) (unsignedint height)) ;;; 10.11.2 Basic Resource Manager Definitions (extern void "XrmInitialize") (extern XrmQuark "XrmUniqueQuark") (extern charP "Xpermalloc" (unsignedint length)) (extern XrmQuark "XrmStringToQuark" (XrmString name)) (extern XrmString "XrmQuarkToString" (XrmQuark quark)) (extern void "XrmStringToQuarkList" (string name) (out XrmQuarkList quarks)) (extern void "XrmStringToBindingQuarkList" (string name) (out XrmBindingList bindings) (out XrmQuarkList quarks)) ;;; 10.11.3.1 Storing into a Resource Database (extern void "XrmPutResource" (XrmDatabaseP pdb) (string specifier) (string type) (XrmValuePtr value)) (extern void "XrmQPutResource" (XrmDatabaseP pdb) (XrmBindingList bindings) (XrmQuarkList quarks) (XrmRepresentation type) (XrmValuePtr value)) (extern void "XrmPutStringResource" (XrmDatabaseP pdb) (string specifier) (string str)) (extern void "XrmQPutStringResource" (XrmDatabaseP pdb) (XrmBindingList bindings) (XrmQuarkList quarks) (string str)) (extern void "XrmPutLineResource" (XrmDatabaseP pdb) (string line)) ;;; 10.11.3.2 Looking Up from a Resource Database (extern Bool "XrmGetResource" (XrmDataBase db) (string name_str) (string class_str) (out string pType_str) (out XrmValue pValue)) (extern Bool "XrmQGetResource" (XrmHashBucket db) (XrmNameList names) (XrmClassList classes) (out XrmRepresentation pType) (out XrmValuePtr pValue)) ;;; 10.11.3.3 Database Search Lists (extern Bool "XrmQGetSearchList" (XrmHashBucket db) (XrmNameList names) (XrmClassList classes) ; (XrmSearchList searchList) (int searchlist) (int listLength)) (extern Bool "XrmQGetSearchResource" (int searchlist) ; (XrmSearchList searchList) (XrmName name) (XrmClass class) (out XrmRepresentation pType) (out XrmValue pVal)) ;;; 10.11.3.4 Merging Resource Databases (extern void "XrmMergeDatabases" (XrmDatabase new) (XrmDatabaseP into)) ;;; 10.11.3.5 Retrieving and Storing Database (extern XrmDatabase "XrmGetFileDatabase" (string fileName)) (extern void "XrmPutFileDatabase" (XrmDatabase db) (string fileName)) (extern XrmDatabase "XrmGetStringDatabase" (string data)) ;;; 10.11.4 Parsing Command Line Options (extern void "XrmParseCommand" (XrmDatabaseP pdb) (XrmOptionDescList options) (int num_options) (string prefix) (intP argc) (charPAP argv)) ;;; 10.12 Using the Context Manager (extern int "XSaveContext" (DisplayP display) (Window window) (XContext context) (caddr_t data)) (extern int "XFindContext" (DisplayP display) (Window window) (XContext context) (out caddr_t data)) (extern int "XDeleteContext" (DisplayP display) (Window window) (XContext context)) ;;; Unique Context documented in Xlib but non-existent in R3 source... scheme2c-2012.10.14/xlib/xws2.cdecl000066400000000000000000000056501203736146400164440ustar00rootroot00000000000000;;; Display functions ;;; 2.1 Opening the Display (extern DisplayP "XOpenDisplay" (string display)) ;;; 2.2.1 Display Macros (extern long "XAllPlanes") (extern long "XBlackPixel" (DisplayP dpy) (int scr)) (extern long "XWhitePixel" (DisplayP dpy) (int scr)) (extern int "XConnectionNumber" (DisplayP dpy)) (extern Colormap "XDefaultColormap" (DisplayP dpy) (int scr)) (extern int "XDefaultDepth" (DisplayP dpy) (int scr)) (extern GC "XDefaultGC" (DisplayP dpy) (int scr)) (extern Window "XDefaultRootWindow" (DisplayP dpy)) (extern ScreenP "XDefaultScreenOfDisplay" (DisplayP dpy)) (extern ScreenP "XScreenOfDisplay" (DisplayP dpy) (int scr)) (extern int "XDefaultScreen" (DisplayP dpy)) (extern VisualP "XDefaultVisual" (DisplayP dpy) (int scr)) (extern int "XDisplayCells" (DisplayP dpy) (int scr)) (extern int "XDisplayPlanes" (DisplayP dpy) (int scr)) (extern string "XDisplayString" (DisplayP dpy)) (extern long "XLastKnownRequestProcessed" (DisplayP dpy)) (extern long "XNextRequest" (DisplayP dpy)) (extern int "XProtocolVersion" (DisplayP dpy)) (extern int "XProtocolRevision" (DisplayP dpy)) (extern int "XQLength" (DisplayP dpy)) (extern Window "XRootWindow" (DisplayP dpy) (int scr)) (extern int "XScreenCount" (DisplayP dpy)) (extern string "XServerVendor" (DisplayP dpy)) (extern int "XVendorRelease" (DisplayP dpy)) ;;; 2.2.2 Image Format Macros (extern int "XImageByteOrder" (DisplayP dpy)) (extern int "XBitmapUnit" (DisplayP dpy)) (extern int "XBitmapBitOrder" (DisplayP dpy)) (extern int "XBitmapPad" (DisplayP dpy)) (extern int "XDisplayHeight" (DisplayP dpy) (int scr)) (extern int "XDisplayHeightMM" (DisplayP dpy) (int scr)) (extern int "XDisplayWidth" (DisplayP dpy) (int scr)) (extern int "XDisplayWidthMM" (DisplayP dpy) (int scr)) ;;; 2.2.3 Screen Information Macros (extern long "XBlackPixelOfScreen" (ScreenP s)) (extern long "XWhitePixelOfScreen" (ScreenP s)) (extern int "XCellsOfScreen" (ScreenP s)) (extern Colormap "XDefaultColormapOfScreen" (ScreenP s)) (extern int "XDefaultDepthOfScreen" (ScreenP s)) (extern GC "XDefaultGCOfScreen" (ScreenP s)) (extern VisualP "XDefaultVisualOfScreen" (ScreenP s)) (extern int "XDoesBackingStore" (ScreenP s)) (extern Bool "XDoesSaveUnders" (ScreenP s)) (extern DisplayP "XDisplayOfScreen" (ScreenP s)) (extern long "XEventMaskOfScreen" (ScreenP s)) (extern int "XWidthOfScreen" (ScreenP s)) (extern int "XHeightOfScreen" (ScreenP s)) (extern int "XWidthMMOfScreen" (ScreenP s)) (extern int "XHeightMMOfScreen" (ScreenP s)) (extern int "XMaxCmapsOfScreen" (ScreenP s)) (extern int "XMinCmapsOfScreen" (ScreenP s)) (extern int "XPlanesOfScreen" (ScreenP s)) (extern Window "XRootWindowOfScreen" (ScreenP s)) ;;; 2.3 Generating a NoOperation Protocol Request (extern void "XNoOp" (DisplayP dpy)) ;;; 2.4 Freeing Client-Created Data (extern void "XFree" (unsignedint data)) ;;; 2.5 Closing the Display (extern void "XCloseDisplay" (DisplayP dpy)) scheme2c-2012.10.14/xlib/xws3.cdecl000066400000000000000000000053051203736146400164420ustar00rootroot00000000000000;;; Window Functions ;;; 3.1 Visual Types (extern VisualID "XVisualIDFromVisual" (VisualP visual)) ;;; 3.3 Creating Windows (extern Window "XCreateWindow" (DisplayP dpy) (Window parent) (int x) (int y) (unsignedint width) (unsignedint height) (unsignedint borderWidth) (int depth) (unsignedint class) (VisualP visual) (unsignedlong valuemask) (XSetWindowAttributesP attributes)) (extern Window "XCreateSimpleWindow" (DisplayP dpy) (Window parent) (int x) (int y) (unsignedint width) (unsignedint height) (unsignedint borderWidth) (unsignedlong border) (unsignedlong background)) ;;; 3.4 Destroying Windows (extern void "XDestroyWindow" (DisplayP dpy) (Window w)) (extern void "XDestroySubwindows" (DisplayP dpy) (Window win)) ;;; 3.5 Mapping Windows (extern void "XMapWindow" (DisplayP dpy) (Window w)) (extern void "XMapRaised" (DisplayP dpy) (Window w)) (extern void "XMapSubwindows" (DisplayP dpy) (Window win)) ;;; 3.6 Unmapping Windows (extern void "XUnmapWindow" (DisplayP dpy) (Window w)) (extern void "XUnmapSubwindows" (DisplayP dpy) (Window win)) ;;; 3.7 Configuring Windows (extern void "XConfigureWindow" (DisplayP dpy) (Window w) (unsignedint mask) (XWindowChangesP changes)) (extern void "XMoveWindow" (DisplayP dpy) (Window w) (int x) (int y)) (extern void "XResizeWindow" (DisplayP dpy) (Window w) (unsignedint width) (unsignedint height)) (extern void "XMoveResizeWindow" (DisplayP dpy) (Window w) (int x) (int y) (unsignedint width) (unsignedint height)) (extern void "XSetWindowBorderWidth" (DisplayP dpy) (Window w) (unsignedint width)) ;;; 3.8 Changing Window Stacking Order (extern void "XRaiseWindow" (DisplayP dpy) (Window w)) (extern void "XLowerWindow" (DisplayP dpy) (Window w)) (extern void "XCirculateSubwindows" (DisplayP dpy) (Window w) (int direction)) (extern void "XCirculateSubwindowsUp" (DisplayP dpy) (Window w)) (extern void "XCirculateSubwindowsDown" (DisplayP dpy) (Window w)) (extern void "XRestackWindows" (DisplayP dpy) (unsignedAP windows) (unsigned count)) ;;; 3.9 Changing Window Attributes (extern void "XChangeWindowAttributes" (DisplayP dpy) (Window w) (unsignedlong valuemask) (XSetWindowAttributesP attributes)) (extern void "XSetWindowBackground" (DisplayP dpy) (Window w) (unsignedlong pixel)) (extern void "XSetWindowBackgroundPixmap" (DisplayP dpy) (Window w) (Pixmap pixmap)) (extern void "XSetWindowBorder" (DisplayP dpy) (Window w) (unsignedlong pixel)) (extern void "XSetWindowBorderPixmap" (DisplayP dpy) (Window w) (Pixmap pixmap)) (extern int "XTranslateCoordinates" (DisplayP dpy) (Window src_win) (Window dest_win) (int src_x) (int src_y) (out int dst_x) (out int dst_y) (out Window child)) scheme2c-2012.10.14/xlib/xws4.cdecl000066400000000000000000000037651203736146400164530ustar00rootroot00000000000000;;; Window Information Functions ;;; 4.1 Obtaining Window Information (extern Status "XQueryTree" (DisplayP dpy) (Window w) (out Window root) (out Window parent) (out WindowAP children) (out unsignedint nchildren)) (extern Status "XGetWindowAttributes" (DisplayP dpy) (Window w) (out XWindowAttributes att)) (extern Status "XGetGeometry" (DisplayP dpy) (Drawable d) (out Window root) (out int x) (out int y) (out unsignedint width) (out unsignedint height) (out unsignedint borderWidth) (out unsignedint depth)) (extern Bool "XQueryPointer" (DisplayP dpy) (Window w) (out Window root) (out Window child) (out int root_x) (out int root_y) (out int win_x) (out int win_y) (out unsignedint mask)) ;;; 4.2 Properties and Atoms (extern Atom "XInternAtom" (DisplayP dpy) (string name) (Bool onlyIfExists)) (extern charAP "XGetAtomName" (DisplayP dpy) (Atom atom)) ;;; 4.3 Obtaining and Changing Window Properties (extern int "XGetWindowProperty" ;;; A wrapper might be useful here (DisplayP dpy) ;;; once we see how it is used. (Window w) (Atom property) (long offset) (long length) (Bool delete) (Atom req_type) (out Atom actual_type) (out int actual_format) (out unsignedlong nitems) (out unsignedlong bytesafter) (out charAP prop)) (extern AtomAP "XListProperties" (DisplayP dpy) (Window w) (out int num_prop)) (extern void "XChangeProperty" (DisplayP dpy) (Window w) (Atom property) (Atom type) (int format) (int mode) (charAP data) (int nelements)) (extern void "XRotateWindowProperties" (DisplayP dpy) (Window w) (AtomAP properties) (int nprops) (int npositions)) (extern void "XDeleteProperty" (DisplayP dpy) (Window window) (Atom property)) ;;; 4.4 Selections (extern void "XSetSelectionOwner" (DisplayP dpy) (Atom selection) (Window owner) (Time time)) (extern Window "XGetSelectionOwner" (DisplayP dpy) (Atom selection)) (extern void "XConvertSelection" (DisplayP dpy) (Atom selection) (Atom target) (Atom property) (Window requestor) (Time time)) scheme2c-2012.10.14/xlib/xws5.cdecl000066400000000000000000000116311203736146400164430ustar00rootroot00000000000000;;; Graphics Resource Functions ;;; 5.1.1 Creating, Copying, and Destroying Color Maps (extern Colormap "XCreateColormap" (DisplayP dpy) (Window w) (VisualP visual) (int alloc)) (extern Colormap "XCopyColormapAndFree" (DisplayP dpy) (Colormap src_cmap)) (extern void "XSetWindowColormap" (DisplayP dpy) (Window w) (Colormap colormap)) (extern void "XFreeColormap" (DisplayP dpy) (Colormap cmap)) ;;; 5.1.2 Allocating, Modifying, and Freeing Color Cells (extern Status "XAllocColor" (DisplayP dpy) (Colormap cmap) (XColorP def)) (extern Status "XAllocNamedColor" (DisplayP dpy) (Colormap cmap) (string colorname) (out XColor hard_def) (out XColor exact_def)) (extern Status "XLookupColor" (DisplayP dpy) (Colormap cmap) (string spec) (out XColor def) (out XColor scr)) (extern Status "XAllocColorCells" (DisplayP dpy) (Colormap cmap) (Bool contig) (unsignedlongAP masks) (unsignedint nplanes) (unsignedlongAP pixels) (unsignedint ncolors)) (extern Status "XAllocColorPlanes" (DisplayP dpy) (Colormap cmap) (Bool contig) (unsignedAP pixels) (int ncolors) (int nreds) (int ngreens) (int nblues) (out unsignedlong rmask) (out unsignedlong gmask) (out unsignedlong bmask)) (extern void "XStoreColors" (DisplayP dpy) (Colormap cmap) (XColorAP defs) (int ncolors)) (extern void "XStoreColor" (DisplayP dpy) (Colormap cmap) (XColorP def)) (extern void "XStoreNamedColor" (DisplayP dpy) (Colormap cmap) (string name) (unsignedlong pixel) (int flags)) (extern void "XFreeColors" (DisplayP dpy) (Colormap cmap) (unsignedAP pixels) (int npixels) (unsignedlong planes)) ;;; 5.1.3 Reading Entries in a Color Map (extern void "XQueryColor" (DisplayP dpy) (Colormap cmap) (XColorP def)) (extern void "XQueryColors" (DisplayP dpy) (Colormap cmap) (XColorAP defs) (int ncolors)) ;;; 5.2 Creating and Freeing Pixmaps (extern Pixmap "XCreatePixmap" (DisplayP dpy) (Drawable d) (unsignedint width) (unsignedint height) (unsignedint depth)) (extern void "XFreePixmap" (DisplayP dpy) (Pixmap pixmap)) ;;; 5.3 Manipulating Graphics Context/State (extern GC "XCreateGC" (DisplayP dpy) (Drawable d) (unsignedlong valuemask) (XGCValuesP values)) (extern void "XCopyGC" (DisplayP dpy) (GC srcGC) (unsignedlong mask) (GC destGC)) (extern void "XChangeGC" (DisplayP dpy) (GC gc) (unsignedlong valuemask) (XGCValuesP values)) (extern void "XFreeGC" (DisplayP dpy) (GC gc)) (extern GContext "XGContextFromGC" (GC gc)) ;;; 5.4.1 Setting the Foreground, Background, Function, or Plane Mask (extern void "XSetState" (DisplayP dpy) (GC gc) (unsignedlong foreground) (unsignedlong background) (int function) (unsignedlong planemask)) (extern void "XSetForeground" (DisplayP dpy) (GC gc) (unsignedlong foreground)) (extern void "XSetBackground" (DisplayP dpy) (GC gc) (unsignedlong background)) (extern void "XSetFunction" (DisplayP dpy) (GC gc) (int function)) (extern void "XSetPlaneMask" (DisplayP dpy) (GC gc) (unsignedlong planemask)) ;;; 5.4.2 Setting the Line Attributes and Dashes (extern void "XSetLineAttributes" (DisplayP dpy) (GC gc) (unsignedint linewidth) (int linestyle) (int capstyle) (int joinstyle)) (extern void "XSetDashes" (DisplayP dpy) (GC gc) (int dash_offset) (charAP list) (int n)) ;;; 5.4.3 Setting the Fill Style and Fill Rule (extern void "XSetFillStyle" (DisplayP dpy) (GC gc) (int fill_style)) (extern void "XSetFillRule" (DisplayP dpy) (GC gc) (int fill_rule)) ;;; 5.4.4 Setting the Fill Tile and Stipple (extern Status "XQueryBestSize" (DisplayP dpy) (int class) (Drawable drawable) (unsignedint width) (unsignedint height) (out unsignedint ret_width) (out unsignedint ret_height)) (extern Status "XQueryBestTile" (DisplayP dpy) (Drawable drawable) (unsignedint width) (unsignedint height) (out unsignedint ret_width) (out unsignedint ret_height)) (extern Status "XQueryBestStipple" (DisplayP dpy) (Drawable drawable) (unsignedint width) (unsignedint height) (out unsignedint ret_width) (out unsignedint ret_height)) (extern void "XSetTile" (DisplayP dpy) (GC gc) (Pixmap tile)) (extern void "XSetStipple" (DisplayP dpy) (GC gc) (Pixmap stipple)) (extern void "XSetTSOrigin" (DisplayP dpy) (GC gc) (int x) (int y)) ;;; 5.4.5 Setting the Current Font (extern void "XSetFont" (DisplayP dpy) (GC gc) (Font font)) ;;; 5.4.6 Setting the Clip Region (extern void "XSetClipOrigin" (DisplayP dpy) (GC gc) (int xorig) (int yorig)) (extern void "XSetClipMask" (DisplayP dpy) (GC gc) (Pixmap mask)) (extern void "XSetClipRectangles" (DisplayP dpy) (GC gc) (int clip_x_origin) (int clip_y_origin) (XRectangleAP rectangles) (int n) (int ordering)) ;;; 5.4.7 Setting the Arc Mode, Subwindow Mode, and Graphics Exposure (extern void "XSetArcMode" (DisplayP dpy) (GC gc) (int arc_mode)) (extern void "XSetSubwindowMode" (DisplayP dpy) (GC gc) (int subwindow_mode)) (extern void "XSetGraphicsExposures" (DisplayP dpy) (GC gc) (Bool graphics_exposures)) scheme2c-2012.10.14/xlib/xws6.cdecl000066400000000000000000000161121203736146400164430ustar00rootroot00000000000000;;; Graphics Functions ;;; 6.1 Clearing Areas (extern void "XClearWindow" (DisplayP dpy) (Window w)) (extern void "XClearArea" (DisplayP dpy) (Window w) (int x) (int y) (unsignedint width) (unsignedint height) (Bool exposures)) ;;; 6.2 Copying Areas (extern void "XCopyArea" (DisplayP dpy) (Drawable src_drawable) (Drawable dst_drawable) (GC gc) (int src_x) (int src_y) (unsignedint width) (unsignedint height) (int dst_x) (int dst_y)) (extern void "XCopyPlane" (DisplayP dpy) (Drawable src_drawable) (Drawable dst_drawable) (GC gc) (int src_x) (int src_y) (unsignedint width) (unsignedint height) (int dst_x) (int dst_y) (unsignedlong bit_plane)) ;;; 6.3.1 Drawing Single and Multiple Points (extern void "XDrawPoint" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y)) (extern void "XDrawPoints" (DisplayP dpy) (Drawable d) (GC gc) (XPointAP points) (int n_points) (int mode)) ;;; 6.3.2 Drawing Single and Multiple Lines (extern void "XDrawLine" (DisplayP dpy) (Drawable d) (GC gc) (int x1) (int y1) (int x2) (int y2)) (extern void "XDrawLines" (DisplayP dpy) (Drawable d) (GC gc) (XPointAP points) (int npoints) (int mode)) (extern void "XDrawSegments" (DisplayP dpy) (Drawable d) (GC gc) (XSegmentAP segments) (int nsegments)) ;;; 6.3.3 Drawing Single and Multiple Rectangles (extern void "XDrawRectangle" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (unsignedint width) (unsignedint height)) (extern void "XDrawRectangles" (DisplayP dpy) (Drawable d) (GC gc) (XRectangleAP rects) (int n_rects)) ;;; 6.3.4 Drawing Single and Multiple Arcs (extern void "XDrawArc" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (unsignedint width) (unsignedint height) (int angle1) (int angle2)) (extern void "XDrawArcs" (DisplayP dpy) (Drawable d) (GC gc) (XArcAP arcs) (int n_arcs)) ;;; 6.4.1 Filling Single and Multiple Rectangles (extern void "XFillRectangle" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (unsignedint width) (unsignedint height)) (extern void "XFillRectangles" (DisplayP dpy) (Drawable d) (GC gc) (XRectangleAP rectangles) (int n_rects)) ;;; 6.4.2 Filling a Single Polygon (extern void "XFillPolygon" (DisplayP dpy) (Drawable d) (GC gc) (XPointAP points) (int n_points) (int shape) (int mode)) ;;; 6.4.3 Filling Single and Multiple Arcs (extern void "XFillArc" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (unsignedint width) (unsignedint height) (int angle1) (int angle2)) (extern void "XFillArcs" (DisplayP dpy) (Drawable d) (GC gc) (XArcAP arcs) (int n_arcs)) ;;; 6.5.1 Loading and Freeing Fonts (extern Font "XLoadFont" (DisplayP dpy) (string name)) (extern XFontStructP "XQueryFont" (DisplayP dpy) (Font fid)) (extern XFontStructP "XLoadQueryFont" (DisplayP dpy) (string name)) (extern void "XFreeFont" (DisplayP dpy) (XFontStructP fs)) (extern Bool "XGetFontProperty" (XFontStructP fs) (Atom name) (out unsignedlong valuePtr)) (extern void "XUnloadFont" (DisplayP dpy) (Font font)) ;;; 6.5.2 Obtaining and Freeing Font Names and Information (extern charPAP "XListFonts" (DisplayP dpy) (string pattern) (int maxnames) (out int actual_count)) (extern void "XFreeFontNames" (charPAP list)) (extern charPAP "XListFontsWithInfo" (DisplayP dpy) (string pattern) (int maxnames) (out int actual_count) (out XFontStructAP info)) (extern void "XFreeFontInfo" (charPAP names) (XFontStructAP info) (int count)) ;;; 6.5.3 Setting and Retrieving the Font Search Path (extern void "XSetFontPath" (DisplayP dpy) (charPAP directories) (int ndirs)) (extern charPAP "XGetFontPath" (DisplayP dpy) (int npaths)) (extern charPAP "XFreeFontPath" (charPAP list)) ;;; 6.5.4 Computing Character String Sizes (extern int "XTextWidth" (XFontStructP fontstruct) (string string) (int count)) (extern int "XTextWidth16" (XFontStructP fontstruct) (XChar2bAP string) (int count)) ;;; 6.5.5 Computing Logical Extents (extern void "XTextExtents" (XFontStructP fontstruct) (string string) (int nchars) (out int dir) (out int font_ascent) (out int font_descent) (out XCharStruct overall)) (extern void "XTextExtents16" (XFontStructP fontstruct) (XChar2bAP string) (int nchars) (out int dir) (out int font_ascent) (out int font_descent) (out XCharStruct overall)) ;;; 6.5.6 Querying Character String Sizes (extern void "XQueryTextExtents" (DisplayP dpy) (Font fid) (string string) (int nchars) (out int dir) (out int font_ascent) (out int font_descent) (out XCharStruct overall)) (extern void "XQueryTextExtents16" (DisplayP dpy) (Font fid) (XChar2bAP string) (int nchars) (out int dir) (out int font_ascent) (out int font_descent) (out XCharStruct overall)) ;;; 6.6.1 Drawing Complex Text (extern void "XDrawText" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (XTextItemAP items) (int nitems)) (extern void "XDrawText16" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (XTextItem16P items) (int nitems)) ;;; 6.6.2 Drawing Text Characters (extern void "XDrawString" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (string string) (int length)) (extern void "XDrawString16" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (XChar2bAP string) (int length)) ;;; 6.6.3 Drawing Image Text Characters (extern void "XDrawImageString" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (string string) (int length)) (extern void "XDrawImageString16" (DisplayP dpy) (Drawable d) (GC gc) (int x) (int y) (XChar2bAP string) (int length)) ;;; 6.7 Transferring Images between Client and Server (extern void "XPutImage" (DisplayP dpy) (Drawable d) (GC gc) (XImageP image) (int req_xoffset) (int req_yoffset) (int x) (int y) (unsignedint req_width) (unsignedint req_height)) (extern XImageP "XGetImage" (DisplayP dpy) (Drawable d) (int x) (int y) (unsignedint width) (unsignedint height) (unsignedlong plane_mask) (int format)) (extern XImageP "XGetSubImage" (DisplayP dpy) (Drawable d) (int x) (int y) (unsignedint width) (unsignedint height) (unsignedlong plane_mask) (int format) (XImageP dest_image) (int dest_x) (int dest_y)) ;;; 6.8.1 Creating a Cursor (extern Cursor "XCreateFontCursor" (DisplayP dpy) (unsignedint which)) (extern Cursor "XCreatePixmapCursor" (DisplayP dpy) (Pixmap source) (Pixmap mask) (XColorP foreground) (XColorP background) (unsignedint x) (unsignedint y)) (extern Cursor "XCreateGlyphCursor" (DisplayP dpy) (Font source_font) (Font mask_font) (unsignedint source_char) (unsignedint mask_char) (XColorP foreground) (XColorP background)) ;;; 6.8.2 Changing and Destroying Cursors (extern void "XRecolorCursor" (DisplayP dpy) (Cursor cursor) (XColorP foreground) (XColorP background)) (extern void "XFreeCursor" (DisplayP dpy) (Cursor cursor)) (extern Status "XQueryBestCursor" (DisplayP dpy) (Drawable drawable) (unsignedint width) (unsignedint height) (out unsignedint ret_width) (out unsignedint ret_height)) ;;; 6.8.3 Defining the Cursor (extern void "XDefineCursor" (DisplayP dpy) (Window w) (Cursor cursor)) (extern void "XUndefineCursor" (DisplayP dpy) (Window w)) scheme2c-2012.10.14/xlib/xws7.cdecl000066400000000000000000000126261203736146400164520ustar00rootroot00000000000000;;; 7.1 Changing the Parent of a Window (extern void "XReparentWindow" (DisplayP dpy) (Window w) (Window p) (int x) (int y)) ;;; 7.2 Controlling the Lifetime of a Window (extern void "XChangeSaveSet" (DisplayP dpy) (Window win) (int mode)) (extern void "XAddToSaveSet" (DisplayP dpy) (Window win)) (extern void "XRemoveFromSaveSet" (DisplayP dpy) (Window win)) ;;; 7.3 Determining Resident Colormaps (extern void "XInstallColormap" (DisplayP dpy) (Colormap cmap)) (extern void "XUninstallColormap" (DisplayP dpy) (Colormap cmap)) (extern ColormapAP "XListInstalledColormaps" (DisplayP dpy) (Window w) (out int num)) ;;; 7.4 Pointer Grabbing (extern int "XGrabPointer" (DisplayP dpy) (Window grab_window) (Bool owner_events) (unsignedint event_mask) (int pointer_mode) (int keyboard_mode) (Window confine_to) (Cursor curs) (Time time)) (extern void "XUngrabPointer" (DisplayP dpy) (Time time)) (extern void "XChangeActivePointerGrab" (DisplayP dpy) (unsignedint event_mask) (Cursor curs) (Time time)) (extern void "XGrabButton" (DisplayP dpy) (unsignedint button) (unsignedint modifiers) (Window grab_window) (Bool owner_events) (unsignedint event_mask) (int pointer_mode) (int keyboard_mode) (Window confine_to) (Cursor curs)) (extern void "XUngrabButton" (DisplayP dpy) (unsignedint button) (unsignedint modifiers) (Window grab_window)) ;;; 7.5 Keyboard Grabbing (extern int "XGrabKeyboard" (DisplayP dpy) (Window window) (Bool ownerEvents) (int pointerMode) (int keyboardMode) (Time time)) (extern void "XUngrabKeyboard" (DisplayP dpy) (Time time)) (extern void "XGrabKey" (DisplayP dpy) (int key) (unsignedint modifiers) (Window grab_window) (Bool owner_events) (int pointer_mode) (int keyboard_mode)) (extern void "XUngrabKey" (DisplayP dpy) (int key) (unsignedint modifiers) (Window grab_window)) (extern void "XAllowEvents" (DisplayP dpy) (int mode) (Time time)) ;;; 7.6 Server Grabbing (extern void "XGrabServer" (DisplayP dpy)) (extern void "XUngrabServer" (DisplayP dpy)) ;;; 7.7.1 Controlling Input Focus (extern void "XWarpPointer" (DisplayP dpy) (Window src_win) (Window dest_win) (int src_x) (int src_y) (unsignedint src_width) (unsignedint src_height) (int dest_x) (int dest_y)) (extern void "XSetInputFocus" (DisplayP dpy) (Window focus) (int revert_to) (Time time)) (extern void "XGetInputFocus" (DisplayP dpy) (out Window focus) (out int revert_to)) ;;; 7.7.2 Killing Clients (extern void "XSetCloseDownMode" (DisplayP dpy) (int mode)) (extern void "XKillClient" (DisplayP dpy) (XID resource)) ;;; 7.8 Keyboard and Pointer Settings (extern void "XChangeKeyboardControl" (DisplayP dpy) (unsignedlong mask) (XKeyboardControlP value_list)) (extern void "XGetKeyboardControl" (DisplayP dpy) (out XKeyboardState state)) (extern void "XAutoRepeatOn" (DisplayP dpy)) (extern void "XAutoRepeatOff" (DisplayP dpy)) (extern void "XBell" (DisplayP dpy) (int percent)) (extern void "XQueryKeymap" (DisplayP dpy) (out XQKeymap keys)) (extern int "XSetPointerMapping" (DisplayP dpy) (charAP map) (int nmaps)) (extern int "XGetPointerMapping" (DisplayP dpy) (charAP map) (int nmaps)) (extern void "XChangePointerControl" (DisplayP dpy) (Bool do_acc) (Bool do_thresh) (int acc_numerator) (int acc_denominator) (int threshold)) (extern void "XGetPointerControl" (DisplayP dpy) (out int accel_numer) (out int accel_denom) (out int threshold)) ;;; 7.9 Keyboard Encoding (extern void "XDisplayKeycodes" (DisplayP dpy) (out int min_keycode_return) (out int max_keycode_return)) (extern KeySymAP "XGetKeyboardMapping" (DisplayP dpy) (KeyCode first_keycode) (int count) (out int keysyms_per_keycode)) (extern void "XChangeKeyboardMapping" (DisplayP dpy) (int first_keycode) (int keysyms_per_keycode) (KeySymAP keysyms) (int nkeycodes)) (extern XModifierKeymapP "XNewModifiermap" (int keyspermodifier)) (extern XModifierKeymapP "XInsertModifiermapEntry" (XModifierKeymapP map) (KeyCode keysym) (int modifier)) (extern XModifierKeymapP "XDeleteModifiermapEntry" (XModifierKeymapP map) (KeyCode keysym) (int modifier)) (extern void "XFreeModifiermap" (XModifierKeymapP map)) (extern int "XSetModifierMapping" (DisplayP dpy) (XModifierKeymapP modifier_map)) (extern XModifierKeymapP "XGetModifierMapping" (DisplayP dpy)) ;;; 7.10 Screen Saver Control (extern void "XSetScreenSaver" (DisplayP dpy) (int timeout) (int interval) (int prefer_blank) (int allow_exp)) (extern void "XForceScreenSaver" (DisplayP dpy) (int mode)) (extern void "XActivateScreenSaver" (DisplayP dpy)) (extern void "XResetScreenSaver" (DisplayP dpy)) (extern void "XGetScreenSaver" (DisplayP dpy) (out int timeout) (out int interval) (out int prefer_blanking) (out int allow_exp)) ;;; 7.11.1 Adding, Getting, or Removing Hosts (extern void "XAddHost" (DisplayP dpy) (XHostAddressP host)) (extern void "XAddHosts" (DisplayP dpy) (XHostAddressAP hosts) (int n)) (extern XHostAddressAP "XListHosts" (DisplayP dpy) (out int nhosts) (out Bool enabled)) (extern void "XRemoveHost" (DisplayP dpy) (XHostAddressP host)) (extern void "XRemoveHosts" (DisplayP dpy) (XHostAddressAP hosts) (int n)) ;;; 7.11.2 Changing, Enabling, or Disabling Access Control (extern void "XSetAccessControl" (DisplayP dpy) (int mode)) (extern void "XEnableAccessControl" (DisplayP dpy)) (extern void "XDisableAccessControl" (DisplayP dpy)) scheme2c-2012.10.14/xlib/xws8.cdecl000066400000000000000000000050231203736146400164440ustar00rootroot00000000000000;;; 8.5 Selecting Events (extern void "XSelectInput" (DisplayP dpy) (Window w) (long mask)) ;;; 8.6 Handling the Output Buffer (extern void "XFlush" (DisplayP dpy)) (extern void "XSync" (DisplayP dpy) (Bool discard)) ;;; 8.7 Event Queue Management (extern int "XEventsQueued" (DisplayP dpy) (int mode)) (extern int "XPending" (DisplayP dpy)) ;;; 8.8.1 Returning the Next Event (extern void "XNextEvent" (DisplayP dpy) (out XEvent event)) (extern void "XPeekEvent" (DisplayP dpy) (out XEvent event)) ;;; 8.8.2 Selecting Events Using a Predicate Procedure (extern void "XIfEvent" (DisplayP dpy) (out XEvent event) (BoolPROC predicate) (charP arg)) (extern Bool "XCheckIfEvent" (DisplayP dpy) (out XEvent event) (BoolPROC predicate) (charP arg)) (extern void "XPeekIfEvent" (DisplayP dpy) (out XEvent event) (BoolPROC predicate) (charP arg)) ;;; 8.8.3 Selecting Events Using a Window or Event Mask (extern void "XWindowEvent" (DisplayP dpy) (Window w) (long mask) (out XEvent event)) (extern Bool "XCheckWindowEvent" (DisplayP dpy) (Window w) (long mask) (out XEvent event)) (extern void "XMaskEvent" (DisplayP dpy) (long mask) (out XEvent event)) (extern Bool "XCheckMaskEvent" (DisplayP dpy) (long mask) (out XEvent event)) (extern Bool "XCheckTypedEvent" (DisplayP dpy) (int type) (out XEvent event)) (extern Bool "XCheckTypedWindowEvent" (DisplayP dpy) (Window w) (int type) (out XEvent event)) ;;; 8.9 Putting an Event Back into the Queue (extern void "XPutBackEvent" (DisplayP dpy) (XEventP event)) ;;; 8.10 Sending Events to Other Applications (extern Status "XSendEvent" (DisplayP dpy) (Window w) (Bool propagate) (long event_mask) (XEventP event)) ;;; 8.11 Getting Pointer Motion History (extern long "XDisplayMotionBufferSize" (DisplayP dpy)) (extern XTimeCoordAP "XGetMotionEvents" (DisplayP dpy) (Window w) (Time start) (Time stop) (out int nevents)) ;;; 8.12.1 Enabling or Disabling Synchronization (extern intPROC "XSetAfterFunction" (DisplayP dpy) (intPROC func)) (extern intPROC "XSynchronize" (DisplayP dpy) (int onoff)) ;;; 8.12.2 Using the Default Error Handlers (extern void "XSetErrorHandler" (intPROC handler)) (extern void "XGetErrorText" (DisplayP dpy) (int code) (out char buffer) (int nbytes)) (extern void "XGetErrorDatabaseText" (DisplayP dpy) (string name) (string type) (string defaultp) (out char buffer) (int nbytes)) (extern string "XDisplayName" (string display)) (extern void "XSetIOErrorHandler" (intPROC handler)) scheme2c-2012.10.14/xlib/xws9.cdecl000066400000000000000000000036441203736146400164540ustar00rootroot00000000000000;;; 9.1.1 Setting Standard Properties ;;; YSetStandardProperties is in xwss.sc ;;; 9.1.2 Setting and Getting Window Names (extern void "XStoreName" (DisplayP dpy) (Window w) (string name)) ;;; YFetchName is in xwss.sc ;;; 9.1.3 Setting and Getting Icon Names (extern void "XSetIconName" (DisplayP dpy) (Window w) (string icon_name)) ;;; YGetIconName is in xwss.sc ;;; 9.1.4 Setting the Command ;;; YSetCommand is in xwss.sc ;;; 9.1.5 Getting and Setting Window Manager Hints (extern void "XSetWMHints" (DisplayP dpy) (Window w) (XWMHintsP hints)) ;;; YGetWMHints is in xwss.sc ;;; 9.1.6 Setting and Getting Window Sizing Hints (extern void "XSetNormalHints" (DisplayP dpy) (Window w) (XSizeHintsP hints)) (extern Status "XGetNormalHints" (DisplayP dpy) (Window w) (out XSizeHints hints)) (extern void "XSetZoomHints" (DisplayP dpy) (Window w) (XSizeHintsP zhints)) (extern Status "XGetZoomHints" (DisplayP dpy) (Window w) (out XSizeHints zhints)) (extern void "XSetSizeHints" (DisplayP dpy) (Window w) (XSizeHintsP hints) (Atom property)) (extern Status "XGetSizeHints" (DisplayP dpy) (Window w) (out XSizeHints hints) (Atom property)) ;;; 9.1.7 Setting and Getting Icon Size Hints ;;; YSetIconSizes is in xwss.sc ;;; YGetIconSizes is in xwss.sc ;;; 9.1.8 Setting and Getting the Class of a Window ;;; YSetClassHint is in xwss.sc ;;; YGetClassHint is in xwss.sc ;;; 9.1.9 Setting and Getting the Transient Property (extern void "XSetTransientForHint" (DisplayP dpy) (Window w) (Window propWindow)) (extern Status "XGetTransientForHint" (DisplayP dpy) (Window w) (out Window propWindow)) ;;; 9.2.3 Getting and Setting an XStandardColormap Structure (extern Status "XGetStandardColormap" (DisplayP dpy) (Window w) (out XStandardColormap cmap) (Atom property)) (extern void "XSetStandardColormap" (DisplayP dpy) (Window w) (XStandardColormapP cmap) (Atom property)) scheme2c-2012.10.14/xlib/xwsr4.cdecl000066400000000000000000000101551203736146400166240ustar00rootroot00000000000000;;; X11 R4 extensions to xlib. Section numbers refer to the 2nd edition ;;; of "X Window System", by Scheifler and Gettys. ;;; 2.2.1 Display Macros (extern intAP "XListDepths" (DisplayP dpy) (int screen) (out int count)) ;;; 2.2.2 Image Format Functions and Macros (extern XPixmapFormatValuesAP "XListPixmapFormats" (DisplayP dpy) (out int count)) ;;; 2.2.3 Screen Information Macros (extern int "XScreenNumberOfScreen" (Screenp screen)) ;;; 5.3 Manipulating Graphics Context/State (extern Status "XGetGCValues" (DisplayP dpy) (GC gc) (unsignedlong value_mask) (out XGCValues values)) ;;; 9.1.1 Manipulating Top-level Windows (extern Status "XIconifyWindow" (DisplayP dpy) (Window w) (int screen)) (extern Status "XWithdrawWindow" (DisplayP dpy) (Window w) (int screen)) (extern Status "XReconfigureWMWindow" (DisplayP dpy) (Window w) (int screen) (unsigned value_mask) (XWindowChangesP values)) ;;; 9.1.2 Converting String Lists (extern Status "XStringListToTextProperty" (charPAP list) (int count) (out XTextProperty text_prop)) (extern Status "XTextPropertyToStringList" (XTextPropertyP text_prop) (out charPAP list) (out int count)) (extern void "XFreeStringList" (charPAP list)) ;;; 9.1.3 Setting and Reading Text Properties (extern void "XSetTextProperty" (DisplayP dpy) (Window w) (XTextPropertyP text_prop) (Atom property)) (extern Status "XGetTextProperty" (DisplayP dpy) (Window w) (out XTextProperty text_prop) (Atom property)) ;;; 9.1.4 Setting and Reading the WM_NAME Property (extern void "XSetWMName" (DisplayP dpy) (Window w) (XTextPropertyP text_prop)) (extern Status "XGetWMName" (DisplayP dpy) (Window w) (out XTextProperty text_prop)) ;;; 9.1.5 Setting and Reading the WM_ICON_NAME Property (extern void "XSetWMIconName" (DisplayP dpy) (Window w) (XTextPropertyP text_prop)) (extern Status "XGetWMIconName" (DisplayP dpy) (Window w) (out XTextProperty text_prop)) ;;; 9.1.7 Setting and Reading the WM_NORMAL_HINTS Property (extern void "XSetWMNormalHints" (DisplayP dpy) (Window w) (XSizeHintsP hints)) (extern Status "XGetWMNormalHints" (DisplayP dpy) (Window w) (out XSizeHints hints) (out longint supplied)) (extern void "XSetWMSizeHints" (DisplayP dpy) (Window w) (XSizeHintsP hints) (Atom property)) (extern Status "XGetWMSizeHints" (DisplayP dpy) (Window w) (out XSizeHints hints) (out longint supplied) (Atom property)) ;;; 9.1.10 Setting and Reading the WM_PROTOCOLS Property (extern Status "XSetWMProtocols" (DisplayP dpy) (Window w) (AtomAP protocols) (int count)) (extern Status "XGetWMProtocols" (DisplayP dpy) (Window w) (out AtomAP protocols) (out int count)) ;;; 9.1.11 Setting and Reading the WM_COLORMAP_WINDOWS Property (extern Status "XSetWMColormapWindows" (DisplayP dpy) (Window w) (WindowAP windows) (int count)) (extern Status "XGetWMColormapWindows" (DisplayP display) (Window w) (out WindowAP windows) (out int count)) ;;; 9.1.13 Using Window Manager Convenience Functions (extern void "XSetWMProperties" (DisplayP display) (Window w) (XTextPropertyP window_name) (XTextPropertyP icon_name) (charPAP argv) (int argc) (XSizeHintsP normal_hints) (XWMHintsP wm_hints) (XClassHintP class_hints)) (extern int "XWMGeometry" (DisplayP dpy) (int screen) (string user_geom) (string def_geom) (unsignedint bwidth) (XSizeHintsP hints) (out int x) (out int y) (out int width) (out int height) (out int gravity)) ;;; 9.2.1 Setting and Reading the WM_COMMAND Property (extern Status "XGetCommand" (DisplayP dpy) (Window w) (out charPAP argv) (out int argc)) ;;; 9.2.2 Setting and Reading the WM_CLIENT_MACHINE Property (extern void "XSetWMClientMachine" (DisplayP dpy) (Window w) (XTextPropertyP text_prop)) (extern Status "XGetWMClientMachine" (DisplayP dpy) (Window w) (out XTextProperty text_prop)) ;;; 9.3.2 Setting and Obtaining Standard Colormaps (extern void "XSetRGBColormaps" (DisplayP dpy) (Window w) (XStandardColormapP std_colormap) (int count) (Atom property)) (extern Status "XGetRGBColormaps" (DisplayP dpy) (Window w) (out XStandardColormapP std_colormap) (out int count) (Atom property)) scheme2c-2012.10.14/xlib/xwss.sc000066400000000000000000000355521203736146400161040ustar00rootroot00000000000000;;; This module contains the interface routines which are not automatically ;;; generated. (module xwss) (include "xlibTYPES.sch") (define SIZEOF-PTR c-sizeof-tscp) (define SIZEOF-LONG c-sizeof-long) (define (C-PTR-REF x y) (c-s2cuint-ref x y)) (define (C-PTR-SET! x y z) (c-s2cuint-set! x y z)) ;;; Internal functions. (define (POINTER-LIST->STRING lst typep) (do ((i 0 (+ i 1)) (array (make-string (* sizeof-ptr (length lst)))) (lst lst (cdr lst))) ((null? lst) array) (c-ptr-set! array (* i sizeof-ptr) (typep (car lst))))) (define (ARRAY-POINTER->LIST arrayptr count type) (let loop ((x 0)) (if (eq? x count) '() (cons (if type (cons type (c-ptr-ref arrayptr (* x sizeof-ptr))) (c-ptr-ref arrayptr (* x sizeof-ptr))) (loop (+ x 1)))))) (define-c-external (xfree pointer) void "XFree") (define (CHK-STRING x) (if (string? x) x (error 'CHK-STRING "Argument is incorrect type: ~s" x))) (define (STRING-LIST->STRING-ARRAY strings) (define (STRING-WORDS s) (quotient (+ (string-length s) 4) 4)) (define PTR-WORDS (/ sizeof-ptr 4)) (let* ((array (make-string (let loop ((strings strings) (words 0)) (if (null? strings) (* words 4) (loop (cdr strings) (+ words ptr-words (string-words (car strings)))))) (integer->char 0))) (base-word-addr (+ ((lap (x) (_TSCP (DIFFERENCE (INT x) 1))) array) ptr-words))) (let loop ((offset (* (length strings) ptr-words)) (ptr 0) (strings strings)) (cond (strings (c-ptr-set! array (* ptr sizeof-ptr) (* 4 (+ offset base-word-addr))) (do ((i (* 4 offset)) (string (car strings)) (j (- (string-length (car strings)) 1) (- j 1))) ((= j -1) (loop (+ offset (string-words string)) (+ ptr 1) (cdr strings))) (c-byte-set! array (+ i j) (c-byte-ref string j)))) (else array))))) (define (STRING-ARRAY->STRING-LIST ptr cnt) (let loop ((ptr ptr) (x 0)) (if (eq? x cnt) '() (cons (c-string->string (c-ptr-ref ptr 0)) (loop (+ ptr sizeof-ptr) (+ x 1)))))) (define (COPY-PTR-TO-STRUCT ptr struct) (let* ((array (cdr struct)) (size (string-length array))) (let loop ((x 0)) (unless (eq? x size) (c-byte-set! array x (c-byte-ref ptr x)) (loop (+ x 1)))) struct)) (define (ARRAY-STRUCT->LIST ptr count make-struct) (let loop ((ptr ptr) (x count)) (if (eq? x 0) '() (let* ((struct (copy-ptr-to-struct ptr (make-struct))) (size (string-length (cdr struct)))) (cons struct (loop (+ ptr size) (- x 1))))))) (define (STRUCT-LIST->STRING lst typep) (apply string-append (let loop ((lst lst)) (if (null? lst) '() (cons (typep (car lst)) (loop (cdr lst))))))) ;;; Misc. Utility functions. (define (NULL-POINTER? x) (or (eq? x 0) (and (pair? x) (eq? (cdr x) 0)))) (define (POINTER-TYPE x) (and (pair? x) (car x))) (define (POINTER-VALUE x) (and (pair? x) (cdr x))) (define (TYPE/VALUE->POINTER type value) (cons type value)) ;;; Chapter 2. (define-c-external (xfree* pointer) void "XFree") (define (YFREE ptr) (if (pair? ptr) (xfree* (pointer-value ptr)) (xfree* ptr)) #f) ;;; Chapter 4. (define-c-external (xquerytree* pointer pointer pointer pointer pointer pointer) int "XQueryTree") (define (YQUERYTREE dpy window) (let ((dpy (chk-displayp dpy)) (root (make-string sizeof-long)) (parent (make-string sizeof-long)) (children (make-string sizeof-long)) (nchildren (make-string sizeof-long))) (if (eq? 0 (xquerytree* dpy window root parent children nchildren)) #f (let ((result (list (c-longunsigned-ref root 0) (c-longunsigned-ref parent 0) (array-pointer->list (c-longunsigned-ref children 0) (c-longunsigned-ref nchildren 0) #f)))) (xfree (c-longunsigned-ref children 0)) result)))) (define-c-external (xgetatomname* pointer int) pointer "XGetAtomName") (define (YGETATOMNAME dpy atom) (let* ((dpy (chk-displayp dpy)) (result (xgetatomname* dpy atom)) (name (c-string->string result))) (xfree result) name)) (define-c-external (xlistproperties* pointer unsigned pointer) pointer "XListProperties") (define (YLISTPROPERTIES dpy window) (let* ((dpy (chk-displayp dpy)) (n_props (make-string c-sizeof-int)) (atomap (xlistproperties* dpy window n_props)) (limit (c-int-ref n_props 0))) (let loop ((i 0)) (if (eq? i limit) (begin (xfree atomap) '()) (cons (c-unsigned-ref atomap (* i c-sizeof-long)) (loop (+ i 1))))))) ;;; Chapter 6. (define-external (make-xfontstruct) xfontstruct) (define-c-external (xlistfonts* pointer pointer int pointer) pointer "XListFonts") (define-c-external (xfreefontnames* pointer) void "XFreeFontNames") (define (YLISTFONTS dpy pattern maxnames) (let* ((dpy (chk-displayp dpy)) (pattern (chk-string pattern)) (count (make-string c-sizeof-int)) (charap (xlistfonts* dpy pattern maxnames count)) (result (string-array->string-list charap (c-int-ref count 0)))) (xfreefontnames* charap) result)) (define-c-external (xlistfontswithinfo* pointer pointer int pointer pointer) pointer "XListFontsWithInfo") (define-c-external (xfreefontinfo* pointer pointer int) void "XFreeFontInfo") (define (YLISTFONTSWITHINFO dpy pattern maxnames) (let* ((dpy (chk-displayp dpy)) (pattern (chk-string pattern)) (count_ret (make-string c-sizeof-int)) (info_ret (make-string sizeof-ptr)) (charap (xlistfontswithinfo* dpy pattern maxnames count_ret info_ret)) (count (c-int-ref count_ret 0)) (info (c-ptr-ref info_ret 0)) (result (let loop ((name charap) (info info) (x count)) (if (eq? x 0) '() (let* ((s (make-xfontstruct)) (l (string-length (cdr s)))) (do ((i 0 (+ i 1))) ((eq? i l) (cons (list (c-string->string (c-ptr-ref name 0)) s) (loop (+ name sizeof-ptr) (+ info i) (- x 1)))) (c-byte-set! (cdr s) i (c-byte-ref info i)))))))) (xfreefontinfo* charap info count) result)) (define-c-external (xsetfontpath* pointer pointer int) void "XSetFontPath") (define (YSETFONTPATH dpy directories) (let ((dpy (chk-displayp dpy)) (charap (string-list->string-array directories))) (xsetfontpath* dpy charap (length directories)) directories)) (define-c-external (xgetfontpath* pointer pointer) pointer "XGetFontPath") (define-c-external (xfreefontpath* pointer) void "XFreeFontPath") (define (YGETFONTPATH dpy) (let* ((dpy (chk-displayp dpy)) (npaths (make-string c-sizeof-int)) (charap (xgetfontpath* dpy npaths)) (result (string-array->string-list charap (c-int-ref npaths 0)))) (xfreefontpath* charap) result)) ;;; Chapter 7. (define-c-external (xlistinstalledcolormaps* pointer unsigned pointer) pointer "XListInstalledColormaps") (define (YLISTINSTALLEDCOLORMAPS dpy window) (let* ((dpy (chk-displayp dpy)) (n_ret (make-string c-sizeof-int)) (cmapaddr (xlistinstalledcolormaps* dpy window n_ret)) (result (let loop ((x (c-int-ref n_ret 0)) (cmapaddr cmapaddr)) (if (eq? x 0) '() (cons (c-longunsigned-ref cmapaddr 0) (loop (- x 1) (+ cmapaddr c-sizeof-long))))))) (xfree cmapaddr) result)) (define (FAMILY-ADDRESS->XHOSTADDRESS family address) (let ((array (string-append (make-string (+ (* 2 c-sizeof-int) sizeof-ptr)) address))) (c-int-set! array 0 family) (c-int-set! array c-sizeof-int (string-length address)) (c-ptr-set! array (* 2 c-sizeof-int) (+ ((lap (x) (_TSCP (DIFFERENCE (INT x) 1))) array) (* 2 c-sizeof-int) (* 2 sizeof-ptr))) array)) ;;; Chapter 8. (define-c-external (xnextevent* pointer pointer) void "XNextEvent") (define (YNEXTEVENT dpy event) (xnextevent* (chk-displayp dpy) (chk-xeventp event)) #f) (define-external (fileno port) sc) (define-c-external (select int pointer pointer pointer pointer) int "select") (define (YSELECT dpy . ports-time) (let* ((timeval (make-string (* 2 c-sizeof-int))) (ports (let loop ((x ports-time)) (if (> (length x) 2) (cons (car x) (loop (cdr x))) (begin (c-int-set! timeval 0 (car x)) (c-int-set! timeval c-sizeof-int (cadr x)) '())))) (nfds 0) (file->result (make-vector 32 #f)) (read-mask (let* ((mask (make-string c-sizeof-int)) (xfile (xconnectionnumber dpy))) (vector-set! file->result xfile dpy) (c-unsigned-set! mask 0 (let loop ((ports ports) (mask (bit-lsh 1 xfile)) (maxfile xfile)) (if ports (let* ((port (car ports)) (x (fileno (port->stdio-file port)))) (vector-set! file->result x port) (loop (cdr ports) (bit-or (bit-lsh 1 x) mask) (max x maxfile))) (begin (set! nfds (+ maxfile 1)) mask)))) mask))) (cond ((not (zero? (xpending dpy))) dpy) ((let loop ((ports ports)) (if ports (if (char-ready? (car ports)) (car ports) (loop (cdr ports))) #f))) (else (let* ((nfiles (select nfds read-mask 0 0 timeval)) (bits (c-unsigned-ref read-mask 0))) (cond ((positive? nfiles) (let loop ((mask 1) (index 0)) (if (not (zero? (bit-and bits mask))) (vector-ref file->result index) (loop (+ mask mask) (+ index 1))))) ((= nfiles -1) (apply yselect dpy ports-time)) (else #f))))))) (define-c-external (xgetmotionevents* pointer int int int pointer) pointer "XGetMotionEvents") (define (YGETMOTIONEVENTS dpy window start stop) (let* ((dpy (chk-displayp dpy)) (nevents_ret (make-string c-sizeof-int)) (ptr (xgetmotionevents* dpy window start stop nevents_ret)) (result (let loop ((x (c-int-ref nevents_ret 0)) (ptr ptr)) (if (eq? x 0) '() (cons (list (c-unsigned-ref ptr 0) ; Assumes 32 bit (c-shortint-ref ptr 4) (c-shortint-ref ptr 6)) (loop (- x 1) (+ ptr 6))))))) (xfree ptr) result)) ;;; Chapter 9. (define-c-external (xsetstandardproperties* pointer unsigned pointer pointer unsigned pointer int pointer) void "XSetStandardProperties") (define (YSETSTANDARDPROPERTIES dpy window name icon_string icon_pixmap commands hints) (let ((dpy (chk-displayp dpy)) (name (chk-string name)) (icon_string (chk-string icon_string)) (commands-array (string-list->string-array commands)) (hints (chk-xsizehintsp hints))) (xsetstandardproperties* dpy window name icon_string icon_pixmap commands-array (length commands) hints) #f)) (define-c-external (xfetchname* pointer unsigned pointer) int "XFetchName") (define (YFETCHNAME dpy window) (let* ((dpy (chk-displayp dpy)) (name_ret (make-string c-sizeof-int)) (status (xfetchname* dpy window name_ret)) (name (c-unsigned-ref name_ret 0)) (string (if (or (eq? status 0) (eq? name 0)) #f (c-string->string name)))) (if string (xfree name)) string)) (define-c-external (xgeticonname* pointer unsigned pointer) int "XGetIconName") (define (YGETICONNAME dpy window) (let* ((dpy (chk-displayp dpy)) (name_ret (make-string c-sizeof-int)) (status (xgeticonname* dpy window name_ret)) (name (c-unsigned-ref name_ret 0)) (string (if (or (eq? status 0) (eq? name 0)) #f (c-string->string name)))) (if string (xfree name)) string)) (define-c-external (xsetcommand* pointer pointer pointer int) void "XSetCommand") (define (YSETCOMMAND dpy window commands) (let ((dpy (chk-displayp dpy)) (commands-array (string-list->string-array commands))) (xsetcommand* dpy window commands-array (length commands)) #f)) (define-c-external (xgetwmhints* pointer unsigned) pointer "XGetWMHints") (define-external (make-xwmhints) xwmhints) (define (YGETWMHINTS dpy window) (let* ((dpy (chk-displayp dpy)) (ptr (xgetwmhints* dpy window)) (result (if (eq? ptr 0) #f (copy-ptr-to-struct ptr (make-xwmhints))))) (if result (xfree ptr)) result)) (define-c-external (xseticonsizes* pointer unsigned pointer int) void "XSetIconSizes") (define (YSETICONSIZES dpy window iconsizelist) (let* ((dpy (chk-displayp dpy)) (arrayp (struct-list->string iconsizelist chk-xiconsizep))) (xseticonsizes* dpy window arrayp (length iconsizelist)) #f)) (define-c-external (xgeticonsizes* pointer unsigned pointer pointer) int "XGetIconSizes") (define-external (make-xiconsize) xiconsize) (define (YGETICONSIZES dpy window) (let* ((dpy (chk-displayp dpy)) (array_ret (make-string sizeof-ptr)) (count_ret (make-string c-sizeof-int)) (status (xgeticonsizes* dpy window array_ret count_ret)) (array (c-ptr-ref array_ret 0)) (count (c-unsigned-ref count_ret 0)) (result (if status (array-struct->list array count make-xiconsize) #f))) (if result (xfree array)) result)) (define-c-external (xsetclasshint* pointer unsigned pointer) void "XSetClassHint") (define (YSETCLASSHINT dpy window name-class) (let* ((dpy (chk-displayp dpy)) (hint (string-list->string-array name-class))) (xsetclasshint* dpy window hint) #f)) (define-c-external (xgetclasshint* pointer unsigned pointer) int "XGetClassHint") (define (YGETCLASSHINT dpy window) (let* ((dpy (chk-displayp dpy)) (hint (make-string (* 2 sizeof-ptr))) (status (xgetclasshint* dpy window hint))) (if (eq? status 0) #f (let ((result `(,(c-string->string (c-ptr-ref hint 0)) ,(c-string->string (c-ptr-ref hint sizeof-ptr))))) (xfree (c-ptr-ref hint 0)) (xfree (c-ptr-ref hint sizeof-ptr)) result)))) ;;; Chapter 10 (define-c-external (xlookupstring* pointer pointer int pointer pointer) int "XLookupString") (define XLOOKUPSTRING-BUFFER (make-string 50)) (define (YLOOKUPSTRING event . opt) (let* ((event (chk-xeventp event)) (keysym (if (and opt (car opt)) (make-string sizeof-long) 0)) (status (if (= (length opt) 2) (chk-xcomposestatusp (cadr opt)) 0)) (result (xlookupstring* event xlookupstring-buffer 50 keysym status))) (if opt (list (substring xlookupstring-buffer 0 result) (if (car opt) (c-longunsigned-ref keysym 0) #f)) (substring xlookupstring-buffer 0 result)))) (define (YRMGETRESOURCE db name_str class_str) (let ((returns (XrmGetResource db name_str class_str))) (if (zero? (car returns)) #f (if (equal? (cadr returns) "String") (c-string->string (chk-charap (xrmvalue-addr (caddr returns)))) (error "Unimplemented resource type in YrmGetResource" (cadr returns)))))) (define (YRMMERGEDATABASES new into) (let ((into-p (make-string sizeof-ptr))) (c-ptr-set! into-p 0 (chk-xrmdatabase into)) (XrmMergeDatabases new (type/value->pointer 'xrmdatabasep into-p)) (type/value->pointer 'xrmdatabase (c-ptr-ref into-p 0))))