├── .gitignore ├── CHANGES ├── INSTALL ├── README ├── cdecl ├── README ├── cdecl.sc ├── const.sc ├── document ├── extern.sc ├── load.sc ├── makefile ├── sch.sc ├── sizeof.c └── typedef.sc ├── doc ├── README ├── embedded.tex ├── index.tex ├── intro.tex ├── makefile ├── r4rs │ ├── NOTES │ ├── algol60.sty │ ├── basic.tex │ ├── bib.tex │ ├── commands.tex │ ├── derive.tex │ ├── example.tex │ ├── expr.tex │ ├── first.tex │ ├── index.sch │ ├── index.tex │ ├── intro.tex │ ├── lex.tex │ ├── macros.tex │ ├── notes.tex │ ├── procs.tex │ ├── prog.tex │ ├── r4rs.aux │ ├── r4rs.idx │ ├── r4rs.tex │ ├── r4rs.toc │ ├── sem.tex │ ├── struct.tex │ └── syn.tex ├── s2c.sty ├── s2cc.l ├── s2ci.l └── smithnotes.tex ├── makefile ├── ports ├── AMD64 │ ├── linux.s │ ├── makefile-head │ ├── options-server.h │ └── options.h ├── AOSF │ ├── X.cdecl │ ├── aosf.s │ ├── makefile-head │ ├── options-server.h │ └── options.h ├── ARM │ ├── arm.s │ ├── makefile-head │ └── options.h ├── DECMIPS │ ├── makefile-head │ ├── mips.s │ ├── options-server.h │ └── options.h ├── FREEBSD │ ├── makefile-head │ ├── options-server.h │ ├── options.h │ └── x86.s ├── HP300 │ ├── hp300.s │ ├── makefile-head │ ├── options-server.h │ └── options.h ├── HP700 │ ├── hp700.s │ ├── makefile-head │ ├── options-server.h │ └── options.h ├── LINUX │ ├── linux.s │ ├── makefile-head │ ├── options-server.h │ └── options.h ├── MACOS │ ├── makefile-head │ ├── options-server.h │ ├── options.h │ └── x86.s ├── MAC_CLASSIC │ ├── README │ ├── makefile-head │ ├── options.h │ ├── pack │ ├── unpack │ └── unpack.c ├── OPENBSD │ ├── makefile-head │ ├── openbsd.s │ ├── options-server.h │ └── options.h ├── RS6000 │ ├── makefile-head │ ├── options-server.h │ ├── options.h │ └── rs6000.s ├── SGIMIPS │ ├── makefile-head │ └── ranlib ├── SONYMIPS │ └── makefile-head ├── SUNOS4 │ ├── makefile-head │ ├── options-server.h │ ├── options.h │ ├── sparc-pragma.h │ └── sparc.s ├── SUNOS5 │ ├── makefile-head │ ├── options-server.h │ ├── options.h │ ├── sparc-pragma.h │ └── sparc.s ├── VAX │ ├── makefile-head │ ├── options-server.h │ ├── options.h │ └── vax.s └── makefile ├── scrt ├── README ├── apply.c ├── apply.h ├── c.sc ├── callcc.c ├── callcc.h ├── cio.c ├── cio.h ├── em2.c ├── embedded.c ├── heap.c ├── heap.h ├── makefile ├── mtraps.c ├── objects.c ├── objects.h ├── options.h ├── predef.sc ├── repdef.sc ├── scdebug.c ├── scdebug.sc ├── sceval.c ├── sceval.sc ├── scexpand.c ├── scexpand.sc ├── scexpnd1.c ├── scexpnd1.sc ├── scexpnd2.c ├── scexpnd2.sc ├── sci.c ├── sci.sc ├── scinit.c ├── scinit.h ├── scqquote.c ├── scqquote.sc ├── screp.c ├── screp.sc ├── scrt1.c ├── scrt1.sc ├── scrt2.c ├── scrt2.sc ├── scrt3.c ├── scrt3.sc ├── scrt4.c ├── scrt4.sc ├── scrt5.c ├── scrt5.sc ├── scrt6.c ├── scrt6.sc ├── scrt7.c ├── scrt7.sc ├── scrtuser.c └── scrtuser.sc ├── scsc ├── README ├── callcode.c ├── callcode.sc ├── closeana.c ├── closeana.sc ├── compile.c ├── compile.sc ├── expform.c ├── expform.sc ├── expform.sch ├── gencode.c ├── gencode.sc ├── gencode.sch ├── lambdacode.c ├── lambdacode.sc ├── lambdaexp.c ├── lambdaexp.sc ├── lambdaexp.sch ├── lap.c ├── lap.sc ├── lap.sch ├── macros.c ├── macros.sc ├── main.c ├── main.sc ├── makefile ├── misccode.c ├── misccode.sc ├── miscexp.c ├── miscexp.sc ├── miscexp.sch ├── plist.c ├── plist.sc ├── plist.sch ├── readtext.c ├── readtext.sc ├── transform.c └── transform.sc ├── test ├── README ├── alltests.sc ├── makefile ├── test.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-input.sc ├── test20-make.sc ├── test20.sc ├── test21.sc ├── test22.sc ├── test23.sc ├── test50.sc ├── test51.sc ├── test52.sc ├── test53.sc ├── test54.sc ├── test54c.c ├── test55.sc └── testchk.sc └── xlib ├── README ├── X.cdecl ├── Xatom.cdecl ├── Xcursorfont.cdecl ├── Xkeysym.cdecl ├── Xlib.cdecl ├── Xr4.cdecl ├── Xresource.cdecl ├── Xutil.cdecl ├── clear.sc ├── doc.txt ├── hello.sc ├── hello2.sc ├── makefile ├── makefile-example ├── npuzzle.sc ├── puzzle.sc ├── xlib.sc ├── xws10.cdecl ├── xws2.cdecl ├── xws3.cdecl ├── xws4.cdecl ├── xws5.cdecl ├── xws6.cdecl ├── xws7.cdecl ├── xws8.cdecl ├── xws9.cdecl ├── xwsr4.cdecl └── xwss.sc /.gitignore: -------------------------------------------------------------------------------- 1 | /AMD64/ 2 | /AOSF/ 3 | /ARM/ 4 | /DECMIPS/ 5 | /FREEBSD/ 6 | /HP300/ 7 | /HP700/ 8 | /LINUX/ 9 | /MAC_CLASSIC/ 10 | /MACOS/ 11 | /OPENBSD/ 12 | /SGIMIPS/ 13 | /SONYMIPS/ 14 | /SUNOS4/ 15 | /SUNOS5/ 16 | /VAX/ 17 | /doc/*.aux 18 | /doc/*.dvi 19 | /doc/*.idx 20 | /doc/*.log 21 | /doc/*.toc 22 | /doc/embedded.pdf 23 | /doc/index.pdf 24 | /doc/intro.pdf 25 | /doc/r4rs.pdf 26 | /doc/smithnotes.pdf 27 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # QUICK BUILD/INSTALLATION GUIDE 4 | 5 | # Quick instructions for building s2c on Debian amd64, including the 6 | # X11-enabled libraries etc. All lines including "-C doc" can be 7 | # omitted to skip the manuals. Switch AMD64 to LINUX (for i386) or ARM 8 | # (for arm). Change prefix to /usr or /home/username, and other 9 | # locations, as appropriate. 10 | 11 | # required development libraries: libsigsegv-dev, libx11-dev 12 | 13 | # required to build documentation: 14 | # texlive-latex-base, texlive-latex-extra, latex209-bin, 15 | # texlive-fonts-recommended, ghostscript 16 | 17 | # In the root of the unpacked sources run: 18 | 19 | set -e 20 | set -x 21 | 22 | A=AMD64 23 | P="prefix=/usr/local MANDIR=\$(prefix)/share/man DOCDIR=\$(prefix)/share/doc/scheme2c" 24 | D=~/tmp/s2c 25 | I="$P DESTDIR=$D" 26 | T=~/tmp/scheme2c-binary.tar.gz 27 | MAKE=make 28 | 29 | ${MAKE} $P for$A 30 | ${MAKE} $P -C $A 31 | ${MAKE} $P -C $A/cdecl all 32 | ${MAKE} $P -C $A/xlib sizeof.cdecl libs2cxl.a s2cixl 33 | ${MAKE} $P -C doc 34 | 35 | ${MAKE} $I -C $A/scrt install 36 | ${MAKE} $I -C $A/scsc install 37 | ${MAKE} $I -C $A/cdecl install 38 | ${MAKE} $I -C $A/xlib install 39 | ${MAKE} $I -C doc install 40 | 41 | tar -zcf $T -C $D . 42 | 43 | # The result is a tarball which can be installed with, e.g., 44 | 45 | # sudo tar -C / -zxf $T 46 | -------------------------------------------------------------------------------- /cdecl/README: -------------------------------------------------------------------------------- 1 | C stub declaration compiler for Scheme->C 2 | -------------------------------------------------------------------------------- /cdecl/const.sc: -------------------------------------------------------------------------------- 1 | ;;; C declaration compiler. 2 | 3 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | ;* All Rights Reserved 5 | 6 | ;* Permission is hereby granted, free of charge, to any person obtaining a 7 | ;* copy of this software and associated documentation files (the "Software"), 8 | ;* to deal in the Software without restriction, including without limitation 9 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | ;* and/or sell copies of the Software, and to permit persons to whom the 11 | ;* Software is furnished to do so, subject to the following conditions: 12 | ;* 13 | ;* The above copyright notice and this permission notice shall be included in 14 | ;* all copies or substantial portions of the Software. 15 | ;* 16 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | ;* DEALINGS IN THE SOFTWARE. 23 | 24 | ;;; This module compiles constant expressions. 25 | ;;; 26 | ;;; (const ) 27 | ;;; 28 | ;;; which defines a constant. The expression is evaluated at compile time 29 | ;;; and is defined as the following: 30 | ;;; 31 | ;;; ::= 32 | ;;; Scheme-constant 33 | ;;; ( Scheme-procedure [ ... ] ) 34 | ;;; 35 | ;;; When stubs are being generated, this will result in: 36 | ;;; 37 | ;;; (define ) 38 | ;;; 39 | ;;; and when an include file is being generated, it will generate: 40 | ;;; 41 | ;;; (define-constant ) 42 | 43 | (module const) 44 | 45 | ;;; During the input phase, the following function is called to process 46 | ;;; constant expressions. It will return either the constant or call error 47 | ;;; on an error. 48 | 49 | (define (INPUT-CONST exp) 50 | (if (and (= (length exp) 3) (symbol? (cadr exp))) 51 | (let ((id (cadr exp))) 52 | (putprop id 'const (cddr exp)) 53 | id) 54 | (error 'input-const "Illegal syntax: ~s" exp))) 55 | 56 | ;;; A constant value is computed by the following expression. Any errors will 57 | ;;; be reported by calling error. 58 | 59 | (define (CONST-VALUE const) 60 | (cond ((symbol? const) 61 | (let ((value (getprop const 'const))) 62 | (if value 63 | (const-value (car value)) 64 | (error 'const-value "Undefined constant: ~s" 65 | const)))) 66 | ((pair? const) 67 | (let ((proc (top-level-value (car const)))) 68 | (if (procedure? proc) 69 | (apply proc (map const-value (cdr const))) 70 | (error 'const-value "Undefined function: ~s" 71 | (car const))))) 72 | (else const))) 73 | 74 | ;;; Stub declarations are generated by the following function. 75 | 76 | (define (EMIT-CONSTS constants define-only const-file-root) 77 | (with-output-to-file 78 | (string-append const-file-root ".sc") 79 | (lambda () 80 | (format #t "(module ~a)~%~%" const-file-root) 81 | (for-each 82 | (lambda (const) 83 | (unless (memq const define-only) 84 | (format #t "(define ~s ~s)~%" 85 | const (const-value const)))) 86 | constants))) 87 | (with-output-to-file 88 | (string-append const-file-root ".sch") 89 | (lambda () 90 | (for-each 91 | (lambda (const) 92 | (unless (memq const define-only) 93 | (format #t "(define-constant ~s ~s)~%" 94 | const (const-value const)))) 95 | constants)))) 96 | -------------------------------------------------------------------------------- /cdecl/load.sc: -------------------------------------------------------------------------------- 1 | (load "cdecl.sc") 2 | (load "const.sc") 3 | (load "extern.sc") 4 | (load "typedef.sc") 5 | -------------------------------------------------------------------------------- /cdecl/makefile: -------------------------------------------------------------------------------- 1 | prefix=/usr/local 2 | LIBDIR=${prefix}/lib 3 | BINDIR=${prefix}/bin 4 | LIBSUBDIR=scheme2c 5 | DOCDIR=$(prefix)/doc/scheme2c 6 | MANDIR=$(prefix)/man 7 | 8 | INSTALL = install 9 | INSTALL_DATA = ${INSTALL} -m 644 10 | INSTALL_PROGRAM = ${INSTALL} 11 | INSTALL_SCRIPT = ${INSTALL} 12 | 13 | .SUFFIXES: 14 | .SUFFIXES: .sc .c 15 | 16 | SCSRC = cdecl.sc const.sc extern.sc typedef.sc 17 | CSRC = cdecl.c const.c extern.c typedef.c 18 | MISC = sizeof.c sch.sc README document load.sc 19 | 20 | SRCDIR = ../../cdecl 21 | 22 | SCC = ../scsc/Xs2cc 23 | 24 | .sc.c: 25 | ${SCC} ${CFLAGS} ${LDFLAGS} -C $*.sc 26 | 27 | all: 28 | $(MAKE) "SCC=${SCC}" "SRCDIR=${SRCDIR}" s2cdecl s2csizeof s2ch 29 | 30 | s2cdecl: ${CSRC} 31 | ${SCC} ${CFLAGS} ${LDFLAGS} -o $@ $^ 32 | 33 | s2csizeof: sizeof.c 34 | ${CC} ${CFLAGS} ${LDFLAGS} -o $@ $^ 35 | 36 | s2ch: sch.sc 37 | ${SCC} ${CFLAGS} ${LDFLAGS} -o $@ $^ 38 | 39 | install: s2ch s2cdecl 40 | ${INSTALL} -d ${DESTDIR}${BINDIR} 41 | ${INSTALL_PROGRAM} s2ch s2cdecl ${DESTDIR}${BINDIR}/ 42 | ln -sf s2ch ${DESTDIR}${BINDIR}/sch 43 | 44 | clean: 45 | rm -f *.o *.CKP *.BAK *.S2C core 46 | 47 | clean-sc-to-c: 48 | rm -f ${CSRC} 49 | 50 | noprogs: 51 | rm -f s2cdecl s2csizeof s2ch 52 | 53 | srclinks: 54 | for x in ${SCSRC} ${MISC}; \ 55 | do ln -s ${SRCDIR}/$$x $$x; \ 56 | done 57 | 58 | .PHONY: all noprogs clean-sc-to-c scrlinks 59 | -------------------------------------------------------------------------------- /cdecl/sizeof.c: -------------------------------------------------------------------------------- 1 | /* Generate the structure offset and type information required by the 2 | cdecl compiler. 3 | */ 4 | 5 | #include 6 | 7 | typedef (*pp)(); 8 | 9 | struct {char dummy; char x; char dummy2;} c1; 10 | struct {char dummy; short x; char dummy2;} s1; 11 | struct {char dummy; unsigned short x; char dummy2;} us1; 12 | struct {char dummy; int x; char dummy2;} i1; 13 | struct {char dummy; unsigned x; char dummy2;} u1; 14 | struct {char dummy; long x; char dummy2;} l1; 15 | struct {char dummy; unsigned long x; char dummy2;} ul1; 16 | struct {char dummy; float x; char dummy2;} f1; 17 | struct {char dummy; double x; char dummy2;} d1; 18 | struct {char dummy; char* x; char dummy2;} cp1; 19 | struct {char dummy; pp x; char dummy2;} pp1; 20 | 21 | int main() 22 | { 23 | char *toref, *toset; 24 | 25 | printf( "(sizeof char %i %li c-byte-ref c-byte-set!)\n", 26 | sizeof( char ), ((long)&c1.x)-((long)&c1) ); 27 | printf( "(sizeof shortint %i %li c-shortint-ref c-shortint-set!)\n", 28 | sizeof( short ), ((long)&s1.x)-((long)&s1) ); 29 | printf( "(sizeof shortunsigned %i %li c-shortunsigned-ref c-shortunsigned-set!)\n", 30 | sizeof( unsigned short ), ((long)&us1.x)-((long)&us1) ); 31 | printf( "(sizeof int %i %li c-int-ref c-int-set!)\n", 32 | sizeof( int ), ((long)&i1.x)-((long)&i1) ); 33 | printf( "(sizeof unsigned %i %li c-unsigned-ref c-unsigned-set!)\n", 34 | sizeof( unsigned ), ((long)&u1.x)-((long)&u1) ); 35 | printf( "(sizeof longint %i %li c-longint-ref c-longint-set!)\n", 36 | sizeof( long ), ((long)&l1.x)-((long)&l1) ); 37 | printf( "(sizeof longunsigned %i %li c-longunsigned-ref c-longunsigned-set!)\n", 38 | sizeof( long ), ((long)&ul1.x)-((long)&ul1) ); 39 | printf( "(sizeof float %i %li c-float-ref c-float-set!)\n", 40 | sizeof( float ), ((long)&f1.x)-((long)&f1) ); 41 | printf( "(sizeof double %i %li c-double-ref c-double-set!)\n", 42 | sizeof( double ), ((long)&d1.x)-((long)&d1) ); 43 | if (sizeof( char* ) == sizeof( unsigned short )) { 44 | toref = "c-shortunsigned-ref"; 45 | toset = "c-shortunsigned-set!"; 46 | } else if (sizeof( char* ) == sizeof( unsigned )) { 47 | toref = "c-unsigned-ref"; 48 | toset = "c-unsigned-set!"; 49 | } else { 50 | toref = "c-longunsigned-ref"; 51 | toset = "c-longunsigned-set!"; 52 | } 53 | printf( "(sizeof pointer %i %li %s %s)\n", 54 | sizeof( char* ), ((long)&cp1.x)-((long)&cp1), toref, toset ); 55 | if (sizeof( pp ) == sizeof( unsigned short )) { 56 | toref = "c-shortunsigned-ref"; 57 | toset = "c-shortunsigned-set!"; 58 | } else if (sizeof( pp ) == sizeof( unsigned )) { 59 | toref = "c-unsigned-ref"; 60 | toset = "c-unsigned-set!"; 61 | } else { 62 | toref = "c-longunsigned-ref"; 63 | toset = "c-longunsigned-set!"; 64 | } 65 | printf( "(sizeof procedure %i %li %s %s)\n", 66 | sizeof( pp ), ((long)&pp1.x)-((long)&pp1), toref, toset ); 67 | return 0; 68 | } 69 | -------------------------------------------------------------------------------- /doc/README: -------------------------------------------------------------------------------- 1 | This directory contains documentation for Scheme->C. 2 | 3 | embedded.tex LaTeX document describing embedding Scheme->C inside an 4 | application. 5 | 6 | index.tex a LaTeX reference document for the language 7 | which is in the form of an annotated index to 8 | the Revised**4 Scheme standard. 9 | 10 | intro.tex a LaTeX document introducing Scheme->C. 11 | 12 | r4rs/ the R4RS scheme standard in LaTeX. 13 | 14 | scc.l UNIX man page for the Scheme->C compiler. 15 | 16 | sci.l UNIX man page for the Scheme->C interpreter. 17 | 18 | smithnotes.tex notes to accompany "An Introduction to Scheme" 19 | by Jerry D. Smith. 20 | -------------------------------------------------------------------------------- /doc/makefile: -------------------------------------------------------------------------------- 1 | # Makes the documentation files. 2 | 3 | pdfs = embedded.pdf index.pdf intro.pdf smithnotes.pdf 4 | # building r4rs.pdf requires latex209 which is not typically available, 5 | # so by default do not build/install it. 6 | #pdfs += r4rs.pdf 7 | all: $(pdfs) 8 | 9 | prefix=/usr/local 10 | DOCDIR=$(prefix)/doc/scheme2c 11 | MANDIR=$(prefix)/man 12 | 13 | INSTALL = install 14 | INSTALL_DATA = ${INSTALL} -m 644 15 | INSTALL_PROGRAM = ${INSTALL} 16 | INSTALL_SCRIPT = ${INSTALL} 17 | 18 | .SUFFIXES: 19 | 20 | .SUFFIXES: .tex .dvi .ps .pdf 21 | TEX=latex 22 | %.ps: %.dvi; dvips -K -Ppdf -G0 -R0 -q -tletter -o $@ $< 23 | %.pdf: %.ps; ps2pdf $< $@ 24 | 25 | export TEXINPUTS 26 | r4rs.dvi: TEXINPUTS=r4rs: 27 | r4rs.dvi: TEX=latex209 28 | r4rs.dvi: r4rs/r4rs.tex 29 | $(TEX) -output-directory=. $< 30 | 31 | install: install-pdf install-man 32 | 33 | install-pdf: $(pdfs) 34 | $(INSTALL) -d $(DESTDIR)$(DOCDIR) 35 | $(INSTALL_DATA) $(pdfs) $(DESTDIR)$(DOCDIR)/ 36 | 37 | install-man: 38 | $(INSTALL) -d $(DESTDIR)$(MANDIR)/man1 39 | $(INSTALL_DATA) s2cc.l $(DESTDIR)$(MANDIR)/man1/s2cc.1 40 | $(INSTALL_DATA) s2ci.l $(DESTDIR)$(MANDIR)/man1/s2ci.1 41 | ln -sf s2ci.1 $(DESTDIR)$(MANDIR)/man1/sci.1 42 | ln -sf s2cc.1 $(DESTDIR)$(MANDIR)/man1/scc.1 43 | 44 | clean: 45 | -rm -rf *.pdf *.dvi *.aux *.log *.BAK *.CKP *.toc *.idx 46 | -------------------------------------------------------------------------------- /doc/r4rs/NOTES: -------------------------------------------------------------------------------- 1 | Contents obtained via: 2 | 3 | wget --mirror --no-parent http://www2.lifl.fr/~routier/debScheme/docs/r4rs/r4rs.tex/. 4 | rm *.html* *.LOG 5 | dos2unix -o -p * 6 | -------------------------------------------------------------------------------- /doc/r4rs/first.tex: -------------------------------------------------------------------------------- 1 | % First page 2 | 3 | \thispagestyle{empty} 4 | 5 | % \todo{"another" report?} 6 | 7 | \topnewpage[{ 8 | \begin{center} {\huge\bf 9 | Revised$^{\bf 4}$ Report on the Algorithmic Language \\ 10 | \vskip 3pt 11 | Scheme} 12 | \vskip 1ex 13 | $$ 14 | \begin{tabular}{l@{\extracolsep{.5in}}lll} 15 | \multicolumn{4}{c}{W{\sc ILLIAM} C{\sc LINGER AND} J{\sc ONATHAN} R{\sc EES} 16 | ({\it Editors\/})} \\ 17 | H. A{\sc BELSON} & 18 | R. K. D{\sc YBVIG} & 19 | C. T. H{\sc AYNES} & 20 | G. J. R{\sc OZAS} \\ 21 | N. I. A{\sc DAMS IV} & 22 | D. P. F{\sc RIEDMAN} & 23 | E. K{\sc OHLBECKER} & 24 | G. L. S{\sc TEELE} J{\sc R}. \\ 25 | D. H. B{\sc ARTLEY} & 26 | R. H{\sc ALSTEAD} & 27 | D. O{\sc XLEY} & 28 | G. J. S{\sc USSMAN} \\ 29 | G. B{\sc ROOKS} & 30 | C. H{\sc ANSON} & 31 | K. M. P{\sc ITMAN} & 32 | M. W{\sc AND} \\ 33 | \end{tabular} 34 | $$ 35 | \vskip 2ex 36 | {\it Dedicated to the Memory of ALGOL 60} 37 | \vskip 2.6ex 38 | \end{center} 39 | }] 40 | 41 | \chapter*{Summary} 42 | 43 | The report gives a defining description of the programming language 44 | Scheme. Scheme is a statically scoped and properly tail-recursive 45 | dialect of the Lisp programming language invented by Guy Lewis 46 | Steele~Jr.\ and Gerald Jay~Sussman. It was designed to have an 47 | exceptionally clear and simple semantics and few different ways to 48 | form expressions. A wide variety of programming paradigms, including 49 | imperative, functional, and message passing styles, find convenient 50 | expression in Scheme. 51 | 52 | \vest The introduction offers a brief history of the language and of 53 | the report. 54 | 55 | \vest The first three chapters present the fundamental ideas of the 56 | language and describe the notational conventions used for describing the 57 | language and for writing programs in the language. 58 | 59 | \vest Chapters~\ref{expressionchapter} and~\ref{programchapter} describe 60 | the syntax and semantics of expressions, programs, and definitions. 61 | 62 | \vest Chapter~\ref{builtinchapter} describes Scheme's built-in 63 | procedures, which include all of the language's data manipulation and 64 | input/output primitives. 65 | 66 | \vest Chapter~\ref{formalchapter} provides a formal syntax for Scheme 67 | written in extended BNF, along with a formal denotational semantics. 68 | An example of the use of the language follows the formal syntax and 69 | semantics. 70 | 71 | \vest The appendix describes a macro facility that may be used to 72 | extend the syntax of Scheme. 73 | 74 | \vest The report concludes with a bibliography and an 75 | alphabetic index. 76 | 77 | \todo{expand the summary so that it fills up the column.} 78 | 79 | %\vfill 80 | %\begin{center} 81 | %{\large \bf 82 | %*** DRAFT*** \\ 83 | %August 31, 1989%\today 84 | %}\end{center} 85 | 86 | \vfill 87 | \eject 88 | 89 | {\footnotesize 90 | \tableofcontents 91 | } 92 | 93 | \vfill 94 | \eject 95 | -------------------------------------------------------------------------------- /doc/r4rs/index.sch: -------------------------------------------------------------------------------- 1 | ; Program to process r4rs.idx entries. 2 | 3 | (define main 0) 4 | (define aux 1) 5 | 6 | (define (make-entry key font main/aux page) 7 | (list key font main/aux page)) 8 | (define (entry-key x) (car x)) 9 | (define (entry-font x) (cadr x)) 10 | (define (entry-main/aux x) (caddr x)) 11 | (define (entry-page x) (cadddr x)) 12 | 13 | (define *database* '()) 14 | 15 | (define (index-entry key font main/aux page) 16 | (set! *database* 17 | (cons (make-entry (string-downcase key) 18 | font 19 | main/aux 20 | page) 21 | *database*)) 22 | #t) 23 | 24 | (define (create-index p) 25 | (define (loop) 26 | (if (null? *database*) 27 | 'done 28 | (begin (process-key (collect-entries) p) 29 | (loop)))) 30 | (set! *database* 31 | (sort *database* 32 | (lambda (x y) 33 | (stringstring '(#\\)))) 90 | (define *s2* "{") 91 | (define *s3* "}}{\\hskip .75em}") 92 | (define *semi* "\; ") 93 | (define *comma* ", ") 94 | 95 | (define (write-entries key font main pages p) 96 | (if (and (char-alphabetic? (string-ref key 0)) 97 | (not (char=? (string-ref *last-key* 0) 98 | (string-ref key 0)))) 99 | (begin (display "\\indexspace" p) 100 | (newline p))) 101 | (set! *last-key* key) 102 | (display (string-append *s1* font *s2* key *s3*) p) 103 | (if main 104 | (begin (write main p) 105 | (if (not (null? pages)) 106 | (display *semi* p)))) 107 | (if (not (null? pages)) 108 | (begin (write (car pages) p) 109 | (for-each (lambda (page) 110 | (display *comma* p) 111 | (write page p)) 112 | (cdr pages)))) 113 | (newline p)) 114 | -------------------------------------------------------------------------------- /doc/r4rs/r4rs.tex: -------------------------------------------------------------------------------- 1 | \documentstyle[twoside]{algol60} 2 | 3 | \pagestyle{headings} 4 | \showboxdepth=0 5 | \makeindex 6 | \input{commands} 7 | \def\theevenhead{Revised$^{4}$ Scheme} 8 | 9 | \begin{document} 10 | 11 | \hfil {\bf 2 November 1991}%\today{} ***} 12 | 13 | \input{first} \par 14 | \input{intro} \par 15 | \vskip 2ex 16 | \clearchapterstar{Description of the language} %\unskip\vskip -2ex 17 | % \chapter*{Description of the language}\unskip\vskip -2ex 18 | \input{struct} \par 19 | \input{lex} \par 20 | \input{basic} \par 21 | \input{expr} \par 22 | \input{prog} \par 23 | \input{procs} \par \vfill\eject 24 | \input{syn} \par 25 | \input{sem} \par 26 | \input{derive} \par \vfill%%R4%%\eject 27 | \input{notes} \par \vfill\eject 28 | \input{example} \par \vfill\eject 29 | \input{macros} \par \vfill\eject 30 | \input{bib} \par 31 | 32 | \newpage 33 | \begin{theindex} 34 | 35 | The principal entry for each term, procedure, or keyword is listed 36 | first, separated from the other entries by a semicolon. 37 | 38 | \bigskip 39 | 40 | \input{index} 41 | \end{theindex} 42 | 43 | \end{document} 44 | -------------------------------------------------------------------------------- /doc/s2c.sty: -------------------------------------------------------------------------------- 1 | %%\newcommand{\StoC}[0]{\texttt{Scheme->C}} 2 | \newcommand{\StoC}[0]{\mbox{Scheme\texttt{->}C}} 3 | \newcommand{\RRRRS}[0]{R$^3$RS} 4 | \newcommand{\RRRRRS}[0]{R$^4$RS} 5 | -------------------------------------------------------------------------------- /doc/s2ci.l: -------------------------------------------------------------------------------- 1 | .TH S2CI 1 local 2 | .SH NAME 3 | s2ci \- Scheme interpreter 4 | .SH SYNTAX 5 | .B s2ci 6 | [ option ] 7 | .SH DESCRIPTION 8 | The 9 | .B s2ci 10 | command (previously known as \fBsci\fR) invokes 11 | a Scheme interpreter. The language accepted by this interpreter 12 | is that defined in the essential portions of the 13 | .I 14 | Revised\v'-0.3m'4\v'0.3m' Report on the Algorithmic Language Scheme, 15 | with minor constraints and some additions. The 16 | Scheme interpreter is written in Scheme which has then been compiled using 17 | the Scheme-to-C compiler, \fBs2cc\fR. 18 | .SH OPTIONS 19 | These options are accepted by 20 | .B s2ci. 21 | .TP 15 22 | .B -e 23 | Echo text read from the standard input file on the standard output file. 24 | .TP 15 25 | .B -emacs 26 | Scheme interpreter is controlled by GNU emacs. 27 | .TP 15 28 | .B -nh 29 | Do not print the interpreter version header on the standard output file. 30 | .TP 15 31 | .B -np 32 | Do not prompt for input from the standard input file on the standard output 33 | file. 34 | .TP 15 35 | .B -q 36 | Do not print the result of each expression evaluation. 37 | .TP 15 38 | \fB-scgc \fIstatflag\fR 39 | Enables garbage collection statistics. If set to 1, then garbage collection 40 | statistics will be printed. The default is 0, that will result in no 41 | statistics. 42 | .TP 15 43 | \fB-sch \fIheap\fR 44 | Specifies the initial size of the heap in megabytes. The default heap size is 45 | 4 MB. The maximum heap size allowed is 1000 MB. 46 | .TP 15 47 | \fB-scl \fIpercent\fR 48 | Specifies the percent of the heap allocated after a generational garbage 49 | collection that will force a full collection. The default is 40%. 50 | .TP 15 51 | \fB-scm \fImain\fR 52 | Specifies the function that should be used instead of the predefined "main". 53 | The function name must be entered in the correct case, i.e. letters typically 54 | upshifted. 55 | .TP 15 56 | \fB-scmh \fIheap\fR 57 | Specifies the maximum heap size in megabytes. The default is five times the 58 | initial size of the heap. 59 | .SH ENVIRONMENT VARIABLES 60 | The items controlled by \fI-sc..\fR flags can also be controlled by environment 61 | variables. If both the flag and the environment variable are provided, then 62 | the flag's value will be used. 63 | .TP 15 64 | .B SCGCINFO 65 | Controls the reporting of garbage collection statistics to the standard error 66 | file. If set to 1, then garbage collection statistics will be printed. The 67 | default setting is 0 that will not print the statistics. 68 | .TP 15 69 | .B SCHEAP 70 | Specifies the initial size of the heap in megabytes. The default heap size 71 | is 4 MB. The maximum heap size allowed is 1000 MB. 72 | .TP 15 73 | .B SCLIMIT 74 | Specifies the percent of the heap allocated after a generational garbage 75 | collection that will force a full collection. The default is 40%. 76 | .TP 15 77 | .B SCMAXHEAP 78 | Specifies the maximum size of the heap in megabytes. The default value is 79 | five times the initial heap size. 80 | .SH FILES 81 | The interpreter is one a.out file with the name \fIs2ci\fR. All files 82 | associated with the interpreter are found in the 83 | directory \fI.../schemetoc/scrt\fB. 84 | .SH SEE ALSO 85 | .PP 86 | Harold Abelson and Gerald Jay Sussman with Julie Sussman, 87 | .I 88 | Structure and Interpretation of Computer Programs, 89 | The MIT Press. 90 | .PP 91 | William Clinger and Jonathan Rees (Editors), 92 | .I 93 | Revised\v'-0.3m'4\v'0.3m' Report on the Algorithmic Language Scheme, 94 | LISP Pointers, Volume IV, Number 3, July-September 1991. PostScript for 95 | this report is included in the software distribution. 96 | .PP 97 | Jerry D. Smith, 98 | .I 99 | An Introduction to Scheme, 100 | Prentice Hall, Inc. Chapter notes for using this text with Scheme->C are 101 | included in the software distribution. 102 | .PP 103 | R. Kent Dybvig, 104 | .I 105 | The SCHEME Programming Language, 106 | Prentice Hall, Inc. 107 | .PP 108 | Daniel P. Friedman and Matthias Felleisen, 109 | .I 110 | The Little LISPer, 111 | MIT Press. 112 | .PP 113 | Joel F. Bartlett, 114 | .I 115 | Scheme->C a Portable Scheme-to-C Compiler, 116 | WRL Research Report 89/1. 117 | .PP 118 | Additional documentation is included in the software distribution. 119 | .PP 120 | s2cc(1) 121 | .SH QUESTIONS, COMMENTS, AND COMPLAINTS 122 | http://alioth.debian.org/projects/scheme2c/ 123 | -------------------------------------------------------------------------------- /ports/AMD64/linux.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * LINUX assembly code. 5 | * 6 | */ 7 | 8 | /*#ifdef __i486__ 9 | .align 4 10 | #else 11 | .align 2 12 | #endif*/ 13 | .globl sc_geti386regs 14 | 15 | sc_geti386regs: 16 | pushq %rbp 17 | movq %rsp,%rbp 18 | movq %rax,(%rdi) 19 | movq %rbx,8(%rdi) 20 | movq %rcx,16(%rdi) 21 | movq %rdx,24(%rdi) 22 | movq %rsi,32(%rdi) 23 | movq %r8,40(%rdi) 24 | movq %r9,48(%rdi) 25 | movq %r10,56(%rdi) 26 | movq %r11,64(%rdi) 27 | movq %r12,72(%rdi) 28 | movq %r13,80(%rdi) 29 | movq %r14,88(%rdi) 30 | movq %r15,96(%rdi) 31 | movq %rdi,%rax 32 | movq %rbp,%rsp 33 | popq %rbp 34 | ret 35 | 36 | -------------------------------------------------------------------------------- /ports/AMD64/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for LINUX. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -march=native -Wall -O2 -finline-functions -fno-math-errno -frename-registers -fno-strict-aliasing 8 | LDFLAGS = -lsigsegv 9 | CC = gcc 10 | 11 | # Assembly language object files. 12 | 13 | Aruntime = linux.o 14 | 15 | # Profiled library 16 | 17 | Plib = 18 | 19 | # Installation tools 20 | 21 | RANLIB = ranlib 22 | 23 | # X library 24 | 25 | XLIB = -lX11 26 | XLIBCFLAGS = 27 | 28 | # End of LINUX header. 29 | -------------------------------------------------------------------------------- /ports/AOSF/aosf.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * Alpha AXP for OSF/1 assembly code. 5 | * 6 | */ 7 | 8 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | * All Rights Reserved 10 | 11 | * Permission is hereby granted, free of charge, to any person obtaining a 12 | * copy of this software and associated documentation files (the "Software"), 13 | * to deal in the Software without restriction, including without limitation 14 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | * and/or sell copies of the Software, and to permit persons to whom the 16 | * Software is furnished to do so, subject to the following conditions: 17 | * 18 | * The above copyright notice and this permission notice shall be included in 19 | * all copies or substantial portions of the Software. 20 | * 21 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | * DEALINGS IN THE SOFTWARE. 28 | */ 29 | 30 | #include 31 | 32 | /* sc_s0tos6 returns the values of s0-s6 in the caller supplied buffer. These 33 | are the "callee" save registers which need to be examined during garbage 34 | collection. 35 | */ 36 | 37 | .text 38 | .align 4 39 | 40 | .globl sc_s0tos6 41 | .ent sc_s0tos6 2 42 | sc_s0tos6: 43 | ldgp gp, 0($27) 44 | .frame sp, 0, $26 45 | .prologue 0 46 | stq s0, 0(a0) 47 | stq s1, 8(a0) 48 | stq s2, 16(a0) 49 | stq s3, 24(a0) 50 | stq s4, 32(a0) 51 | stq s5, 40(a0) 52 | stq s6, 48(a0) 53 | ret $31, ($26), 1 54 | .end sc_s0tos6 55 | 56 | /* sc_setsp sets the stack pointer to the argument value */ 57 | 58 | .globl sc_setsp 59 | .ent sc_setsp 2 60 | sc_setsp: 61 | ldgp gp, 0($27) 62 | .frame sp, 0, $26 63 | .prologue 0 64 | bis a0, a0, sp 65 | ret $31, ($26), 1 66 | .end sc_setsp 67 | 68 | /* sc_getsp returns the current top-of-stack value */ 69 | 70 | .globl sc_getsp 71 | .ent sc_getsp 2 72 | sc_getsp: 73 | ldgp gp, 0($27) 74 | .frame sp, 0, $26 75 | .prologue 0 76 | bis sp, sp, $0 77 | ret $31, ($26), 1 78 | .end sc_getsp 79 | 80 | /* 81 | sc_setjmp, sc_longjmp 82 | 83 | This code provides a version of C's setjmp/longjmp that can be used to 84 | implement Scheme's call-with-current-continuation. 85 | 86 | sc_longjmp(a,v) 87 | 88 | will generate a "return(v)" from 89 | the last call to: 90 | 91 | sc_setjmp(a) 92 | 93 | by restoring registers from the saved state, and then doing a return. 94 | */ 95 | 96 | .globl sc_setjmp 97 | .ent sc_setjmp 2 98 | sc_setjmp: 99 | ldgp gp, 0($27) 100 | .frame sp, 0, $26 101 | .prologue 0 102 | stq s0, 0(a0) 103 | stq s1, 8(a0) 104 | stq s2, 16(a0) 105 | stq s3, 24(a0) 106 | stq s4, 32(a0) 107 | stq s5, 40(a0) 108 | stq s6, 48(a0) 109 | stq ra, 56(a0) 110 | stq sp, 64(a0) 111 | bis $31, $31, $0 112 | ret $31, ($26), 1 113 | .end sc_setjmp 114 | 115 | .globl sc_longjmp 116 | .ent sc_longjmp 2 117 | sc_longjmp: 118 | ldgp gp, 0($27) 119 | .frame sp, 0, $26 120 | .prologue 0 121 | ldq s0, 0(a0) 122 | ldq s1, 8(a0) 123 | ldq s2, 16(a0) 124 | ldq s3, 24(a0) 125 | ldq s4, 32(a0) 126 | ldq s5, 40(a0) 127 | ldq s6, 48(a0) 128 | ldq ra, 56(a0) 129 | ldq sp, 64(a0) 130 | bis $17, $17, $0 131 | ret $31, ($26), 1 132 | .end sc_longjmp 133 | -------------------------------------------------------------------------------- /ports/AOSF/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for AOSF. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -O 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = aosf.o 13 | 14 | # Profiled library 15 | 16 | Plib = 17 | 18 | # May be machine dependent 19 | 20 | RANLIB = ranlib 21 | 22 | # X library 23 | 24 | XLIB = -non_shared -lX11 -ldnet_stub 25 | XLIBCFLAGS = 26 | 27 | # End of AOSF header. 28 | -------------------------------------------------------------------------------- /ports/AOSF/options-server.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | 26 | /* This file defines compilation options for a specific implementation */ 27 | 28 | #define CHECKSTACK 1 /* 0 = don't check stack height */ 29 | /* 1 = check stack height */ 30 | 31 | #define TIMESLICE 1 /* 0 = don't time slice execution */ 32 | /* 1 = time slice execution */ 33 | 34 | #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 35 | 1 = emit procedure call for procedure 36 | entry checks. 37 | */ 38 | 39 | #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 40 | 1 = emit procedure call for procedure exit 41 | cleanup. 42 | */ 43 | 44 | #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ 45 | /* 1 = Scheme->C does handle signals */ 46 | 47 | #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ 48 | /* 1 = recover on fixed point overflow */ 49 | 50 | /* Define only one of the supported processor types: 51 | 52 | AOSF Alpha AXP OSF/1 53 | HP700 HP 9000/700 54 | MAC_CLASSIC Macintosh system 7.1 with Think-C 5.0 55 | MC680X0 HP 9000/300, Sun 3, Next 56 | MIPS DECstation, SGI, Sony News 57 | VAX Vax ULTRIX 58 | WIN16 Microsoft Windows 3.1 59 | */ 60 | 61 | #define AOSF 1 62 | 63 | /* Attributes of the selected architecture: 64 | 65 | The following four macros define specific aspects of the system. They 66 | are defined as strings, or specifically undefined: 67 | 68 | IMPLEMENTATION_MACHINE machine type 69 | IMPLEMENTATION_CPU cpu type 70 | IMPLEMENTATION_OS operating system 71 | IMPLEMENTATION_FS file system 72 | 73 | Big endian vs. little endian: 74 | 75 | BIGENDIAN defined to 1 to denote bigendian systems 76 | 77 | Alignment: 78 | 79 | DOUBLE_ALIGN defined to 1 to force doubles to be aligned on 80 | an even S2CINT boundary 81 | 82 | Macro expansion: 83 | 84 | NEED_MACRO_ARGS defined to 1 to declare a macro like X() as 85 | X(dummy) 86 | 87 | The types S2CINT and S2CUINT are defined to be signed and unsigned integers 88 | that are the same size as pointers. This is the basic "word" used by 89 | Scheme->C. 90 | 91 | The machine state when a continuation is created is captured in the 92 | sc_jmp_buf data structure. 93 | 94 | STACKPTR( x ) is a define that stores the address of the stack pointer 95 | in x. 96 | 97 | Unix flavors: 98 | 99 | POSIX POSIX.1 compliant 100 | SYSV System V or derivative 101 | SYSV4 System V release 4 (also define SYSV, POSIX) 102 | */ 103 | 104 | /**************/ 105 | /* AOSF */ 106 | /**************/ 107 | 108 | #ifdef AOSF 109 | #define IMPLEMENTATION_MACHINE "Alpha AXP" 110 | #undef IMPLEMENTATION_CPU 111 | #define IMPLEMENTATION_OS "OSF/1" 112 | #undef IMPLEMENTATION_FS 113 | 114 | typedef long int S2CINT; /* Signed pointer size integer */ 115 | typedef long unsigned S2CUINT; /* Unsigned pointer size integer */ 116 | 117 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 118 | #define MAXS2CINT 0x7fffffffffffffffL /* Maximum value of an S2CINT */ 119 | #define MSBS2CUINT 0x8000000000000000L /* S2CUINT with 1 in the MSB */ 120 | 121 | typedef long int sc_jmp_buf[ 9 ]; /* The buffer contains the following items: 122 | s0-s6 saved registers 123 | ra return address 124 | sp stack pointer 125 | */ 126 | 127 | #define STACKPTR( x ) x = sc_getsp() 128 | extern S2CINT* sc_getsp(); 129 | 130 | #define NEED_MACRO_ARGS 1 131 | #endif 132 | 133 | -------------------------------------------------------------------------------- /ports/AOSF/options.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | 26 | /* This file defines compilation options for a specific implementation */ 27 | 28 | #define CHECKSTACK 0 /* 0 = don't check stack height */ 29 | /* 1 = check stack height */ 30 | 31 | #define TIMESLICE 0 /* 0 = don't time slice execution */ 32 | /* 1 = time slice execution */ 33 | 34 | #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 35 | 1 = emit procedure call for procedure 36 | entry checks. 37 | */ 38 | 39 | #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 40 | 1 = emit procedure call for procedure exit 41 | cleanup. 42 | */ 43 | 44 | #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ 45 | /* 1 = Scheme->C does handle signals */ 46 | 47 | #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ 48 | /* 1 = recover on fixed point overflow */ 49 | 50 | /* Define only one of the supported processor types: 51 | 52 | AOSF Alpha AXP OSF/1 53 | HP700 HP 9000/700 54 | MAC_CLASSIC Macintosh system 7.1 with Think-C 5.0 55 | MC680X0 HP 9000/300, Sun 3, Next 56 | MIPS DECstation, SGI, Sony News 57 | VAX Vax ULTRIX 58 | WIN16 Microsoft Windows 3.1 59 | */ 60 | 61 | #define AOSF 1 62 | 63 | /* Attributes of the selected architecture: 64 | 65 | The following four macros define specific aspects of the system. They 66 | are defined as strings, or specifically undefined: 67 | 68 | IMPLEMENTATION_MACHINE machine type 69 | IMPLEMENTATION_CPU cpu type 70 | IMPLEMENTATION_OS operating system 71 | IMPLEMENTATION_FS file system 72 | 73 | Big endian vs. little endian: 74 | 75 | BIGENDIAN defined to 1 to denote bigendian systems 76 | 77 | Alignment: 78 | 79 | DOUBLE_ALIGN defined to 1 to force doubles to be aligned on 80 | an even S2CINT boundary 81 | 82 | Macro expansion: 83 | 84 | NEED_MACRO_ARGS defined to 1 to declare a macro like X() as 85 | X(dummy) 86 | 87 | The types S2CINT and S2CUINT are defined to be signed and unsigned integers 88 | that are the same size as pointers. This is the basic "word" used by 89 | Scheme->C. 90 | 91 | The machine state when a continuation is created is captured in the 92 | sc_jmp_buf data structure. 93 | 94 | STACKPTR( x ) is a define that stores the address of the stack pointer 95 | in x. 96 | 97 | Unix flavors: 98 | 99 | POSIX POSIX.1 compliant 100 | SYSV System V or derivative 101 | SYSV4 System V release 4 (also define SYSV, POSIX) 102 | */ 103 | 104 | /**************/ 105 | /* AOSF */ 106 | /**************/ 107 | 108 | #ifdef AOSF 109 | #define IMPLEMENTATION_MACHINE "Alpha AXP" 110 | #undef IMPLEMENTATION_CPU 111 | #define IMPLEMENTATION_OS "OSF/1" 112 | #undef IMPLEMENTATION_FS 113 | 114 | typedef long int S2CINT; /* Signed pointer size integer */ 115 | typedef long unsigned S2CUINT; /* Unsigned pointer size integer */ 116 | 117 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 118 | #define MAXS2CINT 0x7fffffffffffffffL /* Maximum value of an S2CINT */ 119 | #define MSBS2CUINT 0x8000000000000000L /* S2CUINT with 1 in the MSB */ 120 | 121 | typedef long int sc_jmp_buf[ 9 ]; /* The buffer contains the following items: 122 | s0-s6 saved registers 123 | ra return address 124 | sp stack pointer 125 | */ 126 | 127 | #define STACKPTR( x ) x = sc_getsp() 128 | extern S2CINT* sc_getsp(); 129 | 130 | #define NEED_MACRO_ARGS 1 131 | #endif 132 | 133 | -------------------------------------------------------------------------------- /ports/ARM/arm.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * ARM assembly code. 5 | * 6 | */ 7 | 8 | .align 2 9 | .global sc_getARMregs 10 | .type sc_getARMregs, %function 11 | 12 | sc_getARMregs: 13 | mov ip, sp 14 | stmfd sp!, {fp, ip, lr, pc} 15 | sub fp, ip, #4 16 | sub sp, sp, #4 17 | str r0, [fp, #-16] 18 | str r1, [r0, #0] 19 | str r2, [r0, #4] 20 | str r3, [r0, #8] 21 | str r4, [r0, #12] 22 | str r5, [r0, #16] 23 | str r6, [r0, #20] 24 | str r7, [r0, #24] 25 | str r8, [r0, #28] 26 | str r9, [r0, #32] 27 | 28 | /* 29 | The following registers aren't saved as they're blessd as 30 | special by GCC, although they don't hold the same status in 31 | the ARM spec 32 | 33 | str r10, [r0, #36] 34 | str r11, [r0, #40] 35 | str r12, [r0, #44] 36 | */ 37 | 38 | ldmfd sp, {r0, fp, sp, pc} 39 | .size sc_getARMregs, .-sc_getARMregs 40 | -------------------------------------------------------------------------------- /ports/ARM/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for LINUX. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -O2 -Wall -finline-functions -fno-math-errno -frename-registers -fomit-frame-pointer 8 | LDFLAGS = -lsigsegv 9 | CC = gcc 10 | 11 | # Assembly language object files. 12 | 13 | Aruntime = arm.o 14 | 15 | # Profiled library 16 | 17 | Plib = 18 | 19 | # Installation tools 20 | 21 | RANLIB = ranlib 22 | 23 | # X library 24 | 25 | XLIB = -lX11 26 | XLIBCFLAGS = 27 | 28 | # End of LINUX header. 29 | -------------------------------------------------------------------------------- /ports/DECMIPS/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for DECMIPS. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -O 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = mips.o 13 | 14 | # Profiled library 15 | 16 | Plib = 17 | 18 | # Installation tools 19 | 20 | RANLIB = ranlib 21 | 22 | # X library 23 | 24 | XLIB = -lX11 25 | XLIBCFLAGS = -G0 26 | 27 | # End of DECMIPS header. 28 | -------------------------------------------------------------------------------- /ports/DECMIPS/mips.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * MIPS assembly code. 5 | * 6 | */ 7 | 8 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | * All Rights Reserved 10 | 11 | * Permission is hereby granted, free of charge, to any person obtaining a 12 | * copy of this software and associated documentation files (the "Software"), 13 | * to deal in the Software without restriction, including without limitation 14 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | * and/or sell copies of the Software, and to permit persons to whom the 16 | * Software is furnished to do so, subject to the following conditions: 17 | * 18 | * The above copyright notice and this permission notice shall be included in 19 | * all copies or substantial portions of the Software. 20 | * 21 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | * DEALINGS IN THE SOFTWARE. 28 | */ 29 | 30 | 31 | /* sc_s0tos8 returns the values of s0-s8 in the caller supplied buffer. These 32 | are the "callee" save registers which need to be examined during garbage 33 | collection. 34 | */ 35 | 36 | #ifndef MIPSEL 37 | #include 38 | #else 39 | #include 40 | #endif 41 | 42 | .text 43 | .align 2 44 | .globl sc_s0tos8 45 | .ent sc_s0tos8 46 | sc_s0tos8: 47 | .frame sp, 0, ra 48 | sw s0, 0(a0) 49 | sw s1, 4(a0) 50 | sw s2, 8(a0) 51 | sw s3, 12(a0) 52 | sw s4, 16(a0) 53 | sw s5, 20(a0) 54 | sw s6, 24(a0) 55 | sw s7, 28(a0) 56 | sw s8, 32(a0) 57 | j ra 58 | .end sc_s0tos8 59 | 60 | /* sc_setsp sets the stack pointer to the argument value. It is necessary 61 | as longjmp checks to assure that the call is an "upexit". 62 | */ 63 | .text 64 | .align 2 65 | .globl sc_setsp 66 | .ent sc_setsp 67 | sc_setsp: 68 | .frame sp, 0, ra 69 | or sp, a0, a0 70 | j ra 71 | .end sc_setsp 72 | 73 | /************************************************************************** 74 | The following 4 arithmetic subroutines use MIPS instructions that generate 75 | overflow exceptions which can then be trappped. 76 | **************************************************************************/ 77 | 78 | /* sc_iplus uses the 'add' instruction to calculate the sum of the two 79 | integer arguments. 80 | */ 81 | 82 | .text 83 | .align 2 84 | .globl sc_iplus 85 | .ent sc_iplus 86 | sc_iplus: 87 | .frame sp, 0, ra 88 | add v0, a0, a1 89 | j ra 90 | .end sc_iplus 91 | 92 | /* sc_idifference uses the 'sub' instruction to calculate the difference 93 | of the two integer arguments. 94 | */ 95 | 96 | .text 97 | .align 2 98 | .globl sc_idifference 99 | .ent sc_idifference 100 | sc_idifference: 101 | .frame sp, 0, ra 102 | sub v0, a0, a1 103 | j ra 104 | .end sc_idifference 105 | 106 | 107 | /* sc_inegate also uses the 'sub' instruction to calculate the negation of 108 | the integer argument. 109 | */ 110 | 111 | .text 112 | .align 2 113 | .globl sc_inegate 114 | .ent sc_inegate 115 | sc_inegate: 116 | .frame sp, 0, ra 117 | sub v0, $0, a0 118 | j ra 119 | .end sc_inegate 120 | 121 | 122 | /* sc_itimes uses the 'mult' instruction to calculate the product of the 123 | two integer arguments. 124 | */ 125 | 126 | .text 127 | .align 2 128 | .globl sc_itimes 129 | .ent sc_itimes 130 | sc_itimes: 131 | subu sp, 24 132 | sw ra, 20(sp) 133 | sd a0, 24(sp) 134 | .mask 0x80000000, -4 135 | .frame sp, 24, ra 136 | 137 | mult a0, a1 138 | 139 | mfhi t0 140 | mflo t1 141 | sra t1, t1, 31 142 | bne t0, t1, $overflow 143 | 144 | mflo v0 145 | 146 | lw ra, 20(sp) 147 | addu sp, 24 148 | j ra 149 | 150 | $overflow: 151 | mtc1 a0, $f4 152 | cvt.d.w $f6, $f4 153 | srl t1, a1, 2 154 | mtc1 t1, $f8 155 | cvt.d.w $f10, $f8 156 | mul.d $f12, $f6, $f10 157 | jal sc_makedoublefloat 158 | lw ra, 20(sp) 159 | addu sp, 24 160 | j ra 161 | .end sc_itimes 162 | -------------------------------------------------------------------------------- /ports/FREEBSD/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for FreeBSD. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -O2 8 | CC = gcc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = x86.o 13 | 14 | # Profiled library 15 | 16 | Plib = libsc_p.a 17 | 18 | # Installation tools 19 | 20 | RANLIB = ranlib 21 | 22 | # X library 23 | 24 | XLIB = -lX11 25 | XLIBCFLAGS = 26 | 27 | # End of FREEBSD header. 28 | -------------------------------------------------------------------------------- /ports/FREEBSD/options-server.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | /* This file defines compilation options for a specific implementation */ 26 | 27 | #define CHECKSTACK 1 /* 0 = don't check stack height */ 28 | /* 1 = check stack height */ 29 | 30 | #define TIMESLICE 1 /* 0 = don't time slice execution */ 31 | /* 1 = time slice execution */ 32 | 33 | #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 34 | 1 = emit procedure call for procedure 35 | entry checks. 36 | */ 37 | 38 | #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 39 | 1 = emit procedure call for procedure exit 40 | cleanup. 41 | */ 42 | 43 | #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ 44 | /* 1 = Scheme->C does handle signals */ 45 | 46 | #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ 47 | /* 1 = recover on fixed point overflow */ 48 | 49 | /* Define only one of the supported processor types: 50 | 51 | AOSF Alpha AXP OSF/1 52 | HP700 HP 9000/700 53 | MAC_CLASSIC Macintosh system 7.1 with Think-C 5.0 54 | MC680X0 HP 9000/300, Sun 3, Next 55 | MIPS DECstation, SGI, Sony News 56 | VAX Vax ULTRIX 57 | FREEBSD x86 FreeBSD 58 | WIN16 Microsoft Windows 3.1 59 | */ 60 | 61 | #define FREEBSD 1 62 | 63 | /* Attributes of the selected architecture: 64 | 65 | The following four macros define specific aspects of the system. They 66 | are defined as strings, or specifically undefined: 67 | 68 | IMPLEMENTATION_MACHINE machine type 69 | IMPLEMENTATION_CPU cpu type 70 | IMPLEMENTATION_OS operating system 71 | IMPLEMENTATION_FS file system 72 | 73 | Big endian vs. little endian: 74 | 75 | BIGENDIAN defined to 1 to denote bigendian systems 76 | 77 | Alignment: 78 | 79 | DOUBLE_ALIGN defined to 1 to force doubles to be aligned on 80 | an even S2CINT boundary 81 | 82 | Macro expansion: 83 | 84 | NEED_MACRO_ARGS defined to 1 to declare a macro like X() as 85 | X(dummy) 86 | 87 | The types S2CINT and S2CUINT are defined to be signed and unsigned integers 88 | that are the same size as pointers. This is the basic "word" used by 89 | Scheme->C. 90 | 91 | The machine state when a continuation is created is captured in the 92 | sc_jmp_buf data structure. 93 | 94 | STACKPTR( x ) is a define that stores the address of the stack pointer 95 | in x. 96 | 97 | Unix flavors: 98 | 99 | POSIX POSIX.1 compliant 100 | SYSV System V or derivative 101 | SYSV4 System V release 4 (also define SYSV, POSIX) 102 | */ 103 | 104 | /***************/ 105 | /* FREEBSD */ 106 | /***************/ 107 | 108 | #ifdef FREEBSD 109 | #define IMPLEMENTATION_MACHINE "Generic PC" 110 | #define IMPLEMENTATION_CPU "Intelx86" 111 | #define IMPLEMENTATION_OS "FreeBSD" 112 | #undef IMPLEMENTATION_FS 113 | 114 | typedef int S2CINT; /* Signed pointer size integer */ 115 | typedef unsigned S2CUINT; /* Unsigned pointer size integer */ 116 | 117 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 118 | #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ 119 | #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ 120 | 121 | #define STACKPTR( x ) x = sc_processor_register( 0 ) 122 | 123 | #include 124 | typedef jmp_buf sc_jmp_buf; 125 | 126 | /* Horrid kludge. See callcc.c for the full story: */ 127 | #define LAZY_STACK_POP 1 128 | #define LAZY_STACK_INCREMENT 4 129 | 130 | #endif 131 | 132 | -------------------------------------------------------------------------------- /ports/FREEBSD/x86.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * x86 assembly code. 5 | * 6 | * This code originally came from the Linux port, so someone else gets 7 | * the credit for writing it. 8 | * 9 | */ 10 | 11 | #ifdef __i486__ 12 | .align 4 13 | #else 14 | .align 2 15 | #endif 16 | .globl _sc_geti386regs 17 | 18 | _sc_geti386regs: 19 | pushl %ebp 20 | movl %esp,%ebp 21 | pushl %ecx 22 | movl %eax,%ecx 23 | movl 8(%ebp),%eax 24 | movl %ecx,(%eax) 25 | popl %ecx 26 | movl %ecx,4(%eax) 27 | movl %edx,8(%eax) 28 | movl %ebx,12(%eax) 29 | movl %esi,16(%eax) 30 | movl %edi,20(%eax) 31 | movl %ebp,%esp 32 | popl %ebp 33 | ret 34 | 35 | -------------------------------------------------------------------------------- /ports/HP300/hp300.s: -------------------------------------------------------------------------------- 1 | # 2 | # SCHEME->C 3 | # 4 | # HP9000s300 assembly code. 5 | # 6 | 7 | # Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 8 | # All Rights Reserved 9 | 10 | # Permission is hereby granted, free of charge, to any person obtaining a 11 | # copy of this software and associated documentation files (the "Software"), 12 | # to deal in the Software without restriction, including without limitation 13 | # the rights to use, copy, modify, merge, publish, distribute, sublicense, 14 | # and/or sell copies of the Software, and to permit persons to whom the 15 | # Software is furnished to do so, subject to the following conditions: 16 | # 17 | # The above copyright notice and this permission notice shall be included in 18 | # all copies or substantial portions of the Software. 19 | # 20 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 21 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 22 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 23 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 24 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 25 | # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 26 | # DEALINGS IN THE SOFTWARE. 27 | # 28 | 29 | # 30 | # sc_a2to5d2to7 31 | # 32 | # sc_a2to5d2to7( a ) 33 | # will return the contents of A2, ..., A5, D2, ..., D7 starting at address 'a'. 34 | # 35 | # 36 | text 37 | global _sc_a2to5d2to7 38 | even 39 | _sc_a2to5d2to7: 40 | link.l %a6,&-4 41 | mov.l %a0,(%sp) 42 | mov.l (%a0),%a2 43 | mov.l 4(%a0),%a3 44 | mov.l 8(%a0),%a4 45 | mov.l 12(%a0),%a5 46 | mov.l 16(%a0),%d2 47 | mov.l 20(%a0),%d3 48 | mov.l 24(%a0),%d4 49 | mov.l 28(%a0),%d5 50 | mov.l 32(%a0),%d6 51 | mov.l 36(%a0),%d7 52 | unlk %a6 53 | rts 54 | -------------------------------------------------------------------------------- /ports/HP300/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for HP 9000 series 300. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -Aa -D_HPUX_SOURCE +O1 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = hp300.o 13 | 14 | # Profiled library 15 | 16 | Plib = 17 | 18 | # Installation tools 19 | 20 | RANLIB = ranlib 21 | 22 | # X library 23 | 24 | XLIB = -lX11 25 | XLIBCFLAGS = 26 | 27 | # End of HP300 header. 28 | -------------------------------------------------------------------------------- /ports/HP300/options-server.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | /* This file defines compilation options for a specific implementation */ 26 | 27 | #define CHECKSTACK 1 /* 0 = don't check stack height */ 28 | /* 1 = check stack height */ 29 | 30 | #define TIMESLICE 1 /* 0 = don't time slice execution */ 31 | /* 1 = time slice execution */ 32 | 33 | #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 34 | 1 = emit procedure call for procedure 35 | entry checks. 36 | */ 37 | 38 | #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 39 | 1 = emit procedure call for procedure exit 40 | cleanup. 41 | */ 42 | 43 | #define S2CSIGNALS 0 /* 0 = Scheme->C doesn't handle signals */ 44 | /* 1 = Scheme->C does handle signals */ 45 | 46 | #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ 47 | /* 1 = recover on fixed point overflow */ 48 | 49 | /* Define only one of the supported processor types: 50 | 51 | AOSF Alpha AXP OSF/1 52 | HP700 HP 9000/700 53 | MAC_CLASSIC Macintosh system 7.1 with Think-C 5.0 54 | MC680X0 HP 9000/300, Sun 3, Next 55 | MIPS DECstation, SGI, Sony News 56 | VAX Vax ULTRIX 57 | WIN16 Microsoft Windows 3.1 58 | */ 59 | 60 | #define MC680X0 1 61 | 62 | /* Attributes of the selected architecture: 63 | 64 | The following four macros define specific aspects of the system. They 65 | are defined as strings, or specifically undefined: 66 | 67 | IMPLEMENTATION_MACHINE machine type 68 | IMPLEMENTATION_CPU cpu type 69 | IMPLEMENTATION_OS operating system 70 | IMPLEMENTATION_FS file system 71 | 72 | Big endian vs. little endian: 73 | 74 | BIGENDIAN defined to 1 to denote bigendian systems 75 | 76 | Alignment: 77 | 78 | DOUBLE_ALIGN defined to 1 to force doubles to be aligned on 79 | an even S2CINT boundary 80 | 81 | Macro expansion: 82 | 83 | NEED_MACRO_ARGS defined to 1 to declare a macro like X() as 84 | X(dummy) 85 | 86 | The types S2CINT and S2CUINT are defined to be signed and unsigned integers 87 | that are the same size as pointers. This is the basic "word" used by 88 | Scheme->C. 89 | 90 | The machine state when a continuation is created is captured in the 91 | sc_jmp_buf data structure. 92 | 93 | STACKPTR( x ) is a define that stores the address of the stack pointer 94 | in x. 95 | 96 | Unix flavors: 97 | 98 | POSIX POSIX.1 compliant 99 | SYSV System V or derivative 100 | SYSV4 System V release 4 (also define SYSV, POSIX) 101 | */ 102 | 103 | /****************/ 104 | /* MC680X0 */ 105 | /****************/ 106 | 107 | #ifdef MC680X0 108 | #define IMPLEMENTATION_CPU "680x0" 109 | 110 | #define BIGENDIAN 1 111 | 112 | typedef int S2CINT; /* Signed pointer size integer */ 113 | typedef unsigned S2CUINT; /* Unsigned pointer size integer */ 114 | 115 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 116 | #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ 117 | #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ 118 | 119 | #define STACKPTR(x) ((x) = (sc_processor_register (15))) 120 | 121 | #ifdef __hp9000s400 122 | #define IMPLEMENTATION_MACHINE "HP9000/400" 123 | #else 124 | #ifdef __hp9000s300 125 | #define IMPLEMENTATION_MACHINE "HP9000/300" 126 | #endif 127 | #endif 128 | 129 | /* HP-UX dependent conditionalizations performed above. */ 130 | 131 | #endif 132 | 133 | -------------------------------------------------------------------------------- /ports/HP300/options.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | 26 | /* This file defines compilation options for a specific implementation */ 27 | 28 | #define CHECKSTACK 0 /* 0 = don't check stack height */ 29 | /* 1 = check stack height */ 30 | 31 | #define TIMESLICE 0 /* 0 = don't time slice execution */ 32 | /* 1 = time slice execution */ 33 | 34 | #define COMPACTPUSHTRACE 0 /* 0 = inline procedure entry checks. 35 | 1 = emit procedure call for procedure 36 | entry checks. 37 | */ 38 | 39 | #define COMPACTPOPTRACE 0 /* 0 = inline procedure exit cleanup. 40 | 1 = emit procedure call for procedure exit 41 | cleanup. 42 | */ 43 | 44 | #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ 45 | /* 1 = Scheme->C does handle signals */ 46 | 47 | #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ 48 | /* 1 = recover on fixed point overflow */ 49 | 50 | /* Define only one of the supported processor types: 51 | 52 | AOSF Alpha AXP OSF/1 53 | HP700 HP 9000/700 54 | MAC_CLASSIC Macintosh system 7.1 with Think-C 5.0 55 | MC680X0 HP 9000/300, Sun 3, Next 56 | MIPS DECstation, SGI, Sony News 57 | VAX Vax ULTRIX 58 | WIN16 Microsoft Windows 3.1 59 | */ 60 | 61 | #define MC680X0 1 62 | 63 | /* Attributes of the selected architecture: 64 | 65 | The following four macros define specific aspects of the system. They 66 | are defined as strings, or specifically undefined: 67 | 68 | IMPLEMENTATION_MACHINE machine type 69 | IMPLEMENTATION_CPU cpu type 70 | IMPLEMENTATION_OS operating system 71 | IMPLEMENTATION_FS file system 72 | 73 | Big endian vs. little endian: 74 | 75 | BIGENDIAN defined to 1 to denote bigendian systems 76 | 77 | Alignment: 78 | 79 | DOUBLE_ALIGN defined to 1 to force doubles to be aligned on 80 | an even S2CINT boundary 81 | 82 | Macro expansion: 83 | 84 | NEED_MACRO_ARGS defined to 1 to declare a macro like X() as 85 | X(dummy) 86 | 87 | The types S2CINT and S2CUINT are defined to be signed and unsigned integers 88 | that are the same size as pointers. This is the basic "word" used by 89 | Scheme->C. 90 | 91 | The machine state when a continuation is created is captured in the 92 | sc_jmp_buf data structure. 93 | 94 | STACKPTR( x ) is a define that stores the address of the stack pointer 95 | in x. 96 | 97 | Unix flavors: 98 | 99 | POSIX POSIX.1 compliant 100 | SYSV System V or derivative 101 | SYSV4 System V release 4 (also define SYSV, POSIX) 102 | */ 103 | 104 | /****************/ 105 | /* MC680X0 */ 106 | /****************/ 107 | 108 | #ifdef MC680X0 109 | #define IMPLEMENTATION_CPU "680x0" 110 | 111 | #define BIGENDIAN 1 112 | 113 | typedef int S2CINT; /* Signed pointer size integer */ 114 | typedef unsigned S2CUINT; /* Unsigned pointer size integer */ 115 | 116 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 117 | #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ 118 | #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ 119 | 120 | #define STACKPTR(x) ((x) = (sc_processor_register (15))) 121 | 122 | #ifdef __hp9000s400 123 | #define IMPLEMENTATION_MACHINE "HP9000/400" 124 | #else 125 | #ifdef __hp9000s300 126 | #define IMPLEMENTATION_MACHINE "HP9000/300" 127 | #endif 128 | #endif 129 | 130 | /* HP-UX dependent conditionalizations performed above. */ 131 | 132 | #endif 133 | 134 | -------------------------------------------------------------------------------- /ports/HP700/hp700.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * PA-RISC assembly code. 5 | * 6 | */ 7 | 8 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | * All Rights Reserved 10 | 11 | * Permission is hereby granted, free of charge, to any person obtaining a 12 | * copy of this software and associated documentation files (the "Software"), 13 | * to deal in the Software without restriction, including without limitation 14 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | * and/or sell copies of the Software, and to permit persons to whom the 16 | * Software is furnished to do so, subject to the following conditions: 17 | * 18 | * The above copyright notice and this permission notice shall be included in 19 | * all copies or substantial portions of the Software. 20 | * 21 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | * DEALINGS IN THE SOFTWARE. 28 | */ 29 | 30 | 31 | /* sc_r1tor18 returns the values of r1-r18 in the caller supplied 32 | buffer. These are the "callee" save registers which need to be 33 | examined during garbage collection. 34 | */ 35 | 36 | #include 37 | 38 | .code 39 | .align 2 40 | .export sc_r1tor18, entry 41 | 42 | sc_r1tor18 43 | .proc 44 | .callinfo 45 | .enter 46 | stw r1,0(%arg0) 47 | stw r2,4(%arg0) 48 | stw r3,8(%arg0) 49 | stw r4,12(%arg0) 50 | stw r5,16(%arg0) 51 | stw r6,20(%arg0) 52 | stw r7,24(%arg0) 53 | stw r8,28(%arg0) 54 | stw r9,32(%arg0) 55 | stw r10,36(%arg0) 56 | stw r11,40(%arg0) 57 | stw r12,44(%arg0) 58 | stw r13,48(%arg0) 59 | stw r14,52(%arg0) 60 | stw r15,56(%arg0) 61 | stw r16,60(%arg0) 62 | stw r17,64(%arg0) 63 | stw r18,68(%arg0) 64 | .leave 65 | .procend 66 | 67 | .end sc_r1tor18 68 | 69 | 70 | -------------------------------------------------------------------------------- /ports/HP700/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for HP 9000 series 700. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -Aa -D_HPUX_SOURCE -O 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = hp700.o 13 | 14 | # Profiled library 15 | 16 | Plib = 17 | 18 | # Installation tools 19 | 20 | RANLIB = ranlib 21 | 22 | # X library 23 | 24 | XLIB = -lX11 25 | XLIBCFLAGS = 26 | 27 | # End of HP700 header. 28 | -------------------------------------------------------------------------------- /ports/LINUX/linux.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * LINUX assembly code. 5 | * 6 | */ 7 | 8 | #ifdef __i486__ 9 | .align 4 10 | #else 11 | .align 2 12 | #endif 13 | .globl sc_geti386regs 14 | 15 | sc_geti386regs: 16 | pushl %ebp 17 | movl %esp,%ebp 18 | pushl %ecx 19 | movl %eax,%ecx 20 | movl 8(%ebp),%eax 21 | movl %ecx,(%eax) 22 | popl %ecx 23 | movl %ecx,4(%eax) 24 | movl %edx,8(%eax) 25 | movl %ebx,12(%eax) 26 | movl %esi,16(%eax) 27 | movl %edi,20(%eax) 28 | movl %ebp,%esp 29 | popl %ebp 30 | ret 31 | 32 | -------------------------------------------------------------------------------- /ports/LINUX/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for LINUX. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -march=native -Wall -O2 -finline-functions -fno-math-errno -frename-registers -fomit-frame-pointer -m32 -fno-strict-aliasing 8 | LDFLAGS = -m32 -lsigsegv 9 | CC = gcc 10 | 11 | # Assembly language object files. 12 | 13 | Aruntime = linux.o 14 | 15 | # Profiled library 16 | 17 | Plib = 18 | 19 | # Installation tools 20 | 21 | RANLIB = ranlib 22 | 23 | # X library 24 | 25 | XLIB = -lX11 26 | XLIBCFLAGS = 27 | 28 | # End of LINUX header. 29 | -------------------------------------------------------------------------------- /ports/MACOS/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for MACOS. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -march=native -Wall -O2 -finline-functions -fno-math-errno 8 | LDFLAGS = -lsigsegv 9 | CC = gcc 10 | 11 | # Assembly language object files. 12 | 13 | Aruntime = x86.o 14 | 15 | # Profiled library 16 | 17 | Plib = 18 | 19 | # Installation tools 20 | 21 | RANLIB = ranlib 22 | 23 | # X library 24 | 25 | XLIB = -lX11 -L/opt/X11/lib 26 | XLIBCFLAGS = 27 | 28 | # End of MACOS header. 29 | -------------------------------------------------------------------------------- /ports/MACOS/x86.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * This assembly code came from the AMD64 port. 5 | * 6 | */ 7 | 8 | .globl _sc_geti386regs 9 | 10 | _sc_geti386regs: 11 | pushq %rbp 12 | movq %rsp,%rbp 13 | movq %rax,(%rdi) 14 | movq %rbx,8(%rdi) 15 | movq %rcx,16(%rdi) 16 | movq %rdx,24(%rdi) 17 | movq %rsi,32(%rdi) 18 | movq %r8,40(%rdi) 19 | movq %r9,48(%rdi) 20 | movq %r10,56(%rdi) 21 | movq %r11,64(%rdi) 22 | movq %r12,72(%rdi) 23 | movq %r13,80(%rdi) 24 | movq %r14,88(%rdi) 25 | movq %r15,96(%rdi) 26 | movq %rdi,%rax 27 | movq %rbp,%rsp 28 | popq %rbp 29 | ret 30 | 31 | -------------------------------------------------------------------------------- /ports/MAC_CLASSIC/makefile-head: -------------------------------------------------------------------------------- 1 | # Header for the MAC_CLASSIC port for Scheme->C 2 | 3 | unpack: unpack.c 4 | cc -o unpack unpack.c 5 | 6 | sourcefiles: 7 | pack sourcefiles 8 | 9 | # End of header 10 | -------------------------------------------------------------------------------- /ports/MAC_CLASSIC/options.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | 26 | 27 | /* This file defines compilation options for a specific implementation */ 28 | 29 | #define CHECKSTACK 1 /* 0 = don't check stack height */ 30 | /* 1 = check stack height */ 31 | 32 | #define TIMESLICE 1 /* 0 = don't time slice execution */ 33 | /* 1 = time slice execution */ 34 | 35 | #define COMPACTPUSHTRACE 1 /* 0 = inline procedure entry checks. 36 | 1 = emit procedure call for procedure 37 | entry checks. 38 | */ 39 | 40 | #define COMPACTPOPTRACE 1 /* 0 = inline procedure exit cleanup. 41 | 1 = emit procedure call for procedure exit 42 | cleanup. 43 | */ 44 | 45 | #define S2CSIGNALS 1 /* 0 = Scheme->C doesn't handle signals */ 46 | /* 1 = Scheme->C does handle signals */ 47 | 48 | #define MATHTRAPS 0 /* 0 = don't detect fixed point overflow */ 49 | /* 1 = recover on fixed point overflow */ 50 | 51 | /* Define only one of the supported processor types: 52 | 53 | AOSF Alpha AXP OSF/1 54 | HP700 HP 9000/700 55 | MAC_CLASSIC Macintosh system 7.1 with Think-C 5.0 56 | MC680X0 HP 9000/300, Sun 3, Next 57 | MIPS DECstation, SGI, Sony News 58 | VAX Vax ULTRIX 59 | WIN16 Microsoft Windows 3.1 60 | */ 61 | 62 | #define MAC_CLASSIC 1 63 | 64 | /* Attributes of the selected architecture: 65 | 66 | The following four macros define specific aspects of the system. They 67 | are defined as strings, or specifically undefined: 68 | 69 | IMPLEMENTATION_MACHINE machine type 70 | IMPLEMENTATION_CPU cpu type 71 | IMPLEMENTATION_OS operating system 72 | IMPLEMENTATION_FS file system 73 | 74 | Big endian vs. little endian: 75 | 76 | BIGENDIAN defined to 1 to denote bigendian systems 77 | 78 | Alignment: 79 | 80 | DOUBLE_ALIGN defined to 1 to force doubles to be aligned on 81 | an even S2CINT boundary 82 | 83 | Macro expansion: 84 | 85 | NEED_MACRO_ARGS defined to 1 to declare a macro like X() as 86 | X(dummy) 87 | 88 | The types S2CINT and S2CUINT are defined to be signed and unsigned integers 89 | that are the same size as pointers. This is the basic "word" used by 90 | Scheme->C. 91 | 92 | The machine state when a continuation is created is captured in the 93 | sc_jmp_buf data structure. 94 | 95 | STACKPTR( x ) is a define that stores the address of the stack pointer 96 | in x. 97 | 98 | Unix flavors: 99 | 100 | POSIX POSIX.1 compliant 101 | SYSV System V or derivative 102 | SYSV4 System V release 4 (also define SYSV, POSIX) 103 | */ 104 | 105 | /******************/ 106 | /* MAC_CLASSIC */ 107 | /******************/ 108 | 109 | #ifdef MAC_CLASSIC 110 | #define IMPLEMENTATION_MACHINE "Apple Macintosh" 111 | #define IMPLEMENTATION_CPU "680x0" 112 | #define IMPLEMENTATION_OS "7.1" 113 | #undef IMPLEMENTATION_FS 114 | 115 | #define BIGENDIAN 1 116 | 117 | typedef long int S2CINT; /* Signed pointer size integer */ 118 | typedef long unsigned S2CUINT; /* Unsigned pointer size integer */ 119 | 120 | typedef short int PAGELINK; /* 16-bit sc_pagelink values */ 121 | #define MAXS2CINT 0x7fffffffL /* Maximum value of an S2CINT */ 122 | #define MSBS2CUINT 0x80000000L /* S2CUINT with 1 in the MSB */ 123 | 124 | #include 125 | typedef jmp_buf sc_jmp_buf; 126 | #undef TRUE 127 | #undef FALSE 128 | 129 | #define STACKPTR( x ) x = sc_getsp() 130 | extern S2CINT* sc_getsp(); 131 | 132 | #define SCHEAP 1 133 | #define SCMAXHEAP 15 134 | #endif 135 | -------------------------------------------------------------------------------- /ports/MAC_CLASSIC/pack: -------------------------------------------------------------------------------- 1 | #! /bin/csh -f 2 | rm -f sourcefiles 3 | touch sourcefiles 4 | foreach x ({*.c,*.h,../test/alltests.sc,../test/test20-input.sc}) 5 | echo "####START" >> sourcefiles 6 | echo $x:t >> sourcefiles 7 | cat $x >> sourcefiles 8 | echo "####END" >> sourcefiles 9 | end 10 | -------------------------------------------------------------------------------- /ports/MAC_CLASSIC/unpack: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/scheme2c/2b7085746bc5d1b932ef36a32f2dc9a7547f3b53/ports/MAC_CLASSIC/unpack -------------------------------------------------------------------------------- /ports/MAC_CLASSIC/unpack.c: -------------------------------------------------------------------------------- 1 | /* Unpacks the file containing all MAC files. */ 2 | 3 | #include 4 | #ifndef mips 5 | #include 6 | #endif 7 | 8 | main() 9 | { 10 | char line[200], **ap; 11 | FILE *out; 12 | 13 | #ifndef mips 14 | ccommand( &ap ); 15 | #endif 16 | while (gets( line ) != NULL) { 17 | if (strcmp( line, "####START" ) == 0) { 18 | out = fopen( gets( line ), "w" ); 19 | if (out == NULL) exit( 1 ); 20 | fputs( line, stdout ); 21 | while (gets( line ) != NULL && strcmp( line, "####END" )) { 22 | fputs( line, out ); 23 | fputs( "\n", out ); 24 | } 25 | fclose( out ); 26 | fputs( "\n", stdout ); 27 | } else { 28 | fputs( "Junk on end-of-file, Quit!\n", stdout ); 29 | exit( 1 ); 30 | } 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /ports/OPENBSD/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for OPENBSD. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -I/usr/local/include -march=native -Wall -O2 -finline-functions -fno-math-errno -frename-registers -fomit-frame-pointer -m32 8 | LDFLAGS = -L/usr/X11R6/lib -L/usr/local/lib -m32 -lsigsegv 9 | CC = gcc 10 | 11 | # Assembly language object files. 12 | 13 | Aruntime = openbsd.o 14 | 15 | # Profiled library 16 | 17 | Plib = 18 | 19 | # Installation tools 20 | 21 | RANLIB = ranlib 22 | 23 | # X library 24 | 25 | XLIB = -lX11 26 | XLIBCFLAGS = 27 | 28 | # End of OPENBSD header. 29 | -------------------------------------------------------------------------------- /ports/OPENBSD/openbsd.s: -------------------------------------------------------------------------------- 1 | /* 2 | * SCHEME->C 3 | * 4 | * OPENBSD assembly code. 5 | * 6 | */ 7 | 8 | #ifdef __i486__ 9 | .align 4 10 | #else 11 | .align 2 12 | #endif 13 | .globl sc_geti386regs 14 | 15 | sc_geti386regs: 16 | pushl %ebp 17 | movl %esp,%ebp 18 | pushl %ecx 19 | movl %eax,%ecx 20 | movl 8(%ebp),%eax 21 | movl %ecx,(%eax) 22 | popl %ecx 23 | movl %ecx,4(%eax) 24 | movl %edx,8(%eax) 25 | movl %ebx,12(%eax) 26 | movl %esi,16(%eax) 27 | movl %edi,20(%eax) 28 | movl %ebp,%esp 29 | popl %ebp 30 | ret 31 | 32 | -------------------------------------------------------------------------------- /ports/RS6000/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for IBM RS/6000. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -D_AIX_SOURCE -O 8 | CC = gcc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = rs6000.o 13 | 14 | # Profiled library 15 | 16 | Plib = 17 | 18 | # Installation tools 19 | 20 | RANLIB = ranlib 21 | 22 | # X library 23 | 24 | XLIB = -lX11 25 | XLIBCFLAGS = 26 | 27 | # End of RS6000 header. 28 | -------------------------------------------------------------------------------- /ports/RS6000/rs6000.s: -------------------------------------------------------------------------------- 1 | # 2 | # SCHEME->C 3 | # 4 | # PowerPC assembly code. 5 | # 6 | 7 | # sc_r14tor31 returns the values of r14-r31 in the caller-supplied 8 | # buffer. These are the "callee" save registers that need to be 9 | # examined during garbage collection. 10 | 11 | .align 2 12 | .globl .sc_r14tor31 13 | .csect .text[PR] 14 | 15 | .sc_r14tor31: 16 | stw 14,0(3) 17 | stw 15,4(3) 18 | stw 16,8(3) 19 | stw 17,12(3) 20 | stw 18,16(3) 21 | stw 19,20(3) 22 | stw 20,24(3) 23 | stw 21,28(3) 24 | stw 22,32(3) 25 | stw 23,36(3) 26 | stw 24,40(3) 27 | stw 25,44(3) 28 | stw 26,48(3) 29 | stw 27,52(3) 30 | stw 28,56(3) 31 | stw 29,60(3) 32 | stw 30,64(3) 33 | stw 31,68(3) 34 | 35 | blr 36 | -------------------------------------------------------------------------------- /ports/SGIMIPS/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for SGIMIPS. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -O 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = mips.o 13 | 14 | # Profiled library 15 | 16 | Plib = 17 | 18 | # Installation tools 19 | 20 | RANLIB = ../ranlib 21 | 22 | # X library 23 | 24 | XLIB = -lX11 25 | XLIBCFLAGS = -G0 26 | 27 | # Force make to use the right shell 28 | 29 | SHELL = /bin/sh 30 | 31 | # End of SGIMIPS header. 32 | -------------------------------------------------------------------------------- /ports/SGIMIPS/ranlib: -------------------------------------------------------------------------------- 1 | #!/bin/csh 2 | echo "ranlib(1) not implemented on Silicon Graphics Iris" 3 | -------------------------------------------------------------------------------- /ports/SONYMIPS/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for SONYMIPS. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -Xa -O 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = mips.o 13 | 14 | # Profiled library 15 | 16 | Plib = 17 | 18 | # Installation tools 19 | 20 | RANLIB = ranlib 21 | 22 | # X library 23 | 24 | XLIB = -lX11 25 | XLIBCFLAGS = -G0 26 | 27 | # End of SONYMIPS header. 28 | -------------------------------------------------------------------------------- /ports/SUNOS4/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for SPARC-SunOS4.1.x. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -O 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = sparc.o 13 | 14 | # need to override the default ".s.o" rule in the generic makefile 15 | 16 | sparc.o: sparc.s 17 | as -o sparc.o -P -DSUNOS4 sparc.s 18 | 19 | # Profiled library 20 | 21 | Plib = libsc_p.a 22 | 23 | # Installation tools 24 | 25 | RANLIB = ranlib 26 | 27 | # X library 28 | 29 | XLIB = -lX11 30 | XLIBCFLAGS = 31 | 32 | # End of SPARC-SunOS4.1.x header. 33 | -------------------------------------------------------------------------------- /ports/SUNOS4/options-server.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /****************/ 4 | /* SPARC-SunOS4 */ 5 | /****************/ 6 | 7 | #define SPARC 8 | #define SUNOS4 9 | 10 | /* callcc.c */ 11 | #undef COPY_STACK_BEFORE_LONGJMP 12 | 13 | /* cio.c */ 14 | #undef POSIX 15 | #undef SYSV 16 | #undef SYSV4 17 | #undef HAVE_TIMES 18 | 19 | /* objects.h */ 20 | #define BIGENDIAN 1 21 | #undef COMPACTPUSHTRACE 22 | #undef COMPACTPOPTRACE 23 | #undef NEED_MACROS_ARGS 24 | 25 | /* scinit.c */ 26 | #define IMPLEMENTATION_MACHINE "SPARC" 27 | #define IMPLEMENTATION_CPU "SPARC" 28 | #define IMPLEMENTATION_OS "SunOS 4.x" 29 | #undef IMPLEMENTATION_FS 30 | #undef STDERR_ISNT_UNBUFFERED 31 | 32 | /* 33 | * The sc_jmp_buf buffer contains the following items: 34 | * %o6-%o7, %g1-%g7, %l0-%l7, %i0-%i7, %y, 35 | * 0-4, 8-32, 36-64, 68-96, 100, 104 36 | */ 37 | typedef int sc_jmp_buf[2+7+8+8+1+1]; /* heap.c, objects.h, sparc.s */ 38 | 39 | #undef DOUBLE_ALIGN /* heap.h, objects.h */ 40 | #undef STACK_GROWS_POSITIVE /* callcc.c, objects.h, scinit.c */ 41 | #define MATHTRAPS 1 /* mtraps.c, objects.h, sparc.s */ 42 | 43 | typedef int S2CINT; /* Signed pointer size integer */ 44 | typedef unsigned S2CUINT; /* Unsigned pointer size integer */ 45 | 46 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 47 | #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ 48 | #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ 49 | 50 | #define STACKPTR(x) ((x) = (sc_processor_register(0))) 51 | 52 | /* be a server */ 53 | #define CHECKSTACK 1 /* objects.h */ 54 | #undef S2CSIGNALS /* cio.c */ 55 | #define TIMESLICE 1 /* cio.c, cio.h, objects.h */ 56 | -------------------------------------------------------------------------------- /ports/SUNOS4/options.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /****************/ 4 | /* SPARC-SunOS4 */ 5 | /****************/ 6 | 7 | #define SPARC 8 | #define SUNOS4 9 | 10 | /* callcc.c */ 11 | #undef COPY_STACK_BEFORE_LONGJMP 12 | 13 | /* cio.c */ 14 | #undef POSIX 15 | #undef SYSV 16 | #undef SYSV4 17 | #undef HAVE_TIMES 18 | 19 | /* objects.h */ 20 | #define BIGENDIAN 1 21 | #undef COMPACTPUSHTRACE 22 | #undef COMPACTPOPTRACE 23 | #undef NEED_MACROS_ARGS 24 | 25 | /* scinit.c */ 26 | #define IMPLEMENTATION_MACHINE "SPARC" 27 | #define IMPLEMENTATION_CPU "SPARC" 28 | #define IMPLEMENTATION_OS "SunOS 4.x" 29 | #undef IMPLEMENTATION_FS 30 | #undef STDERR_ISNT_UNBUFFERED 31 | 32 | /* 33 | * The sc_jmp_buf buffer contains the following items: 34 | * %o6-%o7, %g1-%g7, %l0-%l7, %i0-%i7, %y, 35 | * 0-4, 8-32, 36-64, 68-96, 100, 104 36 | */ 37 | typedef int sc_jmp_buf[2+7+8+8+1+1]; /* heap.c, objects.h, sparc.s */ 38 | 39 | #undef DOUBLE_ALIGN /* heap.h, objects.h */ 40 | #undef STACK_GROWS_POSITIVE /* callcc.c, objects.h, scinit.c */ 41 | #define MATHTRAPS 1 /* mtraps.c, objects.h, sparc.s */ 42 | 43 | typedef int S2CINT; /* Signed pointer size integer */ 44 | typedef unsigned S2CUINT; /* Unsigned pointer size integer */ 45 | 46 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 47 | #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ 48 | #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ 49 | 50 | #define STACKPTR(x) ((x) = (sc_processor_register(0))) 51 | 52 | /* not a server */ 53 | #undef CHECKSTACK /* objects.h */ 54 | #define S2CSIGNALS 1 /* cio.c */ 55 | #undef TIMESLICE /* cio.c, cio.h, objects.h */ 56 | -------------------------------------------------------------------------------- /ports/SUNOS4/sparc-pragma.h: -------------------------------------------------------------------------------- 1 | /* This is the pragma declaration that is necessary to tell the SPARC */ 2 | /* compiler about the new setjmp routine. */ 3 | #pragma unknown_control_flow(sc_setjmp) 4 | -------------------------------------------------------------------------------- /ports/SUNOS5/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for SPARC-SunOS5.x 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -O 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = sparc.o 13 | 14 | # need to override the default ".s.o" rule in the generic makefile 15 | 16 | sparc.o: sparc.s 17 | cpp sparc.s sparc-cpp.s 18 | as -o sparc.o -P sparc-cpp.s 19 | 20 | # Profiled library 21 | 22 | Plib = libsc_p.a 23 | 24 | # Installation tools 25 | 26 | RANLIB = echo 27 | 28 | # X library 29 | 30 | XLIB = -lX11 31 | XLIBCFLAGS = 32 | 33 | # End of SPARC-SunOS5.x header. 34 | -------------------------------------------------------------------------------- /ports/SUNOS5/options-server.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /****************/ 4 | /* SPARC-SunOS5 */ 5 | /****************/ 6 | 7 | #define SPARC 8 | #define SUNOS5 9 | 10 | /* callcc.c */ 11 | #undef COPY_STACK_BEFORE_LONGJMP 12 | 13 | /* cio.c */ 14 | #define POSIX 1 15 | #define SYSV 1 16 | #define SYSV4 1 17 | #undef HAVE_RUSAGE 18 | 19 | /* objects.h */ 20 | #define BIGENDIAN 1 21 | #undef COMPACTPUSHTRACE 22 | #undef COMPACTPOPTRACE 23 | #undef NEED_MACROS_ARGS 24 | 25 | /* scinit.c */ 26 | #define IMPLEMENTATION_MACHINE "SPARC" 27 | #define IMPLEMENTATION_CPU "SPARC" 28 | #define IMPLEMENTATION_OS "SunOS 5.x" 29 | #undef IMPLEMENTATION_FS 30 | #undef STDERR_ISNT_UNBUFFERED 31 | 32 | /* 33 | * The sc_jmp_buf buffer contains the following items: 34 | * %o6-%o7, %g1-%g7, %l0-%l7, %i0-%i7, %y, 35 | * 0-4, 8-32, 36-64, 68-96, 100, 104-116 36 | */ 37 | typedef int sc_jmp_buf[2+7+8+8+1+4]; /* heap.c, objects.h, sparc.s */ 38 | 39 | #undef DOUBLE_ALIGN /* heap.h, objects.h */ 40 | #undef STACK_GROWS_POSITIVE /* callcc.c, objects.h, scinit.c */ 41 | #define MATHTRAPS 1 /* mtraps.c, objects.h, sparc.s */ 42 | 43 | typedef int S2CINT; /* Signed pointer size integer */ 44 | typedef unsigned S2CUINT; /* Unsigned pointer size integer */ 45 | 46 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 47 | #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ 48 | #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ 49 | 50 | #define STACKPTR(x) ((x) = (sc_processor_register(0))) 51 | 52 | /* be a server */ 53 | #define CHECKSTACK 1 /* objects.h */ 54 | #undef S2CSIGNALS /* cio.c */ 55 | #define TIMESLICE 1 /* cio.c, cio.h, objects.h */ 56 | -------------------------------------------------------------------------------- /ports/SUNOS5/options.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /****************/ 4 | /* SPARC-SunOS5 */ 5 | /****************/ 6 | 7 | #define SPARC 8 | #define SUNOS5 9 | 10 | /* callcc.c */ 11 | #undef COPY_STACK_BEFORE_LONGJMP 12 | 13 | /* cio.c */ 14 | #define POSIX 1 15 | #define SYSV 1 16 | #define SYSV4 1 17 | #undef HAVE_RUSAGE 18 | 19 | /* objects.h */ 20 | #define BIGENDIAN 1 21 | #undef COMPACTPUSHTRACE 22 | #undef COMPACTPOPTRACE 23 | #undef NEED_MACROS_ARGS 24 | 25 | /* scinit.c */ 26 | #define IMPLEMENTATION_MACHINE "SPARC" 27 | #define IMPLEMENTATION_CPU "SPARC" 28 | #define IMPLEMENTATION_OS "SunOS 5.x" 29 | #undef IMPLEMENTATION_FS 30 | #undef STDERR_ISNT_UNBUFFERED 31 | 32 | /* 33 | * The sc_jmp_buf buffer contains the following items: 34 | * %o6-%o7, %g1-%g7, %l0-%l7, %i0-%i7, %y, 35 | * 0-4, 8-32, 36-64, 68-96, 100, 104-116 36 | */ 37 | typedef int sc_jmp_buf[2+7+8+8+1+4]; /* heap.c, objects.h, sparc.s */ 38 | 39 | #undef DOUBLE_ALIGN /* heap.h, objects.h */ 40 | #undef STACK_GROWS_POSITIVE /* callcc.c, objects.h, scinit.c */ 41 | #define MATHTRAPS 1 /* mtraps.c, objects.h, sparc.s */ 42 | 43 | typedef int S2CINT; /* Signed pointer size integer */ 44 | typedef unsigned S2CUINT; /* Unsigned pointer size integer */ 45 | 46 | typedef int PAGELINK; /* 32-bit sc_pagelink values */ 47 | #define MAXS2CINT 0x7fffffff /* Maximum value of an S2CINT */ 48 | #define MSBS2CUINT 0x80000000 /* S2CUINT with 1 in the MSB */ 49 | 50 | #define STACKPTR(x) ((x) = (sc_processor_register(0))) 51 | 52 | /* not a server */ 53 | #undef CHECKSTACK /* objects.h */ 54 | #define S2CSIGNALS 1 /* cio.c */ 55 | #undef TIMESLICE /* cio.c, cio.h, objects.h */ 56 | -------------------------------------------------------------------------------- /ports/SUNOS5/sparc-pragma.h: -------------------------------------------------------------------------------- 1 | /* This is the pragma declaration that is necessary to tell the SPARC */ 2 | /* compiler about the new setjmp routine. */ 3 | #pragma unknown_control_flow(sc_setjmp) 4 | -------------------------------------------------------------------------------- /ports/VAX/makefile-head: -------------------------------------------------------------------------------- 1 | # 2 | # This is the header file for constructing make files for VAX. 3 | # 4 | 5 | # Default flags to use when invoking the C compiler. 6 | 7 | CFLAGS = -O 8 | CC = cc 9 | 10 | # Assembly language object files. 11 | 12 | Aruntime = vax.o 13 | 14 | # Profiled library 15 | 16 | Plib = libsc_p.a 17 | 18 | # Installation tools 19 | 20 | RANLIB = ranlib 21 | 22 | # X library 23 | 24 | XLIB = -lX11 25 | XLIBCFLAGS = 26 | 27 | # End of VAX header. 28 | -------------------------------------------------------------------------------- /ports/makefile: -------------------------------------------------------------------------------- 1 | # 2 | # This file is used to make the Scheme->C system for a specific processor 3 | # type. 4 | # 5 | 6 | # The Scheme->C system is initially compiled from the C sources by the 7 | # following: 8 | 9 | port: 10 | $(MAKE) -C scrt port 11 | $(MAKE) -C scsc port 12 | $(MAKE) -C test autotest 13 | 14 | # Install in system directories; use prefix=~ for private copy 15 | 16 | install: 17 | $(MAKE) -C scrt install 18 | $(MAKE) -C scsc install 19 | $(MAKE) -C cdecl install 20 | $(MAKE) -C xlib install 21 | 22 | # Clean out working files. 23 | 24 | clean: 25 | rm -f *.BAK *.CKP SC-TO-C* 26 | $(MAKE) -C scrt clean 27 | $(MAKE) -C scsc clean 28 | $(MAKE) -C cdecl clean 29 | $(MAKE) -C xlib clean 30 | $(MAKE) -C test clean 31 | 32 | # Clean up C source files generated from Scheme source. 33 | 34 | clean-sc-to-c: 35 | $(MAKE) -C scrt clean-sc-to-c 36 | $(MAKE) -C scsc clean-sc-to-c 37 | $(MAKE) -C cdecl clean-sc-to-c 38 | $(MAKE) -C xlib clean-sc-to-c 39 | $(MAKE) -C test clean-sc-to-c 40 | 41 | # Delete programs and libraries. 42 | 43 | noprogs: 44 | $(MAKE) -C scrt noprogs 45 | $(MAKE) -C scsc noprogs 46 | $(MAKE) -C cdecl noprogs 47 | $(MAKE) -C xlib noprogs 48 | $(MAKE) -C test noprogs 49 | 50 | # All files which must be constructed are made by the following command: 51 | 52 | all: 53 | $(MAKE) -C scrt all 54 | $(MAKE) -C scsc all 55 | $(MAKE) -C cdecl all 56 | $(MAKE) -C xlib all 57 | -------------------------------------------------------------------------------- /scrt/README: -------------------------------------------------------------------------------- 1 | This directory contains the shared files for the SCHEME->C runtime system. 2 | -------------------------------------------------------------------------------- /scrt/apply.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | 26 | /* This module defines the APPLY and UNKNOWNCALL functions. APPLY is as 27 | defined in Revised**3 and UNKNOWNCALL is a variant of APPLY which is used 28 | by the compiler to call unknown functions. 29 | */ 30 | 31 | #define MAXARGS 70 /* Maximum number of required arguments permitted. 32 | Note that this does not preclude an optional 33 | argument list as an additional argument. This 34 | number is typically determined by the ability 35 | of one's C compiler. */ 36 | /* I changed this from 25 to 30 -- Qobi M19Aug96 */ 37 | /* I changed this from 30 to 40 -- Qobi T25Aug98 */ 38 | /* I changed this from 40 to 50 -- Qobi H7Nov98 */ 39 | /* I changed this from 50 to 70 -- Qobi F22Aug08 */ 40 | 41 | extern S2CINT sc_unknownargc; /* Data structures for sc_unknowncall */ 42 | 43 | extern TSCP sc_unknownproc[ 4 ]; 44 | 45 | extern TSCP sc_arg[MAXARGS]; 46 | 47 | /* The procedural interfaces in this module are: */ 48 | 49 | extern TSCP sc_apply_2dtwo(); 50 | 51 | extern TSCP sc_unknowncall(TSCP va_alist, ...); /* Qobi h15jan2005 */ 52 | -------------------------------------------------------------------------------- /scrt/c.sc: -------------------------------------------------------------------------------- 1 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 2 | ;* All Rights Reserved 3 | 4 | ;* Permission is hereby granted, free of charge, to any person obtaining a 5 | ;* copy of this software and associated documentation files (the "Software"), 6 | ;* to deal in the Software without restriction, including without limitation 7 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | ;* and/or sell copies of the Software, and to permit persons to whom the 9 | ;* Software is furnished to do so, subject to the following conditions: 10 | ;* 11 | ;* The above copyright notice and this permission notice shall be included in 12 | ;* all copies or substantial portions of the Software. 13 | ;* 14 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 20 | ;* DEALINGS IN THE SOFTWARE. 21 | 22 | -------------------------------------------------------------------------------- /scrt/callcc.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | 26 | /* This module implements CALL-WITH-CURRENT-CONTINUATION. SC_CLINK is a 27 | pointer to the current "inner most" continuation on the stack. 28 | */ 29 | 30 | extern TSCP sc_clink; 31 | 32 | /* Procedural interfaces in this module: */ 33 | 34 | extern TSCP sc_ntinuation_1af38b9f_v; 35 | 36 | extern TSCP sc_callcc(); 37 | 38 | -------------------------------------------------------------------------------- /scrt/cio.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | /* This module supplies functions to access system dependent facilities. */ 26 | 27 | extern TSCP sc_stdin_v; 28 | 29 | extern TSCP sc_stdout_v; 30 | 31 | extern TSCP sc_stderr_v; 32 | 33 | extern void sc_setstdio(); 34 | 35 | extern TSCP sc_fopen( XAL2( TSCP, TSCP ) ); 36 | 37 | extern TSCP sc_fclose( XAL1( TSCP ) ); 38 | 39 | extern TSCP sc_fflush( XAL1( TSCP ) ); 40 | 41 | extern TSCP sc_fgetc( XAL1( TSCP ) ); 42 | 43 | extern TSCP sc_fputc( XAL2( TSCP, TSCP ) ); 44 | 45 | extern TSCP sc_charready( XAL1( TSCP ) ); 46 | 47 | extern TSCP sc_fileno( XAL1( TSCP ) ); 48 | 49 | extern TSCP sc_inputready( XAL1( TSCP ) ); 50 | 51 | extern TSCP sc_removefile( XAL1( TSCP ) ); 52 | 53 | extern TSCP sc_rename( XAL2( TSCP, TSCP ) ); 54 | 55 | extern TSCP sc_formatnumber( XAL3( TSCP, TSCP, TSCP ) ); 56 | 57 | extern TSCP sc_readnumber( XAL2( TSCP, TSCP ) ); 58 | 59 | extern char* sc_getenv( XAL1( char* ) ); 60 | 61 | #ifdef __GNUC__ 62 | extern void sc_abort() __attribute__((noreturn)); 63 | #else 64 | extern void sc_abort(); 65 | #endif 66 | 67 | extern double sc_cputime(); 68 | 69 | extern void sc_log_string( XAL1( char * ) ); 70 | 71 | extern void sc_log_dec( XAL1( S2CINT ) ); 72 | 73 | extern void sc_log_hex( XAL1( S2CUINT ) ); 74 | 75 | extern TSCP sc_error_2ddisplay( XAL1( TSCP ) ); 76 | 77 | extern void sc_getheap( XAL2( S2CINT, S2CINT ) ); 78 | 79 | extern void sc_freeheap( XAL1( void* ) ); 80 | 81 | extern VOIDP sc_gettable( XAL2( S2CINT, S2CINT ) ); 82 | 83 | extern void sc_freetable( XAL1( void* ) ); 84 | 85 | /* Signal handling - N.B. signals and time slicing are mutually exclusive. */ 86 | 87 | extern void sc_dispatchpendingsignals(); 88 | 89 | extern S2CINT sc_mutex; 90 | 91 | extern S2CINT sc_pendingsignals; 92 | 93 | #if TIMESLICE 94 | #define MUTEXON 95 | #define MUTEXOFF 96 | #else 97 | #define MUTEXON sc_mutex = 1 98 | #define MUTEXOFF if ((sc_mutex = sc_pendingsignals) && sc_collecting == 0) \ 99 | sc_dispatchpendingsignals() 100 | #endif 101 | 102 | /* Information about allocated heap space is returned in the following 103 | structure. 104 | */ 105 | 106 | struct HEAPBLOCKS { 107 | S2CINT count; /* # of blocks of memory allocated */ 108 | S2CINT minphypage; /* Pages spanned by this allocation */ 109 | S2CINT maxphypage; 110 | struct { 111 | VOIDP address; /* Address of the block */ 112 | S2CINT size; /* Size in bytes of the block */ 113 | } block[ 256 ]; 114 | }; 115 | 116 | extern struct HEAPBLOCKS sc_heapblocks; 117 | 118 | extern TSCP sc_ossystem( XAL1( TSCP ) ); 119 | 120 | extern TSCP sc_ossignal( XAL2( TSCP, TSCP ) ); 121 | 122 | extern void sc_collect_done(); 123 | 124 | extern void sc_stackoverflow(); 125 | 126 | extern void sc_timesliced(); 127 | 128 | extern void sc_pushstacktrace( XAL2( struct STACKTRACE *, char* ) ); 129 | 130 | extern TSCP sc_popstacktrace( XAL2( struct STACKTRACE *, TSCP ) ); 131 | 132 | extern void sc_cioinit(); 133 | 134 | extern TSCP sc_time_2dof_2dday_v; 135 | 136 | extern TSCP sc_time_2dof_2dday(); 137 | -------------------------------------------------------------------------------- /scrt/em2.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 2 | * All Rights Reserved 3 | 4 | * Permission is hereby granted, free of charge, to any person obtaining a 5 | * copy of this software and associated documentation files (the "Software"), 6 | * to deal in the Software without restriction, including without limitation 7 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | * and/or sell copies of the Software, and to permit persons to whom the 9 | * Software is furnished to do so, subject to the following conditions: 10 | * 11 | * The above copyright notice and this permission notice shall be included in 12 | * all copies or substantial portions of the Software. 13 | * 14 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 20 | * DEALINGS IN THE SOFTWARE. 21 | */ 22 | 23 | #include "options.h" 24 | 25 | #include 26 | #if MAC_CLASSIC 27 | #include 28 | #endif 29 | 30 | char line[ 200 ], 31 | *result, 32 | *error; 33 | int status, s; 34 | 35 | void ev0() 36 | { 37 | scheme2c( line, &status, &result, &error ); 38 | } 39 | 40 | void ev1() 41 | { 42 | int buffer[ 500 ], i; 43 | for (i = 0; i < 500; i++) buffer[ i ] = i; 44 | scheme2c( line, &status, &result, &error ); 45 | for (i = 0; i < 500; i++) 46 | if (buffer[ i ] != i) abort(); 47 | } 48 | 49 | void ev2() 50 | { 51 | int buffer[ 1000 ], i; 52 | for (i = 0; i < 1000; i++) buffer[ i ] = i; 53 | scheme2c( line, &status, &result, &error ); 54 | for (i = 0; i < 1000; i++) 55 | if (buffer[ i ] != i) abort(); 56 | } 57 | 58 | void ev3() 59 | { 60 | int buffer[ 700 ], i; 61 | for (i = 0; i < 700; i++) buffer[ i ] = i; 62 | scheme2c( line, &status, &result, &error ); 63 | for (i = 0; i < 700; i++) 64 | if (buffer[ i ] != i) abort(); 65 | } 66 | 67 | 68 | main() 69 | { 70 | S2CINT *sp; 71 | 72 | #if MAC_CLASSIC 73 | STACKPTR( sp ); 74 | SetApplLimit( (char*)sp-57000 ); 75 | console_options.nrows = 30; 76 | console_options.title = "\pScheme->C"; 77 | #endif 78 | printf( "Embedded Scheme->C Test Bed\n0- " ); 79 | scheme2c( "(begin (set-stack-size! 57000) (set-time-slice! 100000))", 80 | &status, &result, &error ); 81 | if (status != 0) { 82 | printf( "Initialization failed!\n" ); 83 | exit( 1 ); 84 | } 85 | while (gets( line ) != NULL) { 86 | switch (s) { 87 | case 0: 88 | ev0(); 89 | break; 90 | case 1: 91 | ev1(); 92 | break; 93 | case 2: 94 | ev2(); 95 | break; 96 | case 3: 97 | ev3(); 98 | break; 99 | } 100 | s = (s + 1) & 3; 101 | if (*result != 0) printf( "%s\n", result ); 102 | if (*error != 0) printf( "%s", error ); 103 | printf( "%d- ", status ); 104 | fflush( stdout ); 105 | } 106 | printf( "\n" ); 107 | exit( 0 ); 108 | } 109 | -------------------------------------------------------------------------------- /scrt/embedded.c: -------------------------------------------------------------------------------- 1 | /* This file is the "main" program for an embedded SCHEME->C interpreter. 2 | */ 3 | 4 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 5 | * All Rights Reserved 6 | 7 | * Permission is hereby granted, free of charge, to any person obtaining a 8 | * copy of this software and associated documentation files (the "Software"), 9 | * to deal in the Software without restriction, including without limitation 10 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 11 | * and/or sell copies of the Software, and to permit persons to whom the 12 | * Software is furnished to do so, subject to the following conditions: 13 | * 14 | * The above copyright notice and this permission notice shall be included in 15 | * all copies or substantial portions of the Software. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 22 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | * DEALINGS IN THE SOFTWARE. 24 | */ 25 | 26 | #include "options.h" 27 | 28 | #ifdef DYNAMIC 29 | #include 30 | #include 31 | 32 | main() 33 | { 34 | char line[ 200 ], 35 | FAR *result, 36 | FAR *error; 37 | int status; 38 | HINSTANCE s2clib; 39 | void (FAR *scheme2c)( char FAR *line, int FAR *status, 40 | char FAR **result, char FAR **error ); 41 | 42 | s2clib = LoadLibrary( "scheme2c.dll" ); 43 | if (s2clib <= 21) { 44 | printf( "LoadLibrary error = %d\n", s2clib ); 45 | exit( 1 ); 46 | } 47 | (FARPROC)scheme2c = GetProcAddress( s2clib, "_scheme2c" ); 48 | 49 | printf( "Embedded Scheme->C Test Bed\n0- " ); 50 | (*scheme2c)( "(begin (set-stack-size! 50000) (set-time-slice! 100000))", 51 | &status, &result, &error ); 52 | if (status != 0) { 53 | printf( "Initialization failed!\n" ); 54 | FreeLibrary( s2clib ); 55 | exit( 1 ); 56 | } 57 | 58 | while (gets( line ) != NULL && line[0] != 0) { 59 | (*scheme2c)( &line[0], &status, &result, &error ); 60 | if (*result != 0) printf( "%s\n", result ); 61 | if (*error != 0) printf( "%s", error ); 62 | printf( "%d- ", status ); 63 | } 64 | printf( "\n" ); 65 | FreeLibrary( s2clib ); 66 | exit( 0 ); 67 | } 68 | 69 | #else 70 | 71 | #include 72 | #if MAC_CLASSIC 73 | #include 74 | #endif 75 | 76 | main() 77 | { 78 | char line[ 200 ], 79 | *result, 80 | *error; 81 | int status; 82 | S2CINT *sp; 83 | 84 | #if MAC_CLASSIC 85 | STACKPTR( sp ); 86 | SetApplLimit( (char*)sp-57000 ); 87 | console_options.nrows = 30; 88 | console_options.title = "\pScheme->C"; 89 | #endif 90 | printf( "Embedded Scheme->C Test Bed\n0- " ); 91 | scheme2c( "(begin (set-stack-size! 57000) (set-time-slice! 100000))", 92 | &status, &result, &error ); 93 | if (status != 0) { 94 | printf( "Initialization failed!\n" ); 95 | exit( 1 ); 96 | } 97 | while (gets( line ) != NULL) { 98 | scheme2c( line, &status, &result, &error ); 99 | if (*result != 0) printf( "%s\n", result ); 100 | if (*error != 0) printf( "%s", error ); 101 | printf( "%d- ", status ); 102 | fflush( stdout ); 103 | } 104 | printf( "\n" ); 105 | exit( 0 ); 106 | } 107 | 108 | #endif 109 | -------------------------------------------------------------------------------- /scrt/repdef.sc: -------------------------------------------------------------------------------- 1 | ;;; Scheme->C 2 | ;;; 3 | ;;; This file contains external definitions for use in compiling the 4 | ;;; the interpreter. 5 | 6 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 7 | ;* All Rights Reserved 8 | 9 | ;* Permission is hereby granted, free of charge, to any person obtaining a 10 | ;* copy of this software and associated documentation files (the "Software"), 11 | ;* to deal in the Software without restriction, including without limitation 12 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 13 | ;* and/or sell copies of the Software, and to permit persons to whom the 14 | ;* Software is furnished to do so, subject to the following conditions: 15 | ;* 16 | ;* The above copyright notice and this permission notice shall be included in 17 | ;* all copies or substantial portions of the Software. 18 | ;* 19 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 24 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 25 | ;* DEALINGS IN THE SOFTWARE. 26 | 27 | 28 | (define-external *DEBUG-ON-ERROR* scdebug) 29 | 30 | (define-external *READING-STDIN* screp) 31 | 32 | (define-external *RESULT* scdebug) 33 | 34 | (define-external (ABORT) sc) 35 | 36 | (define-external (BACKTRACE-ERROR-HANDLER id format-string . args) scdebug) 37 | 38 | (define-external (CHARREADY file) sc) 39 | 40 | (define-external (CLEANUP-UNREFERENCED) scrt4) 41 | 42 | (define-external (COND-MACRO exp) scexpnd1) 43 | 44 | (define-external CURRENT-INPUT-PORT-VALUE scrt5) 45 | 46 | (define-external CURRENT-OUTPUT-PORT-VALUE scrt5) 47 | 48 | (define-external (DOBACKTRACE start stop lines port) scdebug) 49 | 50 | (define-external (EXPAND x) scexpand) 51 | 52 | (define-external (FCLOSE file) sc) 53 | 54 | (define-external (FFLUSH file) sc) 55 | 56 | (define-external (FGETC file) sc) 57 | 58 | (define-external (FILENO file) sc) 59 | 60 | (define-external (FOPEN name access) sc) 61 | 62 | (define-external (FORMATNUMBER number type length) sc) 63 | 64 | (define-external (FPUTC character file) sc) 65 | 66 | (define-external (INPUTREADY mask) sc) 67 | 68 | (define-external (INSTALL-EXPANDER keyword function) scexpand) 69 | 70 | (define-external (ISLIST l min . max) scexpand) 71 | 72 | (define-external (JUMP-TO-SCHEME2C . x) screp) 73 | 74 | (define-external (LET-MACRO exp) scexpnd2) 75 | 76 | (define-external (ERROR-DISPLAY x) sc) 77 | 78 | (define-external (ON-INTERRUPT sig) scdebug) 79 | 80 | (define-external OPEN-FILE-PORTS scrt5) 81 | 82 | (define-external (OSEXIT code) sc) 83 | 84 | (define-external (OSSIGNAL signal handler) sc) 85 | 86 | (define-external (OSSYSTEM command) sc) 87 | 88 | (define-external PROCEED scdebug) 89 | 90 | (define-external (QUASIQUOTATION d exp) scqquote) 91 | 92 | (define-external (READ-DATUM port) scrt7) 93 | 94 | (define-external (READNUMBER string type) sc) 95 | 96 | (define-external (REMOVEFILE name) sc) 97 | 98 | (define-external (RENAME old-name new-name) sc) 99 | 100 | (define-external (SCHEME-MODE) sc) 101 | 102 | (define-external (SET-SCHEME-MODE! mode) sc) 103 | 104 | (define-external SYSTEM-FILE-MASK scrt6) 105 | 106 | (define-constant SIG_IGN 1) 107 | 108 | (define-constant SIGINT 2) 109 | 110 | ;;; Return the current value of sc_stacktrace. It is not defined as a C 111 | ;;; external as the compiler emitted extern might conflict with the one 112 | ;;; in objects.h. 113 | 114 | (define-in-line (STACKTRACE) ((lap () (S2CUINT_TSCP "sc_stacktrace")))) 115 | 116 | (define-external STDIN sc) 117 | 118 | (define-external STDOUT sc) 119 | 120 | (define-external STDERR sc) 121 | 122 | (define-external (TMPNAM) sc) 123 | 124 | (define-external TRACE-LEVEL scdebug) 125 | 126 | (define-external UNDEFINED "sc" "undefined") 127 | 128 | (define-external (VALID-SCHEME-POINTER? x) "" "sc_schemepointer") 129 | 130 | (define-external WHENFREED "sc" "whenfreed") 131 | 132 | (define-external (WRITE/DISPLAY obj readable port) scrt7) 133 | -------------------------------------------------------------------------------- /scrt/scexpand.sc: -------------------------------------------------------------------------------- 1 | ;;; Macro expansion is done by this module. It is based upon the ideas in 2 | ;;; "Expansion-Passing Style: Beyond Conventional Macros", 1986 ACM Conference 3 | ;;; on Lisp and Functional Programming. 4 | 5 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 6 | ;* All Rights Reserved 7 | 8 | ;* Permission is hereby granted, free of charge, to any person obtaining a 9 | ;* copy of this software and associated documentation files (the "Software"), 10 | ;* to deal in the Software without restriction, including without limitation 11 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 12 | ;* and/or sell copies of the Software, and to permit persons to whom the 13 | ;* Software is furnished to do so, subject to the following conditions: 14 | ;* 15 | ;* The above copyright notice and this permission notice shall be included in 16 | ;* all copies or substantial portions of the Software. 17 | ;* 18 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 24 | ;* DEALINGS IN THE SOFTWARE. 25 | 26 | 27 | (module scexpand) 28 | 29 | (include "repdef.sc") 30 | 31 | (define (EXPAND x) (initial-expander x initial-expander)) 32 | 33 | (define (INITIAL-EXPANDER x e) 34 | (let ((e1 (cond ((symbol? x) *identifier-expander*) 35 | ((not (pair? x)) (lambda (x e) x)) 36 | ((procedure? (expander? (car x))) (expander (car x))) 37 | (else *application-expander*)))) 38 | (e1 x e))) 39 | 40 | (define (EXPAND-ONCE x) (initial-expander x (lambda (x e) x))) 41 | 42 | (define (*IDENTIFIER-EXPANDER* x e) 43 | (let ((constant (expander x))) 44 | (if (pair? constant) (car constant) x))) 45 | 46 | (define (*APPLICATION-EXPANDER* x e) (map (lambda (x) (e x e)) x)) 47 | 48 | (define (INSTALL-EXPANDER keyword function) 49 | (putprop keyword '*expander* function) 50 | keyword) 51 | 52 | (define (EXPANDER? x) 53 | (and (symbol? x) (getprop x '*expander*))) 54 | 55 | (define (EXPANDER x) 56 | (getprop x '*expander*)) 57 | 58 | ;;; The following function tests an expression to verify that it is a list 59 | ;;; of a certain minimum length. Optionally a maximum length will also be 60 | ;;; checked. 61 | 62 | (define (ISLIST l min . max) 63 | (do ((len 0 (+ len 1)) 64 | (l l (cdr l))) 65 | ((not (pair? l)) 66 | (and (null? l) (>= len min) (or (null? max) (<= len (car max))))))) 67 | -------------------------------------------------------------------------------- /scrt/sci.c: -------------------------------------------------------------------------------- 1 | 2 | /* SCHEME->C */ 3 | 4 | #include 5 | 6 | int main(); 7 | 8 | static void init_constants() 9 | { 10 | } 11 | 12 | DEFTSCP( scint_start_2drep_v ); 13 | DEFCSTRING( t2003, "SCINT_START-REP" ); 14 | EXTERNTSCPP( sc_apply_2dtwo, XAL2( TSCP, TSCP ) ); 15 | EXTERNTSCP( sc_apply_2dtwo_v ); 16 | EXTERNTSCPP( screp_read_2deval_2dprint, XAL1( TSCP ) ); 17 | EXTERNTSCP( screp_read_2deval_2dprint_v ); 18 | 19 | TSCP scint_start_2drep( c2002 ) 20 | TSCP c2002; 21 | { 22 | PUSHSTACKTRACE( t2003 ); 23 | POPSTACKTRACE( sc_apply_2dtwo( screp_read_2deval_2dprint_v, 24 | c2002 ) ); 25 | } 26 | 27 | void scint__init(){} 28 | void screp__init(); 29 | 30 | static void init_modules( compiler_version ) 31 | char *compiler_version; 32 | { 33 | screp__init(); 34 | MAXDISPLAY( 0 ); 35 | } 36 | 37 | int main( int argc, char **argv ) 38 | { 39 | static int init = 0; 40 | if (init) return 1; 41 | init = 1; 42 | INITHEAP( 0, argc, argv, scint_start_2drep ); 43 | init_constants(); 44 | init_modules( "(scint SCHEME->C COMPILER 15mar93jfb)" ); 45 | sc_segv__handlers(); 46 | INITIALIZEVAR( t2003, 47 | ADR( scint_start_2drep_v ), 48 | MAKEPROCEDURE( 1, 49 | 0, 50 | scint_start_2drep, EMPTYLIST ) ); 51 | scint_start_2drep( CLARGUMENTS( argc, argv ) ); 52 | SCHEMEEXIT(); 53 | return 0; 54 | } 55 | -------------------------------------------------------------------------------- /scrt/sci.sc: -------------------------------------------------------------------------------- 1 | ;;; This file is the "main" program for the SCHEME->C interpreter. 2 | 3 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | ;* All Rights Reserved 5 | 6 | ;* Permission is hereby granted, free of charge, to any person obtaining a 7 | ;* copy of this software and associated documentation files (the "Software"), 8 | ;* to deal in the Software without restriction, including without limitation 9 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | ;* and/or sell copies of the Software, and to permit persons to whom the 11 | ;* Software is furnished to do so, subject to the following conditions: 12 | ;* 13 | ;* The above copyright notice and this permission notice shall be included in 14 | ;* all copies or substantial portions of the Software. 15 | ;* 16 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | ;* DEALINGS IN THE SOFTWARE. 23 | 24 | (module scint (main start-rep) (top-level)) 25 | 26 | ;;; The following function can be invoked by a "main" program to start a 27 | ;;; Scheme interpreter. 28 | ;;; 29 | ;;; The command line flags recognized are: 30 | ;;; 31 | ;;; -e echo input on the output file 32 | ;;; -nh don't print the header 33 | ;;; -np don't print the prompt 34 | ;;; -q don't print the result 35 | ;;; 36 | ;;; All other command-line arguments are ignored. 37 | 38 | (define (START-REP command-line) 39 | (apply read-eval-print command-line)) 40 | -------------------------------------------------------------------------------- /scrt/scinit.h: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | * All Rights Reserved 5 | 6 | * Permission is hereby granted, free of charge, to any person obtaining a 7 | * copy of this software and associated documentation files (the "Software"), 8 | * to deal in the Software without restriction, including without limitation 9 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | * and/or sell copies of the Software, and to permit persons to whom the 11 | * Software is furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | * DEALINGS IN THE SOFTWARE. 23 | */ 24 | 25 | /* This module defines some basic global objects and initializes those parts 26 | of the SCHEME->C runtime system which are written in C. Included in 27 | this initialization is the construction of the heap and the optional loading 28 | of the heap from a file. For compatibility with other modules, the routines 29 | and Scheme globals provided by these routines appear as members of the 30 | module "sc". 31 | */ 32 | 33 | extern S2CINT sc_timeslice, /* Counter for time slicing. */ 34 | sc_timesliceinit; 35 | 36 | extern char *sc_topofstack, /* Top-of-stack limit. */ 37 | *sc_savetopofstack; /* Save limit on overflow. */ 38 | 39 | extern S2CINT sc_stackbytes; /* # of bytes of stack allocated */ 40 | 41 | /* Procedural interfaces in this module: */ 42 | 43 | extern S2CINT sc_expandheap(); 44 | 45 | extern void sc__init(); 46 | 47 | #ifdef __GNUC__ 48 | extern void sc_error( XAL3( char*, char*, TSCP ) ) __attribute__((noreturn)); 49 | #else 50 | extern void sc_error( XAL3( char*, char*, TSCP ) ); 51 | #endif 52 | 53 | extern TSCP sc_implementation_v; 54 | 55 | extern TSCP sc_implementation(); 56 | 57 | extern void scheme2c( XAL4( char *, int *, char **, char ** ) ); 58 | 59 | #define LIST1( x ) CONS( x, EMPTYLIST ) 60 | #define LIST2( x, y ) CONS( x, CONS( y, EMPTYLIST ) ) 61 | -------------------------------------------------------------------------------- /scrt/scqquote.sc: -------------------------------------------------------------------------------- 1 | ;;; The functions in this module implement QUASIQUOTE as defined in section 2 | ;;; 7.1.4 of Revised**4. 3 | 4 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 5 | ;* All Rights Reserved 6 | 7 | ;* Permission is hereby granted, free of charge, to any person obtaining a 8 | ;* copy of this software and associated documentation files (the "Software"), 9 | ;* to deal in the Software without restriction, including without limitation 10 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 11 | ;* and/or sell copies of the Software, and to permit persons to whom the 12 | ;* Software is furnished to do so, subject to the following conditions: 13 | ;* 14 | ;* The above copyright notice and this permission notice shall be included in 15 | ;* all copies or substantial portions of the Software. 16 | ;* 17 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 22 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;* DEALINGS IN THE SOFTWARE. 24 | 25 | (module scqquote (top-level QUASIQUOTATION)) 26 | 27 | (include "repdef.sc") 28 | 29 | (define (QUASIQUOTATION d exp) 30 | (if (islist exp 2 2) 31 | (template d (cadr exp)) 32 | (error 'quasiquote "Illegal form: ~s" exp))) 33 | 34 | (define (TEMPLATE d exp) 35 | (cond ((zero? d) 36 | exp) 37 | ((and (pair? exp) (eq? (car exp) 'unquote)) 38 | (if (islist exp 2 2) 39 | (if (eq? d 1) 40 | (template (- d 1) (cadr exp)) 41 | (list 'list ''unquote (template (- d 1) (cadr exp)))) 42 | (error 'unquote "Illegal form: ~s" (cadr exp)))) 43 | ((vector? exp) 44 | (vector-template d exp)) 45 | ((pair? exp) 46 | (list-template d exp)) 47 | ((or (char? exp) (number? exp) (string? exp)) 48 | exp) 49 | (else 50 | (list 'quote exp)))) 51 | 52 | (define (LIST-TEMPLATE d exp) 53 | (cond ((and (islist exp 2 2) (eq? (car exp) 'quote) (pair? (cadr exp)) 54 | (eq? (caadr exp) 'quasiquote)) 55 | (quasiquotation d (cadr exp))) 56 | ((eq? (car exp) 'quasiquote) 57 | (if (eq? d 0) 58 | (quasiquotation (+ d 1) exp) 59 | (list 'list ''quasiquote (quasiquotation (+ d 1) exp)))) 60 | (else (cons 'cons* (template-or-splice-list d exp))))) 61 | 62 | (define (VECTOR-TEMPLATE d exp) 63 | (list 'list->vector 64 | (cons 'cons* (template-or-splice-list d (vector->list exp))))) 65 | 66 | (define (TEMPLATE-OR-SPLICE-LIST d exp) 67 | (cond ((null? exp) '('())) 68 | ((pair? exp) 69 | (cond ((eq? (car exp) 'unquote) 70 | (list (template d exp))) 71 | ((and (pair? (car exp)) (eq? (caar exp) 'unquote-splicing)) 72 | (list (list 'append 73 | (template-or-splice d (car exp)) 74 | (cons 'cons* 75 | (template-or-splice-list d (cdr exp)))))) 76 | (else (cons (template-or-splice d (car exp)) 77 | (template-or-splice-list d (cdr exp)))))) 78 | (else (list (template-or-splice d exp))))) 79 | 80 | (define (TEMPLATE-OR-SPLICE d exp) 81 | (if (and (pair? exp) (eq? (car exp) 'unquote-splicing)) 82 | (if (islist exp 2 2) 83 | (if (eq? d 1) 84 | (template (- d 1) (cadr exp)) 85 | (list 'list (list 'list ''unquote-splicing 86 | (template (- d 1) (cadr exp))))) 87 | (error 'unquote-splicing "Illegal form: ~s" exp)) 88 | (template d exp))) 89 | 90 | (install-expander 'QUASIQUOTE (lambda (x e) (e (quasiquotation 1 x) e))) 91 | -------------------------------------------------------------------------------- /scrt/scrtuser.c: -------------------------------------------------------------------------------- 1 | 2 | /* SCHEME->C */ 3 | 4 | #include 5 | 6 | void scrtuser__init(); 7 | 8 | static void init_constants() 9 | { 10 | } 11 | 12 | static void init_modules( compiler_version ) 13 | char *compiler_version; 14 | { 15 | MAXDISPLAY( 0 ); 16 | } 17 | 18 | void scrtuser__init() 19 | { 20 | static int init = 0; 21 | if (init) return; 22 | init = 1; 23 | INITHEAP( 0, 0, 0, 0 ); 24 | init_constants(); 25 | init_modules( "(scrtuser SCHEME->C COMPILER 15mar93jfb)" ); 26 | sc_segv__handlers(); 27 | return; 28 | } 29 | -------------------------------------------------------------------------------- /scrt/scrtuser.sc: -------------------------------------------------------------------------------- 1 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 2 | ;* All Rights Reserved 3 | 4 | ;* Permission is hereby granted, free of charge, to any person obtaining a 5 | ;* copy of this software and associated documentation files (the "Software"), 6 | ;* to deal in the Software without restriction, including without limitation 7 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | ;* and/or sell copies of the Software, and to permit persons to whom the 9 | ;* Software is furnished to do so, subject to the following conditions: 10 | ;* 11 | ;* The above copyright notice and this permission notice shall be included in 12 | ;* all copies or substantial portions of the Software. 13 | ;* 14 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 20 | ;* DEALINGS IN THE SOFTWARE. 21 | 22 | ;;; To extend the basic Scheme->C runtime system, replace this module with 23 | ;;; one also named scrtuser, whose MODULE form includes a WITH clause that 24 | ;;; lists all user modules in the order that they must be initialized. 25 | ;;; 26 | ;;; N.B. Modules that are implicity referenced because of a DEFINE-EXTERNAL 27 | ;;; declaration need not be listed. Those modules are automatically 28 | ;;; initialized. 29 | 30 | (module scrtuser) 31 | -------------------------------------------------------------------------------- /scsc/README: -------------------------------------------------------------------------------- 1 | Source directory for Scheme->C compiler for all implementations. 2 | -------------------------------------------------------------------------------- /scsc/expform.sch: -------------------------------------------------------------------------------- 1 | ;;; External and in-line declarations from expform.sc 2 | 3 | (define-in-line (ID-PRINTNAME id) (get id 'printname)) 4 | 5 | (define-in-line (SET-ID-PRINTNAME! id name) (put id 'printname name)) 6 | 7 | (define-in-line (ID-VNAME id) (get id 'vname)) 8 | 9 | (define-in-line (SET-ID-VNAME! id name) (put id 'vname name)) 10 | 11 | (define-in-line (ID-CNAME id) (get id 'cname)) 12 | 13 | (define-in-line (SET-ID-CNAME! id name) (put id 'cname name)) 14 | 15 | (define-in-line (ID-MODULE id) (get id 'module)) 16 | 17 | (define-in-line (SET-ID-MODULE! id name) (put id 'module name)) 18 | 19 | (define-in-line (ID-USE id) (get id 'use)) 20 | 21 | (define-in-line (SET-ID-USE! id tag) (put id 'use tag)) 22 | 23 | (define-in-line (ID-TYPE id) (get id 'type)) 24 | 25 | (define-in-line (SET-ID-TYPE! id tag) (put id 'type tag)) 26 | 27 | (define-in-line (ID-HEAP id) (get id 'heap)) 28 | 29 | (define-in-line (SET-ID-HEAP! id flag) (put id 'heap flag)) 30 | 31 | (define-in-line (ID-DISPLAY id) (get id 'display)) 32 | 33 | (define-in-line (SET-ID-DISPLAY! id flag) (put id 'display flag)) 34 | 35 | (define-in-line (ID-BOUNDID id) (get id 'boundid)) 36 | 37 | (define-in-line (SET-ID-BOUNDID id value) (put id 'boundid value)) 38 | 39 | (define-in-line (ID-LAMBDA id) (get id 'lambda)) 40 | 41 | (define-in-line (SET-ID-LAMBDA! id lambda-id) (put id 'lambda lambda-id)) 42 | 43 | (define-in-line (ID-EXTERNAL id) (get id 'external)) 44 | 45 | (define-in-line (SET-ID-EXTERNAL! id flag) (put id 'external flag)) 46 | 47 | (define-in-line (ID-DEFINED id) (get id 'defined)) 48 | 49 | (define-in-line (SET-ID-DEFINED! id flag) (put id 'defined flag)) 50 | 51 | (define-in-line (ID-VALUE id) (get id 'value)) 52 | 53 | (define-in-line (SET-ID-VALUE! id x) (put id 'value x)) 54 | 55 | (define-in-line (ID-SET! id) (get id 'set!)) 56 | 57 | (define-in-line (SET-ID-SET!! id flag) (put id 'set! flag)) 58 | 59 | (define-in-line (ID-REFS id) (get id 'refs)) 60 | 61 | (define-in-line (SET-ID-REFS! id cnt) (put id 'refs cnt)) 62 | 63 | (define-in-line (ID-CALLS id) (get id 'calls)) 64 | 65 | (define-in-line (SET-ID-CALLS! id cnt) (put id 'calls cnt)) 66 | 67 | (define-in-line (ID-ALIAS id) (get id 'alias)) 68 | 69 | (define-in-line (SET-ID-ALIAS! id label) (put id 'alias label)) 70 | 71 | (define-in-line (ID-GOTOS id) (get id 'gotos)) 72 | 73 | (define-in-line (SET-ID-GOTOS! id cnt) (put id 'gotos cnt)) 74 | 75 | (define-in-line (ID-UNDEFREF id) (get id 'undefref)) 76 | 77 | (define-in-line (SET-ID-UNDEFREF! id var) (put id 'undefref var)) 78 | 79 | (define-in-line (ID-GLOBAL id) (get id 'global)) 80 | 81 | (define-in-line (SET-ID-GLOBAL! id alpha) (put id 'global alpha)) 82 | 83 | (define-external (VNAME exp) expform) 84 | 85 | (define-external (CNAME exp) expform) 86 | 87 | (define-external (LCHEXNAME exp) expform) 88 | 89 | (define-external (NEWV var . pl) expform) 90 | 91 | (define-external (BOUND var) expform) 92 | -------------------------------------------------------------------------------- /scsc/gencode.sch: -------------------------------------------------------------------------------- 1 | ;;; External definitions for gencode.sc 2 | 3 | (define-external CURRENT-CODE-LAMBDA gencode) 4 | 5 | (define-external INIT-MODULES gencode) 6 | 7 | (define-external FREE-DISPLAY gencode) 8 | 9 | (define-external MAX-DISPLAY gencode) 10 | 11 | (define-external EMPTY-CONDITION-INFO gencode) 12 | 13 | (define-external GLOBAL-CONDITION-INFO gencode) 14 | 15 | (define-external ERROR-ID gencode) 16 | 17 | (define-external $_CAR-ERROR-ID gencode) 18 | 19 | (define-external $_CDR-ERROR-ID gencode) 20 | 21 | (define-external (EXP-GENC loc exp bindings) gencode) 22 | 23 | (define-external (MAKE-LABEL) gencode) 24 | 25 | (define-external (CODE-LABEL id) gencode) 26 | 27 | (define-external (MAKE-C-GLOBAL) gencode) 28 | 29 | (define-external (OPTIONAL-ARGS id) gencode) 30 | 31 | (define-external (LOOKUP var bindings) gencode) 32 | 33 | (define-external (VAR-IN-STACK var) gencode) 34 | 35 | (define-external (VAR-IS-GLOBAL var) gencode) 36 | 37 | (define-external (EMIT-EXTERN var) gencode) 38 | 39 | (define-external (VAR-IS-CONSTANT var) gencode) 40 | 41 | (define-external (VAR-IS-TOP-LEVEL var) gencode) 42 | -------------------------------------------------------------------------------- /scsc/lambdaexp.sch: -------------------------------------------------------------------------------- 1 | ;;; External and in-line definitions for lambdaexp.sc 2 | 3 | (define-in-line ($LAMBDA? x) (and (pair? x) (eq? (car x) '$lambda))) 4 | 5 | (define-in-line ($LAMBDA-ID x) (and ($lambda? x) (cadr x))) 6 | 7 | (define-in-line ($LAMBDA-BODY x) (and ($lambda? x) (cddr x))) 8 | 9 | (define-in-line (SET-$LAMBDA-BODY! x body) (set-cdr! (cdr x) body)) 10 | 11 | (define-in-line (LAMBDA-REQVARS id) (get id 'reqvars)) 12 | 13 | (define-in-line (SET-LAMBDA-REQVARS! id vars) (put id 'reqvars vars)) 14 | 15 | (define-in-line (LAMBDA-OPTVARS id) (get id 'optvars)) 16 | 17 | (define-in-line (SET-LAMBDA-OPTVARS! id vars) (put id 'optvars vars)) 18 | 19 | (define-in-line (LAMBDA-LEXICAL id) (get id 'lexical)) 20 | 21 | (define-in-line (SET-LAMBDA-LEXICAL! id lexvars) (put id 'lexical lexvars)) 22 | 23 | (define-in-line (LAMBDA-CALLS id) (get id 'calls)) 24 | 25 | (define-in-line (SET-LAMBDA-CALLS! id x) (put id 'calls x)) 26 | 27 | (define-in-line (LAMBDA-GENERATE id) (get id 'generate)) 28 | 29 | (define-in-line (SET-LAMBDA-GENERATE! id x) (put id 'generate x)) 30 | 31 | (define-in-line (LAMBDA-CLOSED id) (get id 'closed)) 32 | 33 | (define-in-line (SET-LAMBDA-CLOSED! id x) (put id 'closed x)) 34 | 35 | (define-in-line (LAMBDA-DISPLAY-CLOSEP id) (get id 'display-closep)) 36 | 37 | (define-in-line (SET-LAMBDA-DISPLAY-CLOSEP! id x) (put id 'display-closep x)) 38 | 39 | (define-in-line (LAMBDA-NESTIN id) (get id 'nestin)) 40 | 41 | (define-in-line (SET-LAMBDA-NESTIN! id nestin) (put id 'nestin nestin)) 42 | 43 | (define-in-line (LAMBDA-EXITS id) (get id 'exits)) 44 | 45 | (define-in-line (SET-LAMBDA-EXITS! id exits) (put id 'exits exits)) 46 | 47 | (define-in-line (LAMBDA-INLINE-TAILS id) (get id 'inline-tails)) 48 | 49 | (define-in-line (SET-LAMBDA-INLINE-TAILS! id tails) 50 | (put id 'inline-tails tails)) 51 | 52 | (define-in-line (LAMBDA-STR-CALLS id) (get id 'str-calls)) 53 | 54 | (define-in-line (SET-LAMBDA-STR-CALLS! id x) (put id 'str-calls x)) 55 | 56 | (define-in-line (LAMBDA-TAIL-CALLS id) (get id 'tail-calls)) 57 | 58 | (define-in-line (SET-LAMBDA-TAIL-CALLS! id x) (put id 'tail-calls x)) 59 | 60 | (define-in-line (LAMBDA-REAL-CALLS id) (get id 'real-calls)) 61 | 62 | (define-in-line (SET-LAMBDA-REAL-CALLS! id x) (put id 'real-calls x)) 63 | 64 | (define-in-line (LAMBDA-CODE-LABEL id) (get id 'code-label)) 65 | 66 | (define-in-line (SET-LAMBDA-CODE-LABEL! id x) (put id 'code-label x)) 67 | 68 | (define-in-line (LAMBDA-$LAMBDA id) (get id '$lambda)) 69 | 70 | (define-in-line (SET-LAMBDA-$LAMBDA! id exp) (put id '$lambda exp)) 71 | 72 | (define-in-line (LAMBDA-NAME id) (get id 'name)) 73 | 74 | (define-in-line (SET-LAMBDA-NAME! id x) (put id 'name x)) 75 | -------------------------------------------------------------------------------- /scsc/lap.sch: -------------------------------------------------------------------------------- 1 | ;;; External functions from lap.sc 2 | 3 | (define-external (EMIT-GLOBAL-LAP code) lap) 4 | 5 | (define-external (EMIT-LAP code) lap) 6 | 7 | (define-external (SAVE-CURRENT-LAP lap) lap) 8 | 9 | (define-external (USE-LAP-TEMP) lap) 10 | 11 | (define-external (DROP-LAP-TEMP temp) lap) 12 | 13 | (define-external (SAVE-LAP-TEMPS) lap) 14 | 15 | (define-external (RESTORE-LAP-TEMPS state) lap) 16 | 17 | (define-external (DONE-LAP lap) lap) 18 | -------------------------------------------------------------------------------- /scsc/makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Build the SCHEME->C compiler. 3 | # 4 | 5 | # Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 6 | # All Rights Reserved 7 | 8 | # Permission is hereby granted, free of charge, to any person obtaining a 9 | # copy of this software and associated documentation files (the "Software"), 10 | # to deal in the Software without restriction, including without limitation 11 | # the rights to use, copy, modify, merge, publish, distribute, sublicense, 12 | # and/or sell copies of the Software, and to permit persons to whom the 13 | # Software is furnished to do so, subject to the following conditions: 14 | # 15 | # The above copyright notice and this permission notice shall be included in 16 | # all copies or substantial portions of the Software. 17 | # 18 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 24 | # DEALINGS IN THE SOFTWARE. 25 | # 26 | 27 | all: 28 | 29 | prefix=/usr/local 30 | LIBDIR=${prefix}/lib 31 | BINDIR=${prefix}/bin 32 | ## previously value was LIBSUBDIR = schemetoc 33 | LIBSUBDIR = scheme2c 34 | 35 | INSTALL = install 36 | INSTALL_DATA = ${INSTALL} -m 644 37 | INSTALL_PROGRAM = ${INSTALL} 38 | INSTALL_SCRIPT = ${INSTALL} 39 | 40 | 41 | .SUFFIXES: 42 | .SUFFIXES: .o .c .sc .s 43 | 44 | SCC = s2cc 45 | SCCFLAGS = 46 | 47 | SRCDIR = ../../scsc 48 | RTDIR = ../scrt 49 | RT = ${RTDIR}/libs2c.a 50 | 51 | # Defaults for configuring s2cc and Xs2cc commands. 52 | 53 | SCL = 80 54 | SCMH = 40 55 | 56 | scsc = main.sc closeana.sc lambdaexp.sc plist.sc transform.sc expform.sc \ 57 | readtext.sc miscexp.sc macros.sc compile.sc lap.sc gencode.sc \ 58 | callcode.sc lambdacode.sc misccode.sc 59 | 60 | scc = main.c closeana.c lambdaexp.c plist.c transform.c expform.c \ 61 | readtext.c miscexp.c macros.c compile.c lap.c gencode.c \ 62 | callcode.c lambdacode.c misccode.c 63 | 64 | sco = main.o closeana.o lambdaexp.o plist.o transform.o expform.o \ 65 | readtext.o miscexp.o macros.o compile.o lap.o gencode.o \ 66 | callcode.o lambdacode.o misccode.o 67 | 68 | scsch = expform.sch gencode.sch lambdaexp.sch lap.sch miscexp.sch plist.sch 69 | 70 | .SUFFIXES: 71 | .SUFFIXES: .o .sc .c 72 | 73 | .sc.c: 74 | ${SCC} -C $*.sc 75 | 76 | .c.o: 77 | ${CC} -c ${CFLAGS} -I${RTDIR} $*.c 78 | 79 | sc-to-c: ${scc} 80 | 81 | Xs2ccomp: ${scc} ${sco} ${RT} 82 | ${CC} -o Xs2ccomp ${CFLAGS} ${sco} ${RT} -lm ${LDFLAGS} 83 | 84 | s2ccomp: Xs2ccomp 85 | cp -pR Xs2ccomp s2ccomp 86 | 87 | port: 88 | $(MAKE) "CC=${CC}" "CFLAGS=${CFLAGS}" "SCC=echo" Xs2ccomp s2ccomp 89 | 90 | s2cc: 91 | echo '#! /bin/sh' > $@ 92 | echo ${LIBDIR}/${LIBSUBDIR}/s2ccomp -scl ${SCL} -scmh ${SCMH} \ 93 | -cc ${CC} -LIBDIR ${LIBDIR}/${LIBSUBDIR} '$$*' >> $@ 94 | chmod +x $@ 95 | 96 | Xs2cc: 97 | echo '#! /bin/sh' > $@ 98 | echo $$(pwd)/s2ccomp -scl ${SCL} -scmh ${SCMH} \ 99 | -cc ${CC} -LIBDIR $$(pwd)/${RTDIR} '$$*' >> $@ 100 | chmod +x $@ 101 | 102 | all: s2cc s2ccomp 103 | 104 | install: s2cc # s2ccomp 105 | ${INSTALL} -d ${DESTDIR}${BINDIR} 106 | ${INSTALL_SCRIPT} s2cc ${DESTDIR}${BINDIR}/ 107 | ln -sf s2cc ${DESTDIR}${BINDIR}/scc 108 | ${INSTALL} -d ${DESTDIR}${LIBDIR}/${LIBSUBDIR} 109 | ${INSTALL_PROGRAM} s2ccomp ${DESTDIR}${LIBDIR}/${LIBSUBDIR}/ 110 | 111 | clean: 112 | rm -f ${sco} *.BAK *.CKP scltext.* *.S2C 113 | 114 | clean-sc-to-c: 115 | rm -f ${scc} 116 | 117 | noprogs: 118 | rm -f s2ccomp Xs2ccomp 119 | 120 | srclinks: s2cc Xs2cc 121 | for x in ${scsc} ${scc} ${scsch}; \ 122 | do ln -s ${SRCDIR}/$$x $$x;\ 123 | done 124 | 125 | .PHONY: all clean port install sc-to-c srclinks noprogs clean-sc-to-c 126 | -------------------------------------------------------------------------------- /scsc/miscexp.sch: -------------------------------------------------------------------------------- 1 | ;;; External and in-line definitions for miscexp.sc 2 | 3 | (define-in-line ($CALL? x) (and (pair? x) (eq? (car x) '$call))) 4 | 5 | (define-in-line ($CALL-TAIL x) (and ($call? x) (cadr x))) 6 | 7 | (define-in-line (SET-$CALL-TAIL! x v) (set-car! (cdr x) v)) 8 | 9 | (define-in-line ($CALL-FUNC x) (and ($call? x) (caddr x))) 10 | 11 | (define-in-line (SET-$CALL-FUNC! x f) (set-car! (cddr x) f)) 12 | 13 | (define-in-line ($CALL-ARGL x) (and ($call? x) (cdddr x))) 14 | 15 | (define-in-line (SET-$CALL-ARGL! x al) (set-cdr! (cddr x) al)) 16 | 17 | (define-in-line ($LAP? x) (and (pair? x) (eq? (car x) '$lap))) 18 | 19 | (define-in-line ($LAP-TYPE x) (and ($lap? x) (cadr x))) 20 | 21 | (define-in-line ($LAP-VARS x) (and ($lap? x) (caddr x))) 22 | 23 | (define-in-line ($LAP-BODY x) (and ($lap? x) (cdddr x))) 24 | 25 | (define-in-line (SET-$LAP-BODY! exp body) (set-cdr! (cddr exp) body)) 26 | 27 | (define-in-line ($SET? x) (and (pair? x) (eq? (car x) '$set))) 28 | 29 | (define-in-line ($SET-ID x) (and ($set? x) (cadr x))) 30 | 31 | (define-in-line ($SET-EXP x) (and ($set? x) (caddr x))) 32 | 33 | (define-in-line (SET-$SET-EXP! x e) (set-car! (cddr x) e)) 34 | 35 | (define-in-line ($IF? x) (and (pair? x) (eq? (car x) '$if))) 36 | 37 | (define-in-line ($IF-TEST x) (and ($if? x) (cadr x))) 38 | 39 | (define-in-line (SET-$IF-TEST! x test) (set-car! (cdr x) test)) 40 | 41 | (define-in-line ($IF-TRUE x) (and ($if? x) (caddr x))) 42 | 43 | (define-in-line (SET-$IF-TRUE! x v) (set-car! (cddr x) v)) 44 | 45 | (define-in-line ($IF-FALSE x) (and ($if? x) (cadddr x))) 46 | 47 | (define-in-line (SET-$IF-FALSE! x v) (set-car! (cdddr x) v)) 48 | 49 | (define-in-line ($DEFINE? x) (and (pair? x) (eq? (car x) '$define))) 50 | 51 | (define-in-line ($DEFINE-ID x) (and ($define? x) (cadr x))) 52 | 53 | (define-in-line ($DEFINE-EXP x) (and ($define? x) (caddr x))) 54 | 55 | (define-in-line (SET-$DEFINE-EXP! x e) (set-car! (cddr x) e)) 56 | -------------------------------------------------------------------------------- /scsc/plist.sc: -------------------------------------------------------------------------------- 1 | ;;; The compilers "symbol table" is kept by recording an alist associated 2 | ;;; with each identifier under the key SCC. The function GET is used to 3 | ;;; access an item, and the function PUT is used to set an item. 4 | ;;; 5 | ;;; All property entries for all visible symbols (i.e. in *OBARRAY*) can be 6 | ;;; copied from one key to another by COPY-PLIST. This is used to save and 7 | ;;; restore initial values. 8 | ;;; 9 | 10 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 11 | ;* All Rights Reserved 12 | 13 | ;* Permission is hereby granted, free of charge, to any person obtaining a 14 | ;* copy of this software and associated documentation files (the "Software"), 15 | ;* to deal in the Software without restriction, including without limitation 16 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 17 | ;* and/or sell copies of the Software, and to permit persons to whom the 18 | ;* Software is furnished to do so, subject to the following conditions: 19 | ;* 20 | ;* The above copyright notice and this permission notice shall be included in 21 | ;* all copies or substantial portions of the Software. 22 | ;* 23 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 24 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 25 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 26 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 27 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 28 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 29 | ;* DEALINGS IN THE SOFTWARE. 30 | 31 | (module plist) 32 | 33 | (define (GET id key) 34 | (let ((pl (assq key (or (getprop id 'scc) '())))) 35 | (if pl (cdr pl) '()))) 36 | 37 | (define (PUT id key value) 38 | (let* ((pl (or (getprop id 'scc) '())) 39 | (oldvalue (assq key pl))) 40 | (if oldvalue 41 | (set-cdr! oldvalue value) 42 | (putprop id 'scc (cons (cons key value) pl))) 43 | value)) 44 | 45 | (define (COPY-PLIST src-key dest-key) 46 | (do ((i (- (vector-length *obarray*) 1) (- i 1))) 47 | ((= i -1)) 48 | (for-each 49 | (lambda (var) 50 | (putprop var dest-key 51 | (let loop ((val (getprop var src-key))) 52 | (if (pair? val) 53 | (cons (loop (car val)) 54 | (loop (cdr val))) 55 | val)))) 56 | (vector-ref *obarray* i)))) 57 | -------------------------------------------------------------------------------- /scsc/plist.sch: -------------------------------------------------------------------------------- 1 | ;;; External declarations from plist.sc 2 | 3 | (define-external (GET id key) plist) 4 | 5 | (define-external (PUT id key value) plist) 6 | -------------------------------------------------------------------------------- /test/README: -------------------------------------------------------------------------------- 1 | This directory contains test files for the compiler and run-time system. 2 | -------------------------------------------------------------------------------- /test/makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Scheme->C compiler and runtime tests. 3 | # 4 | 5 | SCC = ../scsc/Xs2cc 6 | SCCFLAGS = -g 7 | 8 | n = n must be defined 9 | 10 | SRCDIR = ../../test 11 | 12 | .SUFFIXES: 13 | .SUFFIXES: .sc .c .o 14 | 15 | batch-c = test01.c test02.c test03.c test04.c test05.c \ 16 | test06.c test07.c test08.c test09.c test10.c \ 17 | test11.c test12.c test13.c test14.c test15.c \ 18 | test16.c test17.c test18.c test19.c test20.c \ 19 | test21.c test22.c test23.c 20 | 21 | batch-o = test01.o test02.o test03.o test04.o test05.o \ 22 | test06.o test07.o test08.o test09.o test10.o \ 23 | test11.o test12.o test13.o test14.o test15.o \ 24 | test16.o test17.o test18.o test19.o test20.o \ 25 | test21.o test22.o test23.o 26 | 27 | progs = test test50 test51 test52 test53 test54 \ 28 | test01 test02 test03 test04 test05 \ 29 | test06 test07 test08 test09 test10 \ 30 | test11 test12 test13 test14 test15 \ 31 | test16 test17 test18 test19 test20 \ 32 | test21 test22 test23 33 | 34 | alltests= test.sc testchk.sc \ 35 | test01.sc test02.sc test03.sc test04.sc test05.sc \ 36 | test06.sc test07.sc test08.sc test09.sc test10.sc \ 37 | test11.sc test12.sc test13.sc test14.sc test15.sc \ 38 | test16.sc test17.sc test18.sc test19.sc test20.sc \ 39 | test21.sc test22.sc test23.sc \ 40 | test55.sc 41 | 42 | source = test.sc testchk.sc \ 43 | test01.sc test02.sc test03.sc test04.sc test05.sc \ 44 | test06.sc test07.sc test08.sc test09.sc test10.sc \ 45 | test11.sc test12.sc test13.sc test14.sc test15.sc \ 46 | test16.sc test17.sc test18.sc test19.sc test20.sc \ 47 | test20-input.sc test20-make.sc \ 48 | test21.sc test22.sc test23.sc \ 49 | test50.sc test51.sc test52.sc test53.sc test54.sc test54c.c \ 50 | test55.sc \ 51 | alltests.sc 52 | 53 | .sc.c: 54 | ${SCC} -C ${SCCFLAGS} $*.sc 55 | 56 | .c.o: 57 | ${SCC} -c ${SCCFLAGS} $*.c 58 | 59 | test: test.c test.o testchk.c testchk.o ${batch-c} ${batch-o} 60 | ${SCC} ${LDFLAGS} -o test ${SCCFLAGS} test.o testchk.o ${batch-o} 61 | 62 | testn: testchk.c testchk.o 63 | ${SCC} ${LDFLAGS} -i ${SCCFLAGS} -o test${n} test${n}.sc testchk.o 64 | 65 | test50: test50.c test50.o 66 | ${SCC} ${LDFLAGS} -o test50 ${SCCFLAGS} test50.o 67 | 68 | test51: test51.c test51.o 69 | ${SCC} ${LDFLAGS} -o test51 ${SCCFLAGS} test51.o 70 | 71 | test52: test52.c test52.o 72 | ${SCC} ${LDFLAGS} -o test52 ${SCCFLAGS} test52.o 73 | 74 | test53: test53.sc 75 | ${SCC} ${LDFLAGS} -i -o test53 ${SCCFLAGS} test53.sc 76 | 77 | test54: test54.c test54.o test54c.o testchk.o 78 | ${SCC} ${LDFLAGS} -o test54 test54.o test54c.o testchk.o 79 | 80 | test55: test55.c test55.o testchk.o 81 | ${SCC} ${LDFLAGS} -o test55 test55.o testchk.o 82 | 83 | clean: 84 | rm -f *.o *.BAK *.CKP core *.S2C 85 | 86 | clean-sc-to-c: 87 | rm -f ${batch-c} test.c testchk.c test50.c test51.c test52.c test53.c \ 88 | test54.c 89 | 90 | noprogs: 91 | rm -f ${progs} 92 | 93 | all: 94 | $(MAKE) "SCC=${SCC}" "SCCFLAGS=${SCCFLAGS}" \ 95 | test test50 test51 test52 test54 96 | $(MAKE) "SCC=${SCC}" "SCCFLAGS=${SCCFLAGS}" "n=53" testn 97 | 98 | alltests.sc: ${alltests} 99 | cat ${alltests} > alltests.sc 100 | 101 | srclinks: 102 | for x in ${source}; \ 103 | do ln -s ${SRCDIR}/$$x $$x;\ 104 | done 105 | 106 | autotest: autotest-test autotest-test50 autotest-test54 107 | 108 | autotest-test: test 109 | ./test 110 | autotest-test50: test50 111 | ./test50 112 | autotest-test54: test54 113 | ./test54 114 | 115 | .PHONY: autotest-test autotest-test50 autotest-test54 116 | -------------------------------------------------------------------------------- /test/test.sc: -------------------------------------------------------------------------------- 1 | ;;; Test driver. 2 | ;;; 3 | 4 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 5 | ;* All Rights Reserved 6 | 7 | ;* Permission is hereby granted, free of charge, to any person obtaining a 8 | ;* copy of this software and associated documentation files (the "Software"), 9 | ;* to deal in the Software without restriction, including without limitation 10 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 11 | ;* and/or sell copies of the Software, and to permit persons to whom the 12 | ;* Software is furnished to do so, subject to the following conditions: 13 | ;* 14 | ;* The above copyright notice and this permission notice shall be included in 15 | ;* all copies or substantial portions of the Software. 16 | ;* 17 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 22 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;* DEALINGS IN THE SOFTWARE. 24 | 25 | (module test 26 | (main test) 27 | (with test01 test02 test03 test04 test05 28 | test06 test07 test08 test09 test10 29 | test11 test12 test13 test14 test15 30 | test16 test17 test18 test19 test20 31 | test21 test22 test23)) 32 | 33 | (define-external TEST-ERRORS testchk) 34 | 35 | (define (TEST) 36 | (set! test-errors 0) 37 | (format #t "***** Begin Scheme->C Tests *****~%") 38 | (format #t "test01:~%") 39 | (test01) 40 | (format #t "test02:~%") 41 | (test02) 42 | (format #t "test03:~%") 43 | (test03) 44 | (format #t "test04:~%") 45 | (test04) 46 | (format #t "test05:~%") 47 | (test05) 48 | (format #t "test06:~%") 49 | (test06) 50 | (format #t "test07:~%") 51 | (test07) 52 | (format #t "test08:~%") 53 | (test08) 54 | (format #t "test09:~%") 55 | (test09) 56 | (format #t "test10:~%") 57 | (test10) 58 | (format #t "test11:~%") 59 | (test11) 60 | (format #t "test12:~%") 61 | (test12) 62 | (format #t "test13:~%") 63 | (test13) 64 | (format #t "test14:~%") 65 | (test14) 66 | (format #t "test15:~%") 67 | (test15) 68 | (format #t "test16:~%") 69 | (test16) 70 | (format #t "test17:~%") 71 | (test17) 72 | (format #t "test18:~%") 73 | (test18) 74 | (format #t "test19:~%") 75 | (test19) 76 | (format #t "test20:~%") 77 | (test20) 78 | (format #t "test21:~%") 79 | (test21) 80 | (format #t "test22:~%") 81 | (test22) 82 | (format #t "test23:~%") 83 | (test23) 84 | (format #t "***** End Scheme->C Tests ~a Errors *****~%" test-errors)) 85 | 86 | (define (LOAD-TESTS) 87 | (load "testchk.sc") 88 | (load "test01.sc") 89 | (load "test02.sc") 90 | (load "test03.sc") 91 | (load "test04.sc") 92 | (load "test05.sc") 93 | (load "test06.sc") 94 | (load "test07.sc") 95 | (load "test08.sc") 96 | (load "test09.sc") 97 | (load "test10.sc") 98 | (load "test11.sc") 99 | (load "test12.sc") 100 | (load "test13.sc") 101 | (load "test14.sc") 102 | (load "test15.sc") 103 | (load "test16.sc") 104 | (load "test17.sc") 105 | (load "test18.sc") 106 | (load "test19.sc") 107 | (load "test20.sc") 108 | (load "test21.sc") 109 | (load "test22.sc") 110 | (load "test23.sc") 111 | ) 112 | -------------------------------------------------------------------------------- /test/test01.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Test functions for basic Scheme functions. 3 | ;;; 4 | 5 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 6 | ;* All Rights Reserved 7 | 8 | ;* Permission is hereby granted, free of charge, to any person obtaining a 9 | ;* copy of this software and associated documentation files (the "Software"), 10 | ;* to deal in the Software without restriction, including without limitation 11 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 12 | ;* and/or sell copies of the Software, and to permit persons to whom the 13 | ;* Software is furnished to do so, subject to the following conditions: 14 | ;* 15 | ;* The above copyright notice and this permission notice shall be included in 16 | ;* all copies or substantial portions of the Software. 17 | ;* 18 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 24 | ;* DEALINGS IN THE SOFTWARE. 25 | 26 | (module test01) 27 | 28 | (define-external (chk testnum result expected) testchk) 29 | 30 | (define (test01) 31 | 32 | ;;; 6.1 Booleans 33 | 34 | (chk 01 (boolean? '()) #f) 35 | (chk 02 (boolean? '#()) #f) 36 | (chk 03 (boolean? '(1 2)) #f) 37 | (chk 04 (boolean? '#(1 2)) #f) 38 | (chk 05 (boolean? 'x) #f) 39 | (chk 06 (boolean? "x") #f) 40 | (chk 07 (boolean? '#\a) #f) 41 | (chk 08 (boolean? (lambda (x) x)) #f) 42 | (chk 09 (boolean? #f) #t) 43 | (chk 10 (boolean? #t) #t) 44 | (chk 11 (boolean? -1) #f) 45 | (chk 12 (boolean? 0) #f) 46 | (chk 13 (boolean? 1) #f) 47 | (chk 14 (boolean? -1.5) #f) 48 | (chk 15 (boolean? 0.0) #f) 49 | (chk 16 (boolean? 1.5) #f) 50 | 51 | (chk 21 (not '()) #t) 52 | (chk 22 (not '#()) #f) 53 | (chk 23 (not '(1 2)) #f) 54 | (chk 24 (not '#(1 2)) #f) 55 | (chk 25 (not 'x) #f) 56 | (chk 26 (not "x") #f) 57 | (chk 27 (not '#\a) #f) 58 | (chk 28 (not (lambda (x) x)) #f) 59 | (chk 29 (not #f) #t) 60 | (chk 30 (not #t) #f) 61 | (chk 31 (not -1) #f) 62 | (chk 32 (not 0) #f) 63 | (chk 33 (not 1) #f) 64 | (chk 34 (not -1.5) #f) 65 | (chk 35 (not 0.0) #f) 66 | (chk 36 (not 1.5) #f)) 67 | -------------------------------------------------------------------------------- /test/test02.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Test functions for basic Scheme functions. 3 | ;;; 4 | 5 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 6 | ;* All Rights Reserved 7 | 8 | ;* Permission is hereby granted, free of charge, to any person obtaining a 9 | ;* copy of this software and associated documentation files (the "Software"), 10 | ;* to deal in the Software without restriction, including without limitation 11 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 12 | ;* and/or sell copies of the Software, and to permit persons to whom the 13 | ;* Software is furnished to do so, subject to the following conditions: 14 | ;* 15 | ;* The above copyright notice and this permission notice shall be included in 16 | ;* all copies or substantial portions of the Software. 17 | ;* 18 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 24 | ;* DEALINGS IN THE SOFTWARE. 25 | 26 | (module test02) 27 | 28 | (define-external (chk testnum result expected) testchk) 29 | 30 | (define (test02) 31 | 32 | ;;; 6.2 Equivalence Predicates 33 | 34 | (let ((list4 (list 4 3 2 1)) 35 | (vector4 (vector 4 3 2 1))) 36 | 37 | (chk 41 (eqv? "" "") #t) 38 | (chk 42 (eqv? "" "") #t) 39 | (chk 43 (eqv? '() '()) #t) 40 | (chk 44 (eqv? '#() '#()) #t) 41 | (chk 45 (eqv? (car list4) (car list4)) #t) 42 | (chk 46 (eqv? list4 list4) #t) 43 | (chk 47 (eqv? vector4 vector4) #t) 44 | (chk 48 (eqv? 1 1) #t) 45 | (chk 49 (eqv? 1.5 1.5) #t) 46 | (chk 50 (eqv? 1.5 (+ 1.0 0.5)) #t) 47 | (chk 51 (eqv? list4 (list 4 3 2 1)) #f) 48 | (chk 52 (eqv? vector4 (vector 4 3 2 1)) #f) 49 | (chk 53 (eqv? 'x 'x) #t) 50 | 51 | (chk 61 (eq? "" "") #t) 52 | (chk 62 (eq? "" "") #t) 53 | (chk 63 (eq? '() '()) #t) 54 | (chk 64 (eq? '#() '#()) #t) 55 | (chk 65 (eq? (car list4) (car list4)) #t) 56 | (chk 66 (eq? list4 list4) #t) 57 | (chk 67 (eq? vector4 vector4) #t) 58 | (chk 68 (eq? 1 1) #t) 59 | (chk 69 (eq? 1.5 (+ 1.0 0.5)) #f) 60 | (chk 70 (eq? list4 (list 4 3 2 1)) #f) 61 | (chk 71 (eq? vector4 (vector 4 3 2 1)) #f) 62 | (chk 72 (eq? 'x 'x) #t) 63 | 64 | (chk 81 (equal? "" "") #t) 65 | (chk 82 (equal? "" "") #t) 66 | (chk 83 (equal? '() '()) #t) 67 | (chk 84 (equal? '#() '#()) #t) 68 | (chk 85 (equal? (car list4) (car list4)) #t) 69 | (chk 86 (equal? list4 list4) #t) 70 | (chk 87 (equal? vector4 vector4) #t) 71 | (chk 88 (equal? 1 1) #t) 72 | (chk 89 (equal? 1.5 1.5) #t) 73 | (chk 90 (equal? 1.5 (+ 1.0 0.5)) #t) 74 | (chk 91 (equal? list4 (list 4 3 2 1)) #t) 75 | (chk 92 (equal? vector4 (vector 4 3 2 1)) #t) 76 | (chk 93 (equal? 'x 'x) #t) 77 | (chk 93 (equal? (list (list 1 2) (list 3 4)) '((1 2) (3 4))) #t) 78 | (chk 94 (equal? (list (list 1 1) (list 3 4)) '((1 2) (3 4))) #f))) 79 | -------------------------------------------------------------------------------- /test/test04.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | ;* All Rights Reserved 10 | 11 | ;* Permission is hereby granted, free of charge, to any person obtaining a 12 | ;* copy of this software and associated documentation files (the "Software"), 13 | ;* to deal in the Software without restriction, including without limitation 14 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | ;* and/or sell copies of the Software, and to permit persons to whom the 16 | ;* Software is furnished to do so, subject to the following conditions: 17 | ;* 18 | ;* The above copyright notice and this permission notice shall be included in 19 | ;* all copies or substantial portions of the Software. 20 | ;* 21 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | ;* DEALINGS IN THE SOFTWARE. 28 | 29 | (module test04) 30 | 31 | (define-external (chk testnum result expected) testchk) 32 | 33 | (define (test04) 34 | 35 | ;;; 6.4 Symbols 36 | 37 | (chk 2.001 (symbol? '()) #f) 38 | (chk 2.002 (symbol? '#()) #f) 39 | (chk 2.003 (symbol? '(1 2)) #f) 40 | (chk 2.004 (symbol? '#(1 2)) #f) 41 | (chk 2.005 (symbol? 'x) #t) 42 | (chk 2.006 (symbol? "x") #f) 43 | (chk 2.007 (symbol? '#\a) #f) 44 | (chk 2.008 (symbol? (lambda (x) x)) #f) 45 | (chk 2.009 (symbol? #f) #f) 46 | (chk 2.010 (symbol? #t) #f) 47 | (chk 2.011 (symbol? -1) #f) 48 | (chk 2.012 (symbol? 0) #f) 49 | (chk 2.013 (symbol? 1) #f) 50 | (chk 2.014 (symbol? -2.5) #f) 51 | (chk 2.015 (symbol? 0.0) #f) 52 | (chk 2.016 (symbol? 1.5) #f) 53 | 54 | (chk 2.021 (string->symbol "APPLE") 'apple) 55 | (chk 2.022(string->symbol "apple") '\a\p\p\l\e) 56 | (chk 2.023 (eq? (string->uninterned-symbol "APPLE") 'apple) #f) 57 | (chk 2.024 (symbol? (string->uninterned-symbol "APPLE")) #t) 58 | (chk 2.025 (uninterned-symbol? 'apple) #f) 59 | (chk 2.026 (uninterned-symbol? (string->uninterned-symbol "APPLE")) #t) 60 | (let* ((s (string #\A #\p #\p #\L #\E)) 61 | (s-sym (string->symbol s)) 62 | (s-usym (string->uninterned-symbol s))) 63 | (string-set! s 0 #\space) 64 | (chk 2.027 (symbol->string s-sym) "AppLE") 65 | (chk 2.028 (symbol->string s-usym) "AppLE")) 66 | 67 | (putprop 'x 1 #f) 68 | (chk 2.031 (getprop 'x 1) #f) 69 | (chk 2.032 (putprop 'x 1 -1) -1) 70 | (chk 2.033 (putprop 'x 2 -2) -2) 71 | (chk 2.034 (putprop 'x 3 -3) -3) 72 | (chk 2.035 (getprop 'x 1) -1) 73 | (chk 2.036 (getprop 'x 2) -2) 74 | (chk 2.037 (getprop 'x 3) -3) 75 | (chk 2.038 (putprop 'x 2 #f) #f) 76 | (chk 2.039 (getprop 'x 3) -3) 77 | (chk 2.040 (putprop 'x 3 #f) #f) 78 | (chk 2.040 (getprop 'x 3) #f) 79 | (chk 2.041 (getprop 'x 1) -1) 80 | (chk 2.042 (putprop 'x 1 1) 1) 81 | (chk 2.043 (getprop 'x 1) 1)) 82 | -------------------------------------------------------------------------------- /test/test17.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | ;* All Rights Reserved 10 | 11 | ;* Permission is hereby granted, free of charge, to any person obtaining a 12 | ;* copy of this software and associated documentation files (the "Software"), 13 | ;* to deal in the Software without restriction, including without limitation 14 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | ;* and/or sell copies of the Software, and to permit persons to whom the 16 | ;* Software is furnished to do so, subject to the following conditions: 17 | ;* 18 | ;* The above copyright notice and this permission notice shall be included in 19 | ;* all copies or substantial portions of the Software. 20 | ;* 21 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | ;* DEALINGS IN THE SOFTWARE. 28 | 29 | (module test17) 30 | 31 | (define-external (chk testnum result expected) testchk) 32 | 33 | (define (MAKE-COUNTER x) (lambda () (set! x (+ 1 x)))) 34 | 35 | ;;; This funny little function showed up on the Scheme mailing list. It 36 | ;;; creates an object which has state which never uses a SET!. The I/O 37 | ;;; statements in it are there for debugging purposes. 38 | 39 | (define (MAKE-CELL) 40 | (call-with-current-continuation 41 | (lambda (return-from-make-cell) 42 | (letrec ((state 43 | (call-with-current-continuation 44 | (lambda (return-new-state) 45 | (return-from-make-cell 46 | (lambda (op) 47 | ; (format (current-output-port) "OP is ~s~%" op) 48 | (case op 49 | ((set) 50 | (lambda (value) 51 | (call-with-current-continuation 52 | (lambda (return-from-access) 53 | (return-new-state 54 | (begin 55 | ; (format (current-output-port) 56 | ; "VALUE is ~s~%" value) 57 | (list value return-from-access))))))) 58 | ((get) (car state))))))))) 59 | ; (format (current-output-port) "STATE is ~s~%" state) 60 | ((cadr state) 'done))))) 61 | 62 | 63 | (define (test17) 64 | 65 | ;;; Exercise the display and call-with-current-continuation some more. 66 | 67 | (let* ((cntr1 (make-counter 0)) 68 | (cntr2 (make-counter 100)) 69 | (c1-1 (cntr1)) 70 | (c2-101 (cntr2)) 71 | (c1-2 (cntr1)) 72 | (c2-102 (cntr2))) 73 | (chk 1 (list c1-1 c2-101 c1-2 c2-102) '(1 101 2 102))) 74 | 75 | (let ((cell (make-cell))) 76 | ((cell 'set) 23) 77 | (chk 2 (cell 'get) 23))) 78 | 79 | 80 | 81 | 82 | 83 | -------------------------------------------------------------------------------- /test/test18.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | 9 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 10 | ;* All Rights Reserved 11 | 12 | ;* Permission is hereby granted, free of charge, to any person obtaining a 13 | ;* copy of this software and associated documentation files (the "Software"), 14 | ;* to deal in the Software without restriction, including without limitation 15 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 16 | ;* and/or sell copies of the Software, and to permit persons to whom the 17 | ;* Software is furnished to do so, subject to the following conditions: 18 | ;* 19 | ;* The above copyright notice and this permission notice shall be included in 20 | ;* all copies or substantial portions of the Software. 21 | ;* 22 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 23 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 24 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 25 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 26 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 27 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 28 | ;* DEALINGS IN THE SOFTWARE. 29 | 30 | (module test18) 31 | 32 | (define-external (chk test-number result expected) testchk) 33 | 34 | (define (TEST18) 35 | 36 | ;;; 6.10 I/O tests. 37 | 38 | (chk 01 (input-port? '()) #f) 39 | (chk 02 (input-port? '#()) #f) 40 | (chk 03 (input-port? '(1 2)) #f) 41 | (chk 04 (input-port? '#(1 2)) #f) 42 | (chk 05 (input-port? 'x) #f) 43 | (chk 06 (input-port? "x") #f) 44 | (chk 07 (input-port? '#\a) #f) 45 | (chk 08 (input-port? (lambda (x) x)) #f) 46 | (chk 09 (input-port? #f) #f) 47 | (chk 10 (input-port? #t) #f) 48 | (chk 11 (input-port? -1) #f) 49 | (chk 12 (input-port? 0) #f) 50 | (chk 13 (input-port? 1) #f) 51 | (chk 14 (input-port? -1.5) #f) 52 | (chk 15 (input-port? 0.0) #f) 53 | (chk 16 (input-port? 1.5) #f) 54 | (chk 17 (input-port? stdin-port) #t) 55 | 56 | (chk 21 (output-port? '()) #f) 57 | (chk 22 (output-port? '#()) #f) 58 | (chk 23 (output-port? '(1 2)) #f) 59 | (chk 24 (output-port? '#(1 2)) #f) 60 | (chk 25 (output-port? 'x) #f) 61 | (chk 26 (output-port? "x") #f) 62 | (chk 27 (output-port? '#\a) #f) 63 | (chk 28 (output-port? (lambda (x) x)) #f) 64 | (chk 29 (output-port? #f) #f) 65 | (chk 30 (output-port? #t) #f) 66 | (chk 31 (output-port? -1) #f) 67 | (chk 32 (output-port? 0) #f) 68 | (chk 33 (output-port? 1) #f) 69 | (chk 34 (output-port? -1.5) #f) 70 | (chk 35 (output-port? 0.0) #f) 71 | (chk 36 (output-port? 1.5) #f) 72 | (chk 37 (output-port? stdout-port) #t) 73 | (chk 38 (output-port? stderr-port) #t) 74 | 75 | (chk 40 (call-with-output-file "test18.tmp" 76 | (lambda (port) 77 | (write "Test18 - 40" port) 78 | 'test-40)) 79 | 'test-40) 80 | (chk 43 (call-with-input-file "test18.tmp" 81 | (lambda (port) 82 | (chk 41 (read port) "Test18 - 40") 83 | (chk 42 (eof-object? (read port)) #t) 84 | 'test-43)) 85 | 'test-43) 86 | 87 | (chk 50 (with-output-to-file "test18.tmp" 88 | (lambda () 89 | (write "Test18 - 50") 90 | 'test-50)) 91 | 'test-50) 92 | (chk 53 (with-input-from-file "test18.tmp" 93 | (lambda () 94 | (chk 51 (read) "Test18 - 50") 95 | (chk 52 (eof-object? (read)) #t) 96 | 'test-53)) 97 | 'test-53) 98 | 99 | (let ((port (open-input-file "test18.tmp"))) 100 | (chk 60 (read port) "Test18 - 50") 101 | (chk 61 (eof-object? (read port)) #t) 102 | (close-input-port port)) 103 | 104 | (let ((port (open-output-file "test18.tmp"))) 105 | (write "Test18 - 70" port) 106 | (close-output-port port) 107 | (set! port (open-file "test18.tmp" "r")) 108 | (chk 70 (read port) "Test18 - 70") 109 | (chk 71 (eof-object? (read port)) #t) 110 | (chk 72 (eof-object? (read port)) #t) 111 | (close-port port)) 112 | 113 | (let ((port (open-input-string "1.2 (a b c)"))) 114 | (chk 80 (read port) 1.2) 115 | (chk 81 (read port) '(a b c)) 116 | (chk 82 (eof-object? (read port)) #t) 117 | (chk 83 (eof-object? (read port)) #t)) 118 | 119 | (let ((port (open-output-string))) 120 | (chk 90 (get-output-string port) "") 121 | (write '(a b c d) port) 122 | (chk 91 (get-output-string port) "(A B C D)") 123 | (chk 92 (get-output-string port) "") 124 | (write "This is a string" port) 125 | (chk 93 (get-output-string port) "\"This is a string\""))) 126 | 127 | 128 | -------------------------------------------------------------------------------- /test/test19.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | ;* All Rights Reserved 10 | 11 | ;* Permission is hereby granted, free of charge, to any person obtaining a 12 | ;* copy of this software and associated documentation files (the "Software"), 13 | ;* to deal in the Software without restriction, including without limitation 14 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | ;* and/or sell copies of the Software, and to permit persons to whom the 16 | ;* Software is furnished to do so, subject to the following conditions: 17 | ;* 18 | ;* The above copyright notice and this permission notice shall be included in 19 | ;* all copies or substantial portions of the Software. 20 | ;* 21 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | ;* DEALINGS IN THE SOFTWARE. 28 | 29 | (module test19) 30 | 31 | (define-external (chk test-number result expected) testchk) 32 | 33 | (define (TEST19) 34 | 35 | ;;; 6.10 I/O tests. 36 | 37 | (let ((port (open-input-string "*"))) 38 | (chk 1 (peek-char port) #\*) 39 | (chk 2 (peek-char port) #\*) 40 | (chk 3 (read-char port) #\*) 41 | (chk 4 (eof-object? (read-char port)) #t) 42 | (chk 5 (eof-object? (peek-char port)) #t)) 43 | 44 | (with-output-to-file "test19.tmp" 45 | (lambda () 46 | (write-char #\*) 47 | (chk 10 (write-count) 1) 48 | (chk 11 (write-width) 80) 49 | (set-write-width! 132) 50 | (chk 12 (write-width) 132))) 51 | 52 | (with-input-from-file "test19.tmp" 53 | (lambda () 54 | (chk 21 (peek-char) #\*) 55 | (chk 22 (peek-char) #\*) 56 | (chk 23 (read-char) #\*) 57 | (chk 24 (eof-object? (read-char)) #t) 58 | (chk 25 (eof-object? (peek-char)) #t))) 59 | 60 | (with-output-to-file "test19.tmp" 61 | (lambda () 62 | (with-input-from-file "test19.tmp" 63 | (lambda () 64 | (display 'a) 65 | (chk 30 (eof-object? (read)) #t) 66 | (flush-buffer) 67 | (chk 31 (read) 'a))))) 68 | 69 | (chk 50 (format "~%") (list->string '(#\newline))) 70 | (chk 51 (format "~a~s" "a" "a") "a\"a\"") 71 | (chk 52 (format "~A~S" "a" "a") "a\"a\"") 72 | (chk 53 (format "~c~C" #\a #\a) "aa") 73 | (chk 54 (format "~~") "~") 74 | ) 75 | -------------------------------------------------------------------------------- /test/test20-input.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; readprint test script 3 | ;;; 4 | 5 | ;;; boolean 6 | 7 | #t 8 | #T 9 | #f 10 | #F 11 | 12 | ;;; identifier 13 | 14 | apple 15 | Apple 16 | \apple 17 | \1+ 18 | + 19 | - 20 | a.b 21 | 22 | ;;; number 23 | 24 | 1 25 | -1 26 | +1 27 | +#b11 28 | +#o11 29 | +#xa1 30 | #B11 31 | #O11 32 | #XA1 33 | 1.3 34 | -1.3 35 | 1.3E2 36 | -1.3E2 37 | 38 | ;;; character 39 | 40 | #\a 41 | #\A 42 | #\tab 43 | #\newline 44 | #\linefeed 45 | #\formfeed 46 | #\return 47 | #\space 48 | #\SPAce 49 | #\\ 50 | #\ ;;; A space follows the \ 51 | #\ ;;; A tab follows the \ 52 | 53 | ;;; string 54 | 55 | "" 56 | "This is a string" 57 | "This is a string with \"embedded\" quote marks" 58 | "This string covers 59 | two lines" 60 | 61 | ;;; lists 62 | 63 | () 64 | (a) 65 | (a . b) 66 | (a b c d) 67 | (a . (b . (c . (d . ())))) 68 | ((a b)(c d)(e f)(g h)) 69 | ( 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 70 | 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 71 | y z a b c d e f g h i j k l) 72 | 73 | ;;; vector 74 | 75 | #() 76 | #(1) 77 | #(1 2 3 4) 78 | #(#(1 2) #(2 3) #(3 4)) 79 | #( 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 80 | 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 81 | y z a b c d e f g h i j k l) 82 | 83 | ;;; quote and quasiquote 84 | 85 | 'a 86 | '(1 2 3) 87 | ,b 88 | ,@c 89 | `(a b c) 90 | `(a ,b ,@c) 91 | 92 | 93 | -------------------------------------------------------------------------------- /test/test20-make.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | ;* All Rights Reserved 10 | 11 | ;* Permission is hereby granted, free of charge, to any person obtaining a 12 | ;* copy of this software and associated documentation files (the "Software"), 13 | ;* to deal in the Software without restriction, including without limitation 14 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | ;* and/or sell copies of the Software, and to permit persons to whom the 16 | ;* Software is furnished to do so, subject to the following conditions: 17 | ;* 18 | ;* The above copyright notice and this permission notice shall be included in 19 | ;* all copies or substantial portions of the Software. 20 | ;* 21 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | ;* DEALINGS IN THE SOFTWARE. 28 | 29 | ;;; This test function builds the test program for test 20, using a 30 | ;;; "known good" version of the Scheme->C interpreter. 31 | 32 | (define (TEST20-MAKE) 33 | (let ((in (open-input-file "test20-input.sc")) 34 | (out (open-output-file "test20.sc"))) 35 | (format out "(module test20)~%~%") 36 | (format out "(define (TEST20)~%") 37 | (format out " (with-input-from-file \"test20-input.sc\"~%") 38 | (format out " (lambda ()~%") 39 | (let loop ((form (read in)) (i 1)) 40 | (unless (eof-object? form) 41 | (format out " (chk ~s (read) '~s)~%" 42 | i form) 43 | (loop (read in) (+ i 1)))) 44 | (format out ")))~%") 45 | (close-input-port in) 46 | (close-output-port out))) 47 | 48 | -------------------------------------------------------------------------------- /test/test20.sc: -------------------------------------------------------------------------------- 1 | (module test20) 2 | 3 | (define (TEST20) 4 | (with-input-from-file "test20-input.sc" 5 | (lambda () 6 | (chk 1 (read) '#T) 7 | (chk 2 (read) '#T) 8 | (chk 3 (read) '#F) 9 | (chk 4 (read) '#F) 10 | (chk 5 (read) 'APPLE) 11 | (chk 6 (read) 'APPLE) 12 | (chk 7 (read) '\aPPLE) 13 | (chk 8 (read) '\1+) 14 | (chk 9 (read) '+) 15 | (chk 10 (read) '-) 16 | (chk 11 (read) 'A.B) 17 | (chk 12 (read) '1) 18 | (chk 13 (read) '-1) 19 | (chk 14 (read) '1) 20 | (chk 15 (read) '3) 21 | (chk 16 (read) '9) 22 | (chk 17 (read) '161) 23 | (chk 18 (read) '3) 24 | (chk 19 (read) '9) 25 | (chk 20 (read) '161) 26 | (chk 21 (read) '1.3) 27 | (chk 22 (read) '-1.3) 28 | (chk 23 (read) '130.) 29 | (chk 24 (read) '-130.) 30 | (chk 25 (read) '#\a) 31 | (chk 26 (read) '#\A) 32 | (chk 27 (read) '#\tab) 33 | (chk 28 (read) '#\newline) 34 | (chk 29 (read) '#\newline) 35 | (chk 30 (read) '#\formfeed) 36 | (chk 31 (read) '#\return) 37 | (chk 32 (read) '#\space) 38 | (chk 33 (read) '#\space) 39 | (chk 34 (read) '#\\) 40 | (chk 35 (read) '#\space) 41 | (chk 36 (read) '#\tab) 42 | (chk 37 (read) '"") 43 | (chk 38 (read) '"This is a string") 44 | (chk 39 (read) '"This is a string with \"embedded\" quote marks") 45 | (chk 40 (read) '"This string covers 46 | two lines") 47 | (chk 41 (read) '()) 48 | (chk 42 (read) '(A)) 49 | (chk 43 (read) '(A . B)) 50 | (chk 44 (read) '(A B C D)) 51 | (chk 45 (read) '(A B C D)) 52 | (chk 46 (read) '((A B) (C D) (E F) (G H))) 53 | (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)) 54 | (chk 48 (read) '#()) 55 | (chk 49 (read) '#(1)) 56 | (chk 50 (read) '#(1 2 3 4)) 57 | (chk 51 (read) '#(#(1 2) #(2 3) #(3 4))) 58 | (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)) 59 | (chk 53 (read) ''A) 60 | (chk 54 (read) ''(1 2 3)) 61 | (chk 55 (read) ',B) 62 | (chk 56 (read) ',@C) 63 | (chk 57 (read) '`(A B C)) 64 | (chk 58 (read) '`(A ,B ,@C)) 65 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 66 | ;* All Rights Reserved 67 | 68 | ;* Permission is hereby granted, free of charge, to any person obtaining a 69 | ;* copy of this software and associated documentation files (the "Software"), 70 | ;* to deal in the Software without restriction, including without limitation 71 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 72 | ;* and/or sell copies of the Software, and to permit persons to whom the 73 | ;* Software is furnished to do so, subject to the following conditions: 74 | ;* 75 | ;* The above copyright notice and this permission notice shall be included in 76 | ;* all copies or substantial portions of the Software. 77 | ;* 78 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 79 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 80 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 81 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 82 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 83 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 84 | ;* DEALINGS IN THE SOFTWARE. 85 | ))) 86 | -------------------------------------------------------------------------------- /test/test50.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | ;* All Rights Reserved 10 | 11 | ;* Permission is hereby granted, free of charge, to any person obtaining a 12 | ;* copy of this software and associated documentation files (the "Software"), 13 | ;* to deal in the Software without restriction, including without limitation 14 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | ;* and/or sell copies of the Software, and to permit persons to whom the 16 | ;* Software is furnished to do so, subject to the following conditions: 17 | ;* 18 | ;* The above copyright notice and this permission notice shall be included in 19 | ;* all copies or substantial portions of the Software. 20 | ;* 21 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | ;* DEALINGS IN THE SOFTWARE. 28 | 29 | (module test50 (main test50)) 30 | 31 | ;;; Memory management test 32 | 33 | (define (LISTTEST i l) 34 | (do ((next 1 (+ next 1)) 35 | (l l (cdr l))) 36 | ((or (null? l) (not (eq? (car l) next))) 37 | (if (or l (not (eq? next 10001))) 38 | (error 'listtest "Failed! ~s-~s~%" i next))))) 39 | 40 | (define (TEST50) 41 | (display "***** Starting Memory Test") 42 | (newline) 43 | 44 | (let ((old-obarray *obarray*)) 45 | (collect) 46 | (display "Successfully Garbage Collected initial image") 47 | (newline) 48 | (collect-all) 49 | (display "Collect-all of initial image") 50 | (newline) 51 | (if (not (equal? old-obarray *obarray*)) 52 | (error 'memtest "*OBARRAY* comparison failed"))) 53 | 54 | (display "1000 Lists of 10000 pairs each") 55 | (newline) 56 | (do ((i 0 (+ i 1))) 57 | ((= 1000 i)) 58 | (do ((j 10000 (- j 1)) 59 | (l '() (cons j l))) 60 | ((zero? j) 61 | (listtest i l))) 62 | (if (zero? (remainder i 100)) 63 | (begin (display i) (display " ") (flush-buffer)))) 64 | (newline) 65 | 66 | (display "1000 Vectors of 10000 entries each") 67 | (newline) 68 | (do ((i 0 (+ i 1))) 69 | ((= i 1000)) 70 | (make-vector 10000 i) 71 | (if (zero? (remainder i 100)) 72 | (begin (display i) (display " ") (flush-buffer)))) 73 | (newline) 74 | 75 | (display "1000 Strings of 10000 entries each") 76 | (newline) 77 | (do ((i 0 (+ i 1))) 78 | ((= i 1000)) 79 | (make-string 10000) 80 | (if (zero? (remainder i 100)) 81 | (begin (display i) (display " ") (flush-buffer)))) 82 | (newline) 83 | 84 | (display "***** Ending Memory Test") 85 | (newline)) 86 | 87 | 88 | 89 | 90 | 91 | 92 | -------------------------------------------------------------------------------- /test/test51.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | ;* All Rights Reserved 10 | 11 | ;* Permission is hereby granted, free of charge, to any person obtaining a 12 | ;* copy of this software and associated documentation files (the "Software"), 13 | ;* to deal in the Software without restriction, including without limitation 14 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | ;* and/or sell copies of the Software, and to permit persons to whom the 16 | ;* Software is furnished to do so, subject to the following conditions: 17 | ;* 18 | ;* The above copyright notice and this permission notice shall be included in 19 | ;* all copies or substantial portions of the Software. 20 | ;* 21 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | ;* DEALINGS IN THE SOFTWARE. 28 | 29 | (module test51 (main test51)) 30 | 31 | (define (TEST51 clargs) 32 | (display "Hello world!") 33 | (newline)) 34 | 35 | -------------------------------------------------------------------------------- /test/test52.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | ;* All Rights Reserved 10 | 11 | ;* Permission is hereby granted, free of charge, to any person obtaining a 12 | ;* copy of this software and associated documentation files (the "Software"), 13 | ;* to deal in the Software without restriction, including without limitation 14 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | ;* and/or sell copies of the Software, and to permit persons to whom the 16 | ;* Software is furnished to do so, subject to the following conditions: 17 | ;* 18 | ;* The above copyright notice and this permission notice shall be included in 19 | ;* all copies or substantial portions of the Software. 20 | ;* 21 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | ;* DEALINGS IN THE SOFTWARE. 28 | 29 | (module test52 (main test52)) 30 | 31 | ;;; Prints the command line arguments 32 | 33 | (define (TEST52 cl) 34 | (write cl) 35 | (newline)) 36 | 37 | -------------------------------------------------------------------------------- /test/test53.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Scheme->C test program 3 | ;;; 4 | ;;; 5 | ;;; Test functions for basic Scheme functions. 6 | ;;; 7 | 8 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 9 | ;* All Rights Reserved 10 | 11 | ;* Permission is hereby granted, free of charge, to any person obtaining a 12 | ;* copy of this software and associated documentation files (the "Software"), 13 | ;* to deal in the Software without restriction, including without limitation 14 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 15 | ;* and/or sell copies of the Software, and to permit persons to whom the 16 | ;* Software is furnished to do so, subject to the following conditions: 17 | ;* 18 | ;* The above copyright notice and this permission notice shall be included in 19 | ;* all copies or substantial portions of the Software. 20 | ;* 21 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | ;* DEALINGS IN THE SOFTWARE. 28 | 29 | (module test53) 30 | 31 | ;;; Loops until a key is entered on the keyboard 32 | 33 | (define (KEY-LOOP) 34 | (let loop () (when (char-ready?) (read-char) (loop))) 35 | (display "Waiting for char (and a return) ...") 36 | (flush-buffer) 37 | (let loop ((cnt 0)) 38 | (unless (char-ready?) 39 | (if (zero? (modulo cnt 1000)) 40 | (begin (display ".") 41 | (loop 1))) 42 | (loop (+ cnt 1)))) 43 | (write (read-char)) 44 | (display " entered") 45 | (let loop () (when (char-ready?) (read-char) (loop))) 46 | (newline)) 47 | 48 | (define (CONTROL-C) 49 | (display "Hit control-c ...") 50 | (flush-buffer) 51 | (let loop ((cnt 1)) 52 | (if (zero? (modulo cnt 10000)) 53 | (begin (display ".") 54 | (flush-buffer) 55 | (loop 1)) 56 | (loop (+ cnt 1))))) 57 | 58 | (define (TEST53) 59 | (key-loop) 60 | (control-c)) 61 | 62 | -------------------------------------------------------------------------------- /test/test54c.c: -------------------------------------------------------------------------------- 1 | /* Global variable access test */ 2 | 3 | char c1 = 'A', c2 = 'c'; 4 | 5 | short int si1 = -4, si2 = 24; 6 | 7 | short unsigned su1 = 0xFFFF, su2 = 23; 8 | 9 | int i1 = -2, i2 = 2; 10 | 11 | unsigned int ui1 = 0xFFFFFFFF, ui2 = 0x1FFFFFFF, ui3 = 0xFFFF; 12 | 13 | float f1 = 23.23; 14 | 15 | double d1 = 32.32, ad1[3] = {0.0, 1.0, 2.0}; 16 | 17 | /* Typed function returns */ 18 | 19 | char fc1() { return c1; } 20 | 21 | char fc2() { return c2; } 22 | 23 | short int fsi1() { return si1; } 24 | 25 | short int fsi2() { return si2; } 26 | 27 | short unsigned fsu1() { return su1; } 28 | 29 | short unsigned fsu2() { return su2; } 30 | 31 | int fi1() { return i1; } 32 | 33 | int fi2() { return i2; } 34 | 35 | unsigned int fui1() { return ui1; } 36 | 37 | unsigned int fui2() { return ui2; } 38 | 39 | unsigned int fui3() { return ui3; } 40 | 41 | float ff1() { return f1; } 42 | 43 | double fd1() { return d1; } 44 | 45 | /* Typed function arguments and return */ 46 | 47 | #ifndef __STDC__ 48 | 49 | char* loop_pointer( x ) char *x; { return x; } 50 | 51 | char* loop_array( x ) char *x; { return x; } 52 | 53 | char loop_char( x) char x; { return x; } 54 | 55 | short int loop_shortint( x ) short int x; { return x; } 56 | 57 | unsigned short int loop_shortunsigned( x ) unsigned short int x; { return x; } 58 | 59 | int loop_int( x ) int x; { return x; } 60 | 61 | unsigned int loop_unsigned( x ) unsigned int x; { return x; } 62 | 63 | long int loop_longint( x ) long int x; { return x; } 64 | 65 | unsigned long int loop_longunsigned( x ) unsigned long int x; { return x; } 66 | 67 | float loop_float( x ) float x; { return x; } 68 | 69 | double loop_double( x ) double x; { return x; } 70 | 71 | #else 72 | 73 | void* loop_pointer( void* x ) { return x; } 74 | 75 | void* loop_array( void* x ) { return x; } 76 | 77 | char loop_char( char x ) { return x; } 78 | 79 | short int loop_shortint( short int x ) { return x; } 80 | 81 | unsigned short int loop_shortunsigned( unsigned short int x ) { return x; } 82 | 83 | int loop_int( int x ) { return x; } 84 | 85 | unsigned int loop_unsigned( unsigned int x ) { return x; } 86 | 87 | long int loop_longint( long int x ) { return x; } 88 | 89 | unsigned long int loop_longunsigned( unsigned long int x ) { return x; } 90 | 91 | float loop_float( float x ) { return x; } 92 | 93 | double loop_double( double x ) { return x; } 94 | 95 | #endif 96 | -------------------------------------------------------------------------------- /test/test55.sc: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Test functions for basic Scheme functions. 3 | ;;; 4 | 5 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 6 | ;* All Rights Reserved 7 | 8 | ;* Permission is hereby granted, free of charge, to any person obtaining a 9 | ;* copy of this software and associated documentation files (the "Software"), 10 | ;* to deal in the Software without restriction, including without limitation 11 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 12 | ;* and/or sell copies of the Software, and to permit persons to whom the 13 | ;* Software is furnished to do so, subject to the following conditions: 14 | ;* 15 | ;* The above copyright notice and this permission notice shall be included in 16 | ;* all copies or substantial portions of the Software. 17 | ;* 18 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 23 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 24 | ;* DEALINGS IN THE SOFTWARE. 25 | 26 | (module test55 (main test55)) 27 | 28 | (define (TEST55) 29 | 30 | ;;; Write length and levels. 31 | 32 | (for-each 33 | (lambda (v n) 34 | (set-write-level! v) 35 | (set-write-length! n) 36 | (format #t "~s ~s ~s~%" v n 37 | '(if (member x y) (+ (car x) 3) 38 | '(foo . #(a b c d "Baz"))))) 39 | '(0 1 1 1 1 2 2 2 3 3 3 #f) 40 | '(1 1 2 3 4 1 2 3 2 3 4 #f)) 41 | (newline) 42 | 43 | ;;; Circularity detection. 44 | 45 | (set-write-circle! #t) 46 | (let* ((x (list 1 2 3 4 5)) 47 | (y (make-vector 5 x))) 48 | (set-cdr! (last-pair x) x) 49 | (vector-set! y 4 y) 50 | (write y)) 51 | (newline) 52 | (newline) 53 | 54 | ;;; Pretty-printing 55 | 56 | (set-write-pretty! #t) 57 | (write '(for-each 58 | (lambda (v n) 59 | (set-write-level! v) 60 | (set-write-length! n) 61 | (format #t "~s ~s ~s~%" v n 62 | '(if (member x y) (+ (car x) 3) 63 | '(foo . #(a b c d "Baz"))))) 64 | '(0 1 1 1 1 2 2 2 3 3 3 #f) 65 | '(1 1 2 3 4 1 2 3 2 3 4 #f))) 66 | (newline) 67 | (newline) 68 | 69 | (set-write-pretty! #f) 70 | (pp '(for-each 71 | (lambda (v n) 72 | (set-write-level! v) 73 | (set-write-length! n) 74 | (format #t "~s ~s ~s~%" v n 75 | '(if (member x y) (+ (car x) 3) 76 | '(foo . #(a b c d "Baz"))))) 77 | '(0 1 1 1 1 2 2 2 3 3 3 #f) 78 | '(1 1 2 3 4 1 2 3 2 3 4 #f))) 79 | (newline) 80 | #f) 81 | -------------------------------------------------------------------------------- /test/testchk.sc: -------------------------------------------------------------------------------- 1 | ;;; Test driver checking functions. 2 | 3 | ;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P. 4 | ;* All Rights Reserved 5 | 6 | ;* Permission is hereby granted, free of charge, to any person obtaining a 7 | ;* copy of this software and associated documentation files (the "Software"), 8 | ;* to deal in the Software without restriction, including without limitation 9 | ;* the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | ;* and/or sell copies of the Software, and to permit persons to whom the 11 | ;* Software is furnished to do so, subject to the following conditions: 12 | ;* 13 | ;* The above copyright notice and this permission notice shall be included in 14 | ;* all copies or substantial portions of the Software. 15 | ;* 16 | ;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | ;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | ;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | ;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | ;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | ;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | ;* DEALINGS IN THE SOFTWARE. 23 | 24 | (module testchk) 25 | 26 | (define TEST-ERRORS 0) 27 | 28 | (define *ACCURACY* 1.0e-7) 29 | 30 | (define (CHK test result expected) 31 | (unless (or (equal? result expected) 32 | (and (%record? result) 33 | (%record expected) 34 | (equal? (%record->list result) (%record->list expected))) 35 | (and (number? expected) 36 | (number? result) 37 | (inexact? expected) 38 | (<= (abs (- expected result)) 39 | (* (abs expected) *accuracy*)))) 40 | (format stdout-port " Test ~a failed~%" test) 41 | (format stdout-port " expected = ~s~%" expected) 42 | (format stdout-port " result = ~s~%" result) 43 | (set! test-errors (+ test-errors 1)))) 44 | 45 | (define (CHKQ test result expected) 46 | (unless (eq? result expected) 47 | (format stdout-port " Test ~a failed~%" test) 48 | (format stdout-port " expected = ~s~%" expected) 49 | (format stdout-port " result = ~s~%" result) 50 | (set! test-errors (+ test-errors 1)))) 51 | -------------------------------------------------------------------------------- /xlib/README: -------------------------------------------------------------------------------- 1 | Scheme->C interface to X11's Xlib 2 | -------------------------------------------------------------------------------- /xlib/Xatom.cdecl: -------------------------------------------------------------------------------- 1 | ;;; X11 Xatom.h file for use by Scheme->C 2 | 3 | (const XA_PRIMARY 1) 4 | (const XA_SECONDARY 2) 5 | (const XA_ARC 3) 6 | (const XA_ATOM 4) 7 | (const XA_BITMAP 5) 8 | (const XA_CARDINAL 6) 9 | (const XA_COLORMAP 7) 10 | (const XA_CURSOR 8) 11 | (const XA_CUT_BUFFER0 9) 12 | (const XA_CUT_BUFFER1 10) 13 | (const XA_CUT_BUFFER2 11) 14 | (const XA_CUT_BUFFER3 12) 15 | (const XA_CUT_BUFFER4 13) 16 | (const XA_CUT_BUFFER5 14) 17 | (const XA_CUT_BUFFER6 15) 18 | (const XA_CUT_BUFFER7 16) 19 | (const XA_DRAWABLE 17) 20 | (const XA_FONT 18) 21 | (const XA_INTEGER 19) 22 | (const XA_PIXMAP 20) 23 | (const XA_POINT 21) 24 | (const XA_RECTANGLE 22) 25 | (const XA_RESOURCE_MANAGER 23) 26 | (const XA_RGB_COLOR_MAP 24) 27 | (const XA_RGB_BEST_MAP 25) 28 | (const XA_RGB_BLUE_MAP 26) 29 | (const XA_RGB_DEFAULT_MAP 27) 30 | (const XA_RGB_GRAY_MAP 28) 31 | (const XA_RGB_GREEN_MAP 29) 32 | (const XA_RGB_RED_MAP 30) 33 | (const XA_STRING 31) 34 | (const XA_VISUALID 32) 35 | (const XA_WINDOW 33) 36 | (const XA_WM_COMMAND 34) 37 | (const XA_WM_HINTS 35) 38 | (const XA_WM_CLIENT_MACHINE 36) 39 | (const XA_WM_ICON_NAME 37) 40 | (const XA_WM_ICON_SIZE 38) 41 | (const XA_WM_NAME 39) 42 | (const XA_WM_NORMAL_HINTS 40) 43 | (const XA_WM_SIZE_HINTS 41) 44 | (const XA_WM_ZOOM_HINTS 42) 45 | (const XA_MIN_SPACE 43) 46 | (const XA_NORM_SPACE 44) 47 | (const XA_MAX_SPACE 45) 48 | (const XA_END_SPACE 46) 49 | (const XA_SUPERSCRIPT_X 47) 50 | (const XA_SUPERSCRIPT_Y 48) 51 | (const XA_SUBSCRIPT_X 49) 52 | (const XA_SUBSCRIPT_Y 50) 53 | (const XA_UNDERLINE_POSITION 51) 54 | (const XA_UNDERLINE_THICKNESS 52) 55 | (const XA_STRIKEOUT_ASCENT 53) 56 | (const XA_STRIKEOUT_DESCENT 54) 57 | (const XA_ITALIC_ANGLE 55) 58 | (const XA_X_HEIGHT 56) 59 | (const XA_QUAD_WIDTH 57) 60 | (const XA_WEIGHT 58) 61 | (const XA_POINT_SIZE 59) 62 | (const XA_RESOLUTION 60) 63 | (const XA_COPYRIGHT 61) 64 | (const XA_NOTICE 62) 65 | (const XA_FONT_NAME 63) 66 | (const XA_FAMILY_NAME 64) 67 | (const XA_FULL_NAME 65) 68 | (const XA_CAP_HEIGHT 66) 69 | (const XA_WM_CLASS 67) 70 | (const XA_WM_TRANSIENT_FOR 68) 71 | 72 | (const XA_LAST_PREDEFINED 68) 73 | -------------------------------------------------------------------------------- /xlib/Xcursorfont.cdecl: -------------------------------------------------------------------------------- 1 | ;;; /* $Header: Xcursorfont.cdecl,v 1.1 92/12/28 13:29:14 bartlett Locked $ */ 2 | (const XC_num_glyphs 154) 3 | (const XC_X_cursor 0) 4 | (const XC_arrow 2) 5 | (const XC_based_arrow_down 4) 6 | (const XC_based_arrow_up 6) 7 | (const XC_boat 8) 8 | (const XC_bogosity 10) 9 | (const XC_bottom_left_corner 12) 10 | (const XC_bottom_right_corner 14) 11 | (const XC_bottom_side 16) 12 | (const XC_bottom_tee 18) 13 | (const XC_box_spiral 20) 14 | (const XC_center_ptr 22) 15 | (const XC_circle 24) 16 | (const XC_clock 26) 17 | (const XC_coffee_mug 28) 18 | (const XC_cross 30) 19 | (const XC_cross_reverse 32) 20 | (const XC_crosshair 34) 21 | (const XC_diamond_cross 36) 22 | (const XC_dot 38) 23 | (const XC_dotbox 40) 24 | (const XC_double_arrow 42) 25 | (const XC_draft_large 44) 26 | (const XC_draft_small 46) 27 | (const XC_draped_box 48) 28 | (const XC_exchange 50) 29 | (const XC_fleur 52) 30 | (const XC_gobbler 54) 31 | (const XC_gumby 56) 32 | (const XC_hand1 58) 33 | (const XC_hand2 60) 34 | (const XC_heart 62) 35 | (const XC_icon 64) 36 | (const XC_iron_cross 66) 37 | (const XC_left_ptr 68) 38 | (const XC_left_side 70) 39 | (const XC_left_tee 72) 40 | (const XC_leftbutton 74) 41 | (const XC_ll_angle 76) 42 | (const XC_lr_angle 78) 43 | (const XC_man 80) 44 | (const XC_middlebutton 82) 45 | (const XC_mouse 84) 46 | (const XC_pencil 86) 47 | (const XC_pirate 88) 48 | (const XC_plus 90) 49 | (const XC_question_arrow 92) 50 | (const XC_right_ptr 94) 51 | (const XC_right_side 96) 52 | (const XC_right_tee 98) 53 | (const XC_rightbutton 100) 54 | (const XC_rtl_logo 102) 55 | (const XC_sailboat 104) 56 | (const XC_sb_down_arrow 106) 57 | (const XC_sb_h_double_arrow 108) 58 | (const XC_sb_left_arrow 110) 59 | (const XC_sb_right_arrow 112) 60 | (const XC_sb_up_arrow 114) 61 | (const XC_sb_v_double_arrow 116) 62 | (const XC_shuttle 118) 63 | (const XC_sizing 120) 64 | (const XC_spider 122) 65 | (const XC_spraycan 124) 66 | (const XC_star 126) 67 | (const XC_target 128) 68 | (const XC_tcross 130) 69 | (const XC_top_left_arrow 132) 70 | (const XC_top_left_corner 134) 71 | (const XC_top_right_corner 136) 72 | (const XC_top_side 138) 73 | (const XC_top_tee 140) 74 | (const XC_trek 142) 75 | (const XC_ul_angle 144) 76 | (const XC_umbrella 146) 77 | (const XC_ur_angle 148) 78 | (const XC_watch 150) 79 | (const XC_xterm 152) 80 | -------------------------------------------------------------------------------- /xlib/Xr4.cdecl: -------------------------------------------------------------------------------- 1 | ;;; Additional data structures for X11 R4. 2 | 3 | (typedef (struct 4 | (int depth) 5 | (int bits_per_pixel) 6 | (int scanline_pad) 7 | ) XPixmapFormatValues) 8 | 9 | (typedef (XPixmapFormatValues *) XPixmapFormatValuesP) 10 | 11 | (typedef (XPixmapFormatValues 0) XPixmapFormatValuesA) 12 | 13 | (typedef (XPixmapFormatValuesA *) XPixmapFormatValuesAP) 14 | 15 | (typedef (struct 16 | (Charp value) 17 | (Atom encoding) 18 | (int format) 19 | (unsignedlong nitems) 20 | ) XTextProperty) 21 | 22 | (typedef (XTextProperty *) XTextPropertyP) 23 | -------------------------------------------------------------------------------- /xlib/clear.sc: -------------------------------------------------------------------------------- 1 | ;;; Creates a clear window which covers the display. Then writes speckles 2 | ;;; in it. A mouse click causes it to go away. 3 | 4 | (module clear 5 | (main main) 6 | (with xlib)) 7 | 8 | (define-c-external (rand) int "rand") 9 | 10 | (define (RANDOM) 11 | (quotient (rand) 4096)) 12 | 13 | (define (CLEAR display-name) 14 | (let* ((dpy (let ((x (xopendisplay display-name))) 15 | (if (null-pointer? x) 16 | (error 'hello-world "DISPLAY is not defined")) 17 | x)) 18 | (screen (xdefaultscreen dpy)) 19 | (attributes (let ((x (make-xsetwindowattributes))) 20 | (xsetwindowattributes-override_redirect! x 1) 21 | (xsetwindowattributes-background_pixmap! x none) 22 | x)) 23 | (height (xdisplayheight dpy screen)) 24 | (width (xdisplaywidth dpy screen)) 25 | (window (xcreatewindow dpy (xdefaultrootwindow dpy) 0 0 26 | width height 27 | 0 copyfromparent copyfromparent 28 | (type/value->pointer 'visualp copyfromparent) 29 | (+ cwbackpixmap cwoverrideredirect) 30 | attributes)) 31 | (gc (xcreategc dpy window 0 (make-xgcvalues))) 32 | (event (make-xevent)) 33 | (old-reset reset)) 34 | 35 | (set! reset (lambda () 36 | (xclosedisplay dpy) 37 | (set! reset old-reset) 38 | (reset))) 39 | (xsetforeground dpy gc (xblackpixel dpy screen)) 40 | (xselectinput dpy window (+ buttonpressmask exposuremask)) 41 | (xmapraised dpy window) 42 | (let loop () 43 | (ynextevent dpy event) 44 | (cond ((eq? (xevent-type event) expose) 45 | (let loop () 46 | (xfillrectangle dpy window gc 47 | (remainder (random) width) 48 | (remainder (random) height) 1 1) 49 | (if (eq? (xeventsqueued dpy queuedafterflush) 0) 50 | (loop))) 51 | (loop)) 52 | ((eq? (xevent-type event) buttonpress) 53 | (set! reset old-reset) 54 | (xfreegc dpy gc) 55 | (xdestroywindow dpy window) 56 | (xclosedisplay dpy)) 57 | (else (loop)))))) 58 | 59 | (define (MAIN clargs) 60 | (if (and (= (length clargs) 3) (equal? (cadr clargs) "-display")) 61 | (clear (caddr clargs)) 62 | (clear ""))) 63 | -------------------------------------------------------------------------------- /xlib/hello.sc: -------------------------------------------------------------------------------- 1 | ;;; Hello, World example from Oliver Jones' book in Scheme->C 2 | 3 | (module hello 4 | (main main) 5 | (with xlib)) 6 | 7 | (define (HELLO-WORLD) 8 | (let* ((hello "Hello, World") 9 | (hi "Hi!") 10 | (dpy (let ((x (xopendisplay ""))) 11 | (if (null-pointer? x) 12 | (error 'hello-world "DISPLAY is not defined")) 13 | x)) 14 | (screen (xdefaultscreen dpy)) 15 | (background (xwhitepixel dpy screen)) 16 | (foreground (xblackpixel dpy screen)) 17 | (window (xcreatesimplewindow dpy (xdefaultrootwindow dpy) 18 | 200 300 350 250 5 foreground background)) 19 | (gc (xcreategc dpy window 0 (make-xgcvalues))) 20 | (event (make-xevent))) 21 | 22 | (xstorename dpy window 23 | "Hello, World in Scheme->C using X11's Xlib") 24 | (xseticonname dpy window "hello") 25 | (xsetbackground dpy gc background) 26 | (xsetforeground dpy gc foreground) 27 | (xselectinput dpy window 28 | (bit-or buttonpressmask keypressmask exposuremask)) 29 | (xmapraised dpy window) 30 | (let loop () 31 | (ynextevent dpy event) 32 | (cond ((eq? (xevent-type event) expose) 33 | (xdrawimagestring (xevent-xexpose-display event) 34 | (xevent-xexpose-window event) gc 50 50 35 | hello (string-length hello)) 36 | (loop)) 37 | ((eq? (xevent-type event) mappingnotify) 38 | (xrefreshkeyboardmapping event) 39 | (loop)) 40 | ((eq? (xevent-type event) buttonpress) 41 | (xdrawimagestring (xevent-xbutton-display event) 42 | (xevent-xbutton-window event) gc 43 | (xevent-xbutton-x event) (xevent-xbutton-y event) 44 | hi (string-length hi)) 45 | (loop)) 46 | ((and (eq? (xevent-type event) keypress) 47 | (equal? (ylookupstring event) "q")) 48 | (xfreegc dpy gc) 49 | (xdestroywindow dpy window) 50 | (xclosedisplay dpy)) 51 | (else (loop)))))) 52 | 53 | (define (MAIN clargs) (hello-world)) 54 | -------------------------------------------------------------------------------- /xlib/hello2.sc: -------------------------------------------------------------------------------- 1 | ;;; Hello, World example from Oliver Jones' book in Scheme->C 2 | 3 | (define (HELLO-WORLD rootx rooty) 4 | (let* ((hello "Hello, World") 5 | (hi "Hi!") 6 | (dpy (let ((x (xopendisplay ""))) 7 | (if (null-pointer? x) 8 | (error 'hello-world "DISPLAY is not defined")) 9 | x)) 10 | (screen (xdefaultscreen dpy)) 11 | (background (xwhitepixel dpy screen)) 12 | (foreground (xblackpixel dpy screen)) 13 | (window (xcreatesimplewindow dpy (xdefaultrootwindow dpy) 14 | rootx rooty 400 250 5 foreground background)) 15 | (gc (xcreategc dpy window 0 (make-xgcvalues))) 16 | (event (make-xevent)) 17 | (system-file (xconnectionnumber dpy))) 18 | 19 | (define (DISPLAY-TASK) 20 | (let loop () 21 | (ynextevent dpy event) 22 | (cond ((eq? (xevent-type event) expose) 23 | (xdrawimagestring 24 | (xevent-xexpose-display event) 25 | (xevent-xexpose-window event) gc 50 50 26 | hello (string-length hello))) 27 | ((eq? (xevent-type event) mappingnotify) 28 | (xrefreshkeyboardmapping event)) 29 | ((eq? (xevent-type event) buttonpress) 30 | (xdrawimagestring 31 | (xevent-xbutton-display event) 32 | (xevent-xbutton-window event) gc 33 | (xevent-xbutton-x event) 34 | (xevent-xbutton-y event) 35 | hi (string-length hi))) 36 | ((and (eq? (xevent-type event) keypress) 37 | (equal? (ylookupstring event) "q")) 38 | (xfreegc dpy gc) 39 | (xdestroywindow dpy window) 40 | (xflush dpy) 41 | (define-system-file-task system-file #f #f) 42 | (set! system-file #f))) 43 | (unless (zero? (xeventsqueued dpy queuedafterreading)) 44 | (loop)))) 45 | 46 | (xstorename dpy window 47 | "Hello, World in Scheme->C using X11's Xlib") 48 | (xseticonname dpy window "hello") 49 | (xsetbackground dpy gc background) 50 | (xsetforeground dpy gc foreground) 51 | (xselectinput dpy window 52 | (bit-or buttonpressmask keypressmask exposuremask)) 53 | (xmapraised dpy window) 54 | (define-system-file-task system-file (lambda () (xflush dpy)) 55 | display-task) 56 | system-file)) 57 | 58 | (define (TEST) 59 | (hello-world 100 100) 60 | (hello-world 400 400) 61 | (hello-world 400 100) 62 | (enable-system-file-tasks #t)) 63 | -------------------------------------------------------------------------------- /xlib/makefile-example: -------------------------------------------------------------------------------- 1 | all: clear hello npuzzle puzzle 2 | 3 | S2CC=s2cc 4 | S2CDIR=/usr/lib/scheme2c 5 | S2C_LIBES=$(S2CDIR)/libs2cxl.a -lX11 6 | 7 | %: %.sc 8 | $(S2CC) -o $@ $< $(S2C_LIBES) 9 | -------------------------------------------------------------------------------- /xlib/xlib.sc: -------------------------------------------------------------------------------- 1 | (module xlib 2 | (with 3 | depth 4 | screen 5 | visual 6 | xarc 7 | xchar2b 8 | xcharstruct 9 | xclasshint 10 | xcolor 11 | xcomposestatus 12 | xevent 13 | xfontprop 14 | xfontstruct 15 | xgcvalues 16 | xhostaddress 17 | xiconsize 18 | ximage 19 | xkeyboardcontrol 20 | xkeyboardstate 21 | xlibCONSTANTS 22 | xlibTYPES 23 | xlibSTUBS 24 | xmodifierkeymap 25 | xpixmapformatvalues 26 | xpoint 27 | xrectangle 28 | xrmoptiondescrec 29 | xrmvalue 30 | xsegment 31 | xsetwindowattributes 32 | xsizehints 33 | xstandardcolormap 34 | xtextitem 35 | xtextitem16 36 | xtextproperty 37 | xtimecoord 38 | xvisualinfo 39 | xwindowattributes 40 | xwindowchanges 41 | xwmhints 42 | xws10 43 | xws2 44 | xws3 45 | xws4 46 | xws5 47 | xws6 48 | xws7 49 | xws8 50 | xws9 51 | xwsr4 52 | xwss 53 | )) 54 | -------------------------------------------------------------------------------- /xlib/xws2.cdecl: -------------------------------------------------------------------------------- 1 | ;;; Display functions 2 | 3 | ;;; 2.1 Opening the Display 4 | 5 | (extern DisplayP "XOpenDisplay" (string display)) 6 | 7 | ;;; 2.2.1 Display Macros 8 | 9 | (extern long "XAllPlanes") 10 | 11 | (extern long "XBlackPixel" (DisplayP dpy) (int scr)) 12 | 13 | (extern long "XWhitePixel" (DisplayP dpy) (int scr)) 14 | 15 | (extern int "XConnectionNumber" (DisplayP dpy)) 16 | 17 | (extern Colormap "XDefaultColormap" (DisplayP dpy) (int scr)) 18 | 19 | (extern int "XDefaultDepth" (DisplayP dpy) (int scr)) 20 | 21 | (extern GC "XDefaultGC" (DisplayP dpy) (int scr)) 22 | 23 | (extern Window "XDefaultRootWindow" (DisplayP dpy)) 24 | 25 | (extern ScreenP "XDefaultScreenOfDisplay" (DisplayP dpy)) 26 | 27 | (extern ScreenP "XScreenOfDisplay" (DisplayP dpy) (int scr)) 28 | 29 | (extern int "XDefaultScreen" (DisplayP dpy)) 30 | 31 | (extern VisualP "XDefaultVisual" (DisplayP dpy) (int scr)) 32 | 33 | (extern int "XDisplayCells" (DisplayP dpy) (int scr)) 34 | 35 | (extern int "XDisplayPlanes" (DisplayP dpy) (int scr)) 36 | 37 | (extern string "XDisplayString" (DisplayP dpy)) 38 | 39 | (extern long "XLastKnownRequestProcessed" (DisplayP dpy)) 40 | 41 | (extern long "XNextRequest" (DisplayP dpy)) 42 | 43 | (extern int "XProtocolVersion" (DisplayP dpy)) 44 | 45 | (extern int "XProtocolRevision" (DisplayP dpy)) 46 | 47 | (extern int "XQLength" (DisplayP dpy)) 48 | 49 | (extern Window "XRootWindow" (DisplayP dpy) (int scr)) 50 | 51 | (extern int "XScreenCount" (DisplayP dpy)) 52 | 53 | (extern string "XServerVendor" (DisplayP dpy)) 54 | 55 | (extern int "XVendorRelease" (DisplayP dpy)) 56 | 57 | ;;; 2.2.2 Image Format Macros 58 | 59 | (extern int "XImageByteOrder" (DisplayP dpy)) 60 | 61 | (extern int "XBitmapUnit" (DisplayP dpy)) 62 | 63 | (extern int "XBitmapBitOrder" (DisplayP dpy)) 64 | 65 | (extern int "XBitmapPad" (DisplayP dpy)) 66 | 67 | (extern int "XDisplayHeight" (DisplayP dpy) (int scr)) 68 | 69 | (extern int "XDisplayHeightMM" (DisplayP dpy) (int scr)) 70 | 71 | (extern int "XDisplayWidth" (DisplayP dpy) (int scr)) 72 | 73 | (extern int "XDisplayWidthMM" (DisplayP dpy) (int scr)) 74 | 75 | ;;; 2.2.3 Screen Information Macros 76 | 77 | (extern long "XBlackPixelOfScreen" (ScreenP s)) 78 | 79 | (extern long "XWhitePixelOfScreen" (ScreenP s)) 80 | 81 | (extern int "XCellsOfScreen" (ScreenP s)) 82 | 83 | (extern Colormap "XDefaultColormapOfScreen" (ScreenP s)) 84 | 85 | (extern int "XDefaultDepthOfScreen" (ScreenP s)) 86 | 87 | (extern GC "XDefaultGCOfScreen" (ScreenP s)) 88 | 89 | (extern VisualP "XDefaultVisualOfScreen" (ScreenP s)) 90 | 91 | (extern int "XDoesBackingStore" (ScreenP s)) 92 | 93 | (extern Bool "XDoesSaveUnders" (ScreenP s)) 94 | 95 | (extern DisplayP "XDisplayOfScreen" (ScreenP s)) 96 | 97 | (extern long "XEventMaskOfScreen" (ScreenP s)) 98 | 99 | (extern int "XWidthOfScreen" (ScreenP s)) 100 | 101 | (extern int "XHeightOfScreen" (ScreenP s)) 102 | 103 | (extern int "XWidthMMOfScreen" (ScreenP s)) 104 | 105 | (extern int "XHeightMMOfScreen" (ScreenP s)) 106 | 107 | (extern int "XMaxCmapsOfScreen" (ScreenP s)) 108 | 109 | (extern int "XMinCmapsOfScreen" (ScreenP s)) 110 | 111 | (extern int "XPlanesOfScreen" (ScreenP s)) 112 | 113 | (extern Window "XRootWindowOfScreen" (ScreenP s)) 114 | 115 | ;;; 2.3 Generating a NoOperation Protocol Request 116 | 117 | (extern void "XNoOp" (DisplayP dpy)) 118 | 119 | ;;; 2.4 Freeing Client-Created Data 120 | 121 | (extern void "XFree" (unsignedint data)) 122 | 123 | ;;; 2.5 Closing the Display 124 | 125 | (extern void "XCloseDisplay" (DisplayP dpy)) 126 | -------------------------------------------------------------------------------- /xlib/xws3.cdecl: -------------------------------------------------------------------------------- 1 | ;;; Window Functions 2 | 3 | ;;; 3.1 Visual Types 4 | 5 | (extern VisualID "XVisualIDFromVisual" (VisualP visual)) 6 | 7 | ;;; 3.3 Creating Windows 8 | 9 | (extern Window "XCreateWindow" 10 | (DisplayP dpy) 11 | (Window parent) 12 | (int x) (int y) 13 | (unsignedint width) (unsignedint height) 14 | (unsignedint borderWidth) 15 | (int depth) 16 | (unsignedint class) 17 | (VisualP visual) 18 | (unsignedlong valuemask) 19 | (XSetWindowAttributesP attributes)) 20 | 21 | (extern Window "XCreateSimpleWindow" 22 | (DisplayP dpy) 23 | (Window parent) 24 | (int x) (int y) 25 | (unsignedint width) (unsignedint height) 26 | (unsignedint borderWidth) 27 | (unsignedlong border) 28 | (unsignedlong background)) 29 | 30 | ;;; 3.4 Destroying Windows 31 | 32 | (extern void "XDestroyWindow" (DisplayP dpy) (Window w)) 33 | 34 | (extern void "XDestroySubwindows" (DisplayP dpy) (Window win)) 35 | 36 | ;;; 3.5 Mapping Windows 37 | 38 | (extern void "XMapWindow" (DisplayP dpy) (Window w)) 39 | 40 | (extern void "XMapRaised" (DisplayP dpy) (Window w)) 41 | 42 | (extern void "XMapSubwindows" (DisplayP dpy) (Window win)) 43 | 44 | ;;; 3.6 Unmapping Windows 45 | 46 | (extern void "XUnmapWindow" (DisplayP dpy) (Window w)) 47 | 48 | (extern void "XUnmapSubwindows" (DisplayP dpy) (Window win)) 49 | 50 | ;;; 3.7 Configuring Windows 51 | 52 | (extern void "XConfigureWindow" 53 | (DisplayP dpy) 54 | (Window w) 55 | (unsignedint mask) 56 | (XWindowChangesP changes)) 57 | 58 | (extern void "XMoveWindow" (DisplayP dpy) (Window w) (int x) (int y)) 59 | 60 | (extern void "XResizeWindow" 61 | (DisplayP dpy) 62 | (Window w) 63 | (unsignedint width) 64 | (unsignedint height)) 65 | 66 | (extern void "XMoveResizeWindow" 67 | (DisplayP dpy) 68 | (Window w) (int x) (int y) 69 | (unsignedint width) (unsignedint height)) 70 | 71 | (extern void "XSetWindowBorderWidth" 72 | (DisplayP dpy) 73 | (Window w) 74 | (unsignedint width)) 75 | 76 | ;;; 3.8 Changing Window Stacking Order 77 | 78 | (extern void "XRaiseWindow" (DisplayP dpy) (Window w)) 79 | 80 | (extern void "XLowerWindow" (DisplayP dpy) (Window w)) 81 | 82 | (extern void "XCirculateSubwindows" 83 | (DisplayP dpy) 84 | (Window w) 85 | (int direction)) 86 | 87 | (extern void "XCirculateSubwindowsUp" (DisplayP dpy) (Window w)) 88 | 89 | (extern void "XCirculateSubwindowsDown" (DisplayP dpy) (Window w)) 90 | 91 | (extern void "XRestackWindows" 92 | (DisplayP dpy) 93 | (unsignedAP windows) 94 | (unsigned count)) 95 | 96 | ;;; 3.9 Changing Window Attributes 97 | 98 | (extern void "XChangeWindowAttributes" 99 | (DisplayP dpy) 100 | (Window w) 101 | (unsignedlong valuemask) 102 | (XSetWindowAttributesP attributes)) 103 | 104 | (extern void "XSetWindowBackground" 105 | (DisplayP dpy) 106 | (Window w) 107 | (unsignedlong pixel)) 108 | 109 | (extern void "XSetWindowBackgroundPixmap" 110 | (DisplayP dpy) 111 | (Window w) 112 | (Pixmap pixmap)) 113 | 114 | (extern void "XSetWindowBorder" 115 | (DisplayP dpy) 116 | (Window w) 117 | (unsignedlong pixel)) 118 | 119 | (extern void "XSetWindowBorderPixmap" 120 | (DisplayP dpy) 121 | (Window w) 122 | (Pixmap pixmap)) 123 | 124 | (extern int "XTranslateCoordinates" 125 | (DisplayP dpy) 126 | (Window src_win) (Window dest_win) 127 | (int src_x) (int src_y) 128 | (out int dst_x) (out int dst_y) 129 | (out Window child)) 130 | -------------------------------------------------------------------------------- /xlib/xws4.cdecl: -------------------------------------------------------------------------------- 1 | ;;; Window Information Functions 2 | 3 | ;;; 4.1 Obtaining Window Information 4 | 5 | (extern Status "XQueryTree" 6 | (DisplayP dpy) 7 | (Window w) 8 | (out Window root) 9 | (out Window parent) 10 | (out WindowAP children) 11 | (out unsignedint nchildren)) 12 | 13 | (extern Status "XGetWindowAttributes" 14 | (DisplayP dpy) 15 | (Window w) 16 | (out XWindowAttributes att)) 17 | 18 | (extern Status "XGetGeometry" 19 | (DisplayP dpy) 20 | (Drawable d) 21 | (out Window root) 22 | (out int x) (out int y) 23 | (out unsignedint width) (out unsignedint height) 24 | (out unsignedint borderWidth) 25 | (out unsignedint depth)) 26 | 27 | (extern Bool "XQueryPointer" 28 | (DisplayP dpy) 29 | (Window w) 30 | (out Window root) (out Window child) 31 | (out int root_x) (out int root_y) 32 | (out int win_x) (out int win_y) 33 | (out unsignedint mask)) 34 | 35 | ;;; 4.2 Properties and Atoms 36 | 37 | (extern Atom "XInternAtom" 38 | (DisplayP dpy) 39 | (string name) 40 | (Bool onlyIfExists)) 41 | 42 | (extern charAP "XGetAtomName" (DisplayP dpy) (Atom atom)) 43 | 44 | ;;; 4.3 Obtaining and Changing Window Properties 45 | 46 | (extern int "XGetWindowProperty" ;;; A wrapper might be useful here 47 | (DisplayP dpy) ;;; once we see how it is used. 48 | (Window w) 49 | (Atom property) 50 | (long offset) (long length) 51 | (Bool delete) 52 | (Atom req_type) 53 | (out Atom actual_type) 54 | (out int actual_format) 55 | (out unsignedlong nitems) 56 | (out unsignedlong bytesafter) 57 | (out charAP prop)) 58 | 59 | (extern AtomAP "XListProperties" (DisplayP dpy) (Window w) (out int num_prop)) 60 | 61 | (extern void "XChangeProperty" 62 | (DisplayP dpy) 63 | (Window w) 64 | (Atom property) 65 | (Atom type) 66 | (int format) 67 | (int mode) 68 | (charAP data) 69 | (int nelements)) 70 | 71 | (extern void "XRotateWindowProperties" 72 | (DisplayP dpy) 73 | (Window w) 74 | (AtomAP properties) 75 | (int nprops) 76 | (int npositions)) 77 | 78 | (extern void "XDeleteProperty" 79 | (DisplayP dpy) 80 | (Window window) 81 | (Atom property)) 82 | 83 | ;;; 4.4 Selections 84 | 85 | (extern void "XSetSelectionOwner" 86 | (DisplayP dpy) 87 | (Atom selection) 88 | (Window owner) 89 | (Time time)) 90 | 91 | (extern Window "XGetSelectionOwner" 92 | (DisplayP dpy) 93 | (Atom selection)) 94 | 95 | (extern void "XConvertSelection" 96 | (DisplayP dpy) 97 | (Atom selection) (Atom target) 98 | (Atom property) 99 | (Window requestor) 100 | (Time time)) 101 | -------------------------------------------------------------------------------- /xlib/xws8.cdecl: -------------------------------------------------------------------------------- 1 | ;;; 8.5 Selecting Events 2 | 3 | (extern void "XSelectInput" 4 | (DisplayP dpy) 5 | (Window w) 6 | (long mask)) 7 | 8 | ;;; 8.6 Handling the Output Buffer 9 | 10 | (extern void "XFlush" 11 | (DisplayP dpy)) 12 | 13 | (extern void "XSync" 14 | (DisplayP dpy) 15 | (Bool discard)) 16 | 17 | ;;; 8.7 Event Queue Management 18 | 19 | (extern int "XEventsQueued" 20 | (DisplayP dpy) 21 | (int mode)) 22 | 23 | (extern int "XPending" 24 | (DisplayP dpy)) 25 | 26 | ;;; 8.8.1 Returning the Next Event 27 | 28 | (extern void "XNextEvent" 29 | (DisplayP dpy) 30 | (out XEvent event)) 31 | 32 | (extern void "XPeekEvent" 33 | (DisplayP dpy) 34 | (out XEvent event)) 35 | 36 | ;;; 8.8.2 Selecting Events Using a Predicate Procedure 37 | 38 | (extern void "XIfEvent" 39 | (DisplayP dpy) 40 | (out XEvent event) 41 | (BoolPROC predicate) 42 | (charP arg)) 43 | 44 | (extern Bool "XCheckIfEvent" 45 | (DisplayP dpy) 46 | (out XEvent event) 47 | (BoolPROC predicate) 48 | (charP arg)) 49 | 50 | (extern void "XPeekIfEvent" 51 | (DisplayP dpy) 52 | (out XEvent event) 53 | (BoolPROC predicate) 54 | (charP arg)) 55 | 56 | ;;; 8.8.3 Selecting Events Using a Window or Event Mask 57 | 58 | (extern void "XWindowEvent" 59 | (DisplayP dpy) 60 | (Window w) 61 | (long mask) 62 | (out XEvent event)) 63 | 64 | (extern Bool "XCheckWindowEvent" 65 | (DisplayP dpy) 66 | (Window w) 67 | (long mask) 68 | (out XEvent event)) 69 | 70 | (extern void "XMaskEvent" 71 | (DisplayP dpy) 72 | (long mask) 73 | (out XEvent event)) 74 | 75 | (extern Bool "XCheckMaskEvent" 76 | (DisplayP dpy) 77 | (long mask) 78 | (out XEvent event)) 79 | 80 | (extern Bool "XCheckTypedEvent" 81 | (DisplayP dpy) 82 | (int type) 83 | (out XEvent event)) 84 | 85 | (extern Bool "XCheckTypedWindowEvent" 86 | (DisplayP dpy) 87 | (Window w) 88 | (int type) 89 | (out XEvent event)) 90 | 91 | ;;; 8.9 Putting an Event Back into the Queue 92 | 93 | (extern void "XPutBackEvent" 94 | (DisplayP dpy) 95 | (XEventP event)) 96 | 97 | ;;; 8.10 Sending Events to Other Applications 98 | 99 | (extern Status "XSendEvent" 100 | (DisplayP dpy) 101 | (Window w) 102 | (Bool propagate) 103 | (long event_mask) 104 | (XEventP event)) 105 | 106 | ;;; 8.11 Getting Pointer Motion History 107 | 108 | (extern long "XDisplayMotionBufferSize" 109 | (DisplayP dpy)) 110 | 111 | (extern XTimeCoordAP "XGetMotionEvents" 112 | (DisplayP dpy) 113 | (Window w) 114 | (Time start) 115 | (Time stop) 116 | (out int nevents)) 117 | 118 | ;;; 8.12.1 Enabling or Disabling Synchronization 119 | 120 | (extern intPROC "XSetAfterFunction" 121 | (DisplayP dpy) 122 | (intPROC func)) 123 | 124 | (extern intPROC "XSynchronize" 125 | (DisplayP dpy) 126 | (int onoff)) 127 | 128 | ;;; 8.12.2 Using the Default Error Handlers 129 | 130 | (extern void "XSetErrorHandler" 131 | (intPROC handler)) 132 | 133 | (extern void "XGetErrorText" 134 | (DisplayP dpy) 135 | (int code) 136 | (out char buffer) 137 | (int nbytes)) 138 | 139 | (extern void "XGetErrorDatabaseText" 140 | (DisplayP dpy) 141 | (string name) 142 | (string type) 143 | (string defaultp) 144 | (out char buffer) 145 | (int nbytes)) 146 | 147 | (extern string "XDisplayName" 148 | (string display)) 149 | 150 | (extern void "XSetIOErrorHandler" 151 | (intPROC handler)) 152 | -------------------------------------------------------------------------------- /xlib/xws9.cdecl: -------------------------------------------------------------------------------- 1 | ;;; 9.1.1 Setting Standard Properties 2 | 3 | ;;; YSetStandardProperties is in xwss.sc 4 | 5 | ;;; 9.1.2 Setting and Getting Window Names 6 | 7 | (extern void "XStoreName" 8 | (DisplayP dpy) 9 | (Window w) 10 | (string name)) 11 | 12 | ;;; YFetchName is in xwss.sc 13 | 14 | ;;; 9.1.3 Setting and Getting Icon Names 15 | 16 | (extern void "XSetIconName" 17 | (DisplayP dpy) 18 | (Window w) 19 | (string icon_name)) 20 | 21 | ;;; YGetIconName is in xwss.sc 22 | 23 | ;;; 9.1.4 Setting the Command 24 | 25 | ;;; YSetCommand is in xwss.sc 26 | 27 | ;;; 9.1.5 Getting and Setting Window Manager Hints 28 | 29 | (extern void "XSetWMHints" 30 | (DisplayP dpy) 31 | (Window w) 32 | (XWMHintsP hints)) 33 | 34 | ;;; YGetWMHints is in xwss.sc 35 | 36 | ;;; 9.1.6 Setting and Getting Window Sizing Hints 37 | 38 | (extern void "XSetNormalHints" 39 | (DisplayP dpy) 40 | (Window w) 41 | (XSizeHintsP hints)) 42 | 43 | (extern Status "XGetNormalHints" 44 | (DisplayP dpy) 45 | (Window w) 46 | (out XSizeHints hints)) 47 | 48 | (extern void "XSetZoomHints" 49 | (DisplayP dpy) 50 | (Window w) 51 | (XSizeHintsP zhints)) 52 | 53 | (extern Status "XGetZoomHints" 54 | (DisplayP dpy) 55 | (Window w) 56 | (out XSizeHints zhints)) 57 | 58 | (extern void "XSetSizeHints" 59 | (DisplayP dpy) 60 | (Window w) 61 | (XSizeHintsP hints) 62 | (Atom property)) 63 | 64 | (extern Status "XGetSizeHints" 65 | (DisplayP dpy) 66 | (Window w) 67 | (out XSizeHints hints) 68 | (Atom property)) 69 | 70 | ;;; 9.1.7 Setting and Getting Icon Size Hints 71 | 72 | ;;; YSetIconSizes is in xwss.sc 73 | 74 | ;;; YGetIconSizes is in xwss.sc 75 | 76 | ;;; 9.1.8 Setting and Getting the Class of a Window 77 | 78 | ;;; YSetClassHint is in xwss.sc 79 | 80 | ;;; YGetClassHint is in xwss.sc 81 | 82 | ;;; 9.1.9 Setting and Getting the Transient Property 83 | 84 | (extern void "XSetTransientForHint" 85 | (DisplayP dpy) 86 | (Window w) 87 | (Window propWindow)) 88 | 89 | (extern Status "XGetTransientForHint" 90 | (DisplayP dpy) 91 | (Window w) 92 | (out Window propWindow)) 93 | 94 | ;;; 9.2.3 Getting and Setting an XStandardColormap Structure 95 | 96 | (extern Status "XGetStandardColormap" 97 | (DisplayP dpy) 98 | (Window w) 99 | (out XStandardColormap cmap) 100 | (Atom property)) 101 | 102 | (extern void "XSetStandardColormap" 103 | (DisplayP dpy) 104 | (Window w) 105 | (XStandardColormapP cmap) 106 | (Atom property)) 107 | --------------------------------------------------------------------------------