# This is a shell archive. Remove anything before this line, # then unpack it by saving it in a file and typing "sh file". # # Wrapped by Aubrey Jaffer on Thu May 28 23:28:43 1992 # # This archive contains: # README COPYING scm.1 scm.doc # MANUAL ChangeLog code.doc ANNOUNCE # scm.c time.c repl.c scl.c # sys.c eval.c subr.c sc2.c # scm.h config.h patchlvl.h Init.scm # test.scm example.scm pi.scm pi.c # makefile.unix makefile.msc makefile.bor makefile.tur # makefile.djg makefile.qc compile.amiga link.amiga # makefile.aztec makefile.ast setjump.mar setjump.h # VMSBUILD.COM VMSGCC.COM # LANG=""; export LANG PATH=/bin:/usr/bin:$PATH; export PATH echo x - README sed 's/^@//' >README <<'@EOF' This directory contains the distribution of scm4a. Scm conforms to Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Scm runs under VMS, MS-DOS, MacOS, Amiga, Atari-ST, NOS/VE, Unix and similar systems. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880. MANIFEST `README' is this file. It contains a MANIFEST, INSTALLATION INSTRUCTIONS, hints for EDITING SCHEME CODE, and a TROUBLE SHOOTING GUIDE. `COPYING' details the LACK OF WARRANTY for scm and the conditions for distributing scm. `scm.1' is the unix style man page in nroff format. `scm.doc' is the text man page generated from scm.1. `MANUAL' details feature support and enhancements to Scheme and contains a SCHEME BIBLIOGRAPHY. `ChangeLog' documents changes to the scm. `code.doc' describes the internal representations and algorithms. Also describes how to modify scm. `test.scm' is Scheme code which tests conformance with Scheme specifications. `example.scm' is Scheme code from Revised^4 Report on the Algorithmic Language Scheme which uses inexact numbers. `pi.scm' is Scheme code for computing digits of pi [type (pi 100 5)] which can be used to test the performance of scm against compiled C code [cc -o pi pi.c;time pi 100 5]. `pi.c' is C code for computing digits of pi. `makefile.unix' is the file for building scm using the `make' program. `makefile.msc' is the file for building scm on an IBM PC using Microsoft C. `makefile.qc' is the file for building scm on an IBM PC using Microsoft QuickC. `makefile.bor' is the file for building scm on an IBM PC using Borland C. `makefile.tur' is the file for building scm on an IBM PC using Turbo C. `makefile.djg' is the file for building scm on an i386 IBM PC using DJGPP (Gnu CC ported to MSDOS). `makefile.ast' is the file for building scm on a ATARI-ST using Gnu CC. `makefile.aztec' is the file for building scm on an AMIGA using Aztec C 5.2a. `compile.amiga' is the file for compiling scm on an AMIGA. `link.amiga' is the file for linking scm on an AMIGA. `VMSBUILD.COM' is the command file for building scm on a VMS machine. `VMSGCC.COM' is the command file for building scm using GCC on a VMS machine. `setjump.h' and 'setjump.mar' provide setjmp and longjmp which do not use $unwind utility on VMS. `Init.scm' is Scheme initialization code. `config.h' is a C include file containing system dependent definitions. `patchlvl.h is the patchlevel of this release. `scm.h' has the data type and external definitions of scm. `scm.c' has the top level and interrupt code. `time.c' has functions dealing with time. `repl.c' has error, read-eval-print loop, read, write and load code. `scl.c' has the code for utility functions which are not part of the IEEE Scheme spec or which are required for non-integer arithmetic. `eval.c' has the evaluator, apply, map, and foreach. `sys.c' has the code for call-with-current-continuation, opening and closing files, storage allocation and garbage collection. `subr.c' has all the rest of functions. `sc2.c' has code for procedures from R2RS and R3RS not in R4RS. INSTALLATION INSTRUCTIONS If scm is already built (compiled) skip to secton INSTALL. These #defines should be checked before compilation. The first 2 can be defined either in the Makefile or config.h. See config.h for more information. Makefile config.h note ------ ---- -------- -DIMPLINIT IMPLINIT directory and pathname where Init.scm will reside. -DFLOATS FLOATS support for inexact numerical types. On unix systems, FLOATS is automatically handled by makefile.unix. DEST directory where `make install' will put the executable. Unix only. MANDEST directory where `make install' will put the unix style manual page. Unix only. These #defines are automatically generated by various preprocessors. Scm uses them to find include files and the proper names for system functions. If a define for your system type is missing on your system, put -Dflag in the Makefile or #define flag in config.h. define note ------ -------- AZTEC_C Aztec_C 5.2a __GNUC__ Gnu CC (and DJGPP) MWC Mark Williams C on COHERENT _QC Microsoft QuickC __STDC__ ANSI C compliant __TURBOC__ Turbo C and Borland C __ZTC__ Zortech C AMIGA SAS/C 5.10 on AMIGA atarist ATARI-ST under Gnu CC GNUDOS DJGPP __GO32__ DJGPP (future?) MCH_AMIGA Aztec_c 5.2a on AMIGA MSDOS Microsoft C 5.10 and 6.00A __MSDOS__ Turbo C, Borland C, and DJGPP nosve Control Data NOS/VE SVR2 System V Revision 2. THINK_C developement environment for the Macintosh unix most Unix and similar systems and DJGPP (!?) __unix__ Gnu CC and DJGPP vms (and VMS) VAX-11 C under VMS. hp9000s800 HP RISC processor __i386__ DJGPP i386 DJGPP MULTIMAX Encore computer pyr Pyramid 9810 processor sparc SPARC processor sequent Sequent computer TO COMPILE under UNIX and similar systems: cp makefile.unix Makefile Edit Makefile to change CFLAGS, LIBS, and especially IMPLINIT. make If you want an exact number (integer) only version type make escm (`make both' makes both). Test scm scm (load "test.scm") (test-sc4) (test-cont) under VMS: Edit CONFIG.H to set desired options and IMPLINIT. Execute VMSBUILD.COM or VMSGCC.COM (for Gnu C compiler). @VMSBUILD Test scm run scm (load "test.scm") (test-sc4) (test-cont) under MSDOS: Copy the appropriate makefile to MAKEFILE: MAKEFILE.MSC for Microsoft C, MAKEFILE.BOR for Borland C, MAKEFILE.TUR for Turbo C, MAKEFILE.QC for Quick C, or MAKEFILE.DJG for DJGPP (GCC port to i386 MSDOS). COPY MAKEFILE.xxx MAKEFILE Edit MAKEFILE to set desired options and IMPLINIT. MAKE Test scm SCM (GO32 SCM for DJGPP) (load "test.scm") (test-sc4) (test-cont) under Think C 4.0 (or 4.1): Edit Config.h to set desired options and IMPLINIT. from Yasuaki Honda // honda@csl.SONY.co.jp: Make a project and add source files repl.c, time.c, scm.c, subr.c, sys.c, eval.c, scl.c, and sc2.c to it. Add libraries MacTraps, unix, ANSI to the project. The project should be segmented in the following way: ---------- repl.c scm.c subr.c sys.c sc2.c time.c ---------- MacTraps unix ---------- ANSI ---------- eval.c ---------- scl.c ---------- Choose 'Set Project Type' from 'Project' menu. Choose Application from radio buttons. Set Partition size to 600K. (The default 384K is not enough). under Aztec C 5.2a on AMIGA: Edit makefile.aztec to set desired options and IMPLINIT. make under SAS/C 5.10 on AMIGA: Edit compile.amiga to set desired options and IMPLINIT. compile.amiga INSTALL under UNIX: Edit Makefile to have appropriate destinations for scm and scm.1. make install If IMPLINIT is not correctly defined in Makefile or config.h then you will need to define the environment variable SCM_INIT_PATH to be the full pathname of Init.scm. In a csh init file (.cshrc) this is done by: setenv SCM_INIT_PATH /usr/src/scm/Init.scm In a .profile file this should be: SCM_INIT_PATH=/usr/src/scm/Init.scm; export SCM_INIT_PATH Define the environment variable SCHEME_LIBRARY_PATH to be the full pathname of the Scheme Library directory if you have one. In a csh init file (.cshrc) this is done by setenv SCHEME_LIBRARY_PATH /usr/lib/scheme/ In a .profile file this should be: SCHEME_LIBRARY_PATH=/usr/lib/scheme/; export SCHEME_LIBRARY_PATH under VMS: Put SCM.EXE, INIT.SCM, and COPYING someplace. INIT.SCM and COPYING need to be in the same directory. Either put SCM.EXE in a SYS$SYSTEM directory or, in your LOGIN.COM file, define the symbol SCHEME to be "$" appended to the full pathname of SCM.EXE. For example: SCHEME == "$DKB100:[AGJ.SCM]SCM.EXE" In your LOGIN.COM file define the environment SCM_INIT_PATH to be the full pathname of INIT.SCM. For example: DEFINE SCM_INIT_PATH DKB100:[AGJ.SCM]INIT.SCM Define SCHEME_LIBRARY_PATH to be the pathname of the Scheme Library if you have one. For example: DEFINE SCHEME_LIBRARY_PATH DKB100:[AGJ.SLIB] under MSDOS: If you are using DJGPP do: STRIP SCM.32 COPY /B C:\DJGPP\BIN\STUB.EXE+SCM.32 SCM.EXE Put SCM.EXE, INIT.SCM, and COPYING someplace. INIT.SCM and COPYING need to be in the same directory. SCM.EXE needs to be in your search path. In AUTOEXEC.BAT define the environment variable SCM_INIT_PATH to be the full pathname of INIT.SCM. For example: SET SCM_INIT_PATH=G:\AGJ\SCM\INIT.SCM In AUTOEXEC.BAT define the environment variable SCHEME_LIBRARY_PATH to be the full pathname of the Scheme Library directory if you have one. For example: SET SCHEME_LIBRARY_PATH=G:\AGJ\SLIB\ EDITING SCHEME CODE under Gnu Emacs: Editing of Scheme code is supported by emacs. Buffers holding files ending in .scm are automatically put into scheme-mode. However, the run-scheme (`xscheme.el') which comes included with Gnu Emacs will work only with MIT Cscheme. If your Emacs can run a process in a buffer you can use the run-scheme command with SCM when you get the emacs packages `cmuscheme.el' and `comint.el'. Otherwise, see "under other systems" below. under Epsilon (MSDOS): There is lisp (and scheme) mode available by use of the package `LISP.E'. It offers several different indentation formats. With this package, buffers holding files ending in .L, .LSP, .S, and .SCM (my modification) are automatically put into lisp-mode. It is possible to run a process in a buffer under Epsilon. However, memory available to the process is limited and episodes of file system damage when doing this have occured. See "under other systems" below. under other systems: Define the environment variable "EDITOR" to be the name of the editor you use. The SCM procedure (ed arg1 ...) will then invoke that editor and return to SCM when you exit the editor. I find the following definition very convenient: (define (e) (ed "work.scm") (load "work.scm")) Invoking (e) will then put me into the editor with the file I am working on and load this file after I have changed it. TROUBLE SHOOTING Compiling: FILE ERROR or WARNING HOW TO FIX *.c include file not found Correct status of STDC_HEADERS fix #include statement or add #define for system type to config.h scm.c assignment between incompatible types change SIGRETTYPE in scm.c time.c CLK_TCK redefined incompatablility between and . remove STDC_HEADERS in config.h edit to remove incompatability. sys.c statement not reached ignore constant in conditional expression ignore scl.c syntax error define system type in config.h and scl.c (softtype) Linking: ERROR or WARNING HOW TO FIX _sin etc. missing. uncomment LIBS in makefile Running: PROBLEM HOW TO FIX Opening message and then machine Change memory model option crashes. to C compiler (or makefile). Make sure sizet definition is correct in config.h Reduce size of HEAP_SEG_SIZE in config.h ERROR: Could not allocate ... Check sizet definition. Get more memory. Don't try to run as subproccess @... in config.h and recompile scm Do it and recompile files. ERROR: Init.scm not found Assign correct IMPLINIT in makefile or config.scm or define environment variable SCM_INIT_PATH to be the full pathname of Init.scm (see INSTALLATION instructions). WARNING: require.scm not found define environment variable SCHEME_LIBRARY_PATH to be the full pathname of the scheme library or change library-vicinity in Init.scm to point to library or remove. Testing: (load "test.scm") or (load "pi.scm") (pi 100 5) Runs some and then machine crashes. See above under machine crashes. Runs some and then ERROR: ... Remove optimization option (after a GC has happened) to C compiler and recompile. #define SHORT_ALIGN in config.h Some symbol names print incorrectly. Change memory model option to C compiler (or makefile). Check that HEAP_SEG_SIZE fits within sizet. Increase size of HEAP_SEG_SIZE (or INIT_HEAP_SIZE if it is smaller than HEAP_SEG_SIZE). ERROR: Rogue pointer in Heap. See above under machine crashes. Newline or other characters don't Check character defines in print correctly. config.h Newlines don't appear correctly in Check file mode #define OPEN_... output files. in config.h Spaces or control characters appear Check character defines in in symbol names config.h Negative numbers turn positive. Check SRS in config.h VMS: Couldn't unwind stack #define CHEAP_CONTIUATIONS VAX: botched longjmp in config.h @EOF chmod 666 README echo x - COPYING cat >COPYING <<'@EOF' GNU GENERAL PUBLIC LICENSE ************************** Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble ======== The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software---to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 1. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 2. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 3. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: * cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and * cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). * If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. * You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 4. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: * accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, * accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, * accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 5. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 6. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 7. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 8. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 9. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 10. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 11. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs ======================================================= If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. ONE LINE TO GIVE THE PROGRAM'S NAME AND A BRIEF IDEA OF WHAT IT DOES. Copyright (C) 19YY NAME OF AUTHOR This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19YY NAME OF AUTHOR Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items---whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. SIGNATURE OF TY COON, 1 April 1989 Ty Coon, President of Vice That's all there is to it! @EOF chmod 666 COPYING echo x - scm.1 sed 's/^@//' >scm.1 <<'@EOF' @.\" dummy line @.TH SCM "14 July 1991" @.UC 4 @.SH NAME scm \- a Scheme Language Interpreter @.SH SYNOPSIS @.B scm [arg ...] @.br @.SH DESCRIPTION @.I Scm is an interactive Scheme interpreter. @.PP If ScmInit.scm exists in (getenv "HOME") directory then it is loaded; otherwise, each arg is given to LOAD in the order specified. @.I Scm then evaluates and prints all expressions typed into it. @.PP Here are some of @.I scm's features: @.PP Runs under Amiga, Atari-ST, MacOS, MS-DOS, NOS/VE, VMS, Unix and similar systems. @.PP Conforms to Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. @.PP Enchancements to support files open for simultaneous reading and writing. @.PP Setable levels of monitoring and timing information printed interactively (the `verbose' function). @.PP User definable responses to interrupts and errors. @.PP open-pipe, close-pipe, open-file, close-file, file-exists?, force-output, chdir, alarm, system, quit, program-arguments, getenv, tmpnam, software-type, ed, abort, line-number, get-decoded-time, get-internal-run-time, get-internal-real-time, substring-move-left!, substring-move-right!, substring-fill!, object-hash, object-unhash, delete-file, rename-file, and try-load functions. @.PP *Features* and *load-pathname* variables. @.PP char-code-limit, most-positive-fixnum, most-negative-fixnum, and internal-time-units-per-second constants. @.PP Support for ASCII and EBCDIC character sets. @.PP Documentation on the internal representation and how to extend or include scm in other programs (code.doc in the source directory). @.SH AUTHOR Aubrey Jaffer @.br (jaffer@ai.mit.edu) @.SH BUGS Integers larger than 30 bits are not supported. @.SH SEE ALSO The Scheme specifications for details on specific procedures (altorf.ai.mit.edu:archive/scheme-reports/) or @.PP IEEE Std 1178-1990, @.br IEEE Standard for the Scheme Programming Language, @.br Institute of Electrical and Electronic Engineers, Inc., @.br New York, NY, 1991 @.PP R. Kent Dybvig, The Scheme Programming Language, @.br Prentice-Hall Inc, Englewood Cliffs, New Jersey 07632, USA @.PP H. Abelson, G. J. Sussman, and J. Sussman, @.br Structure and Interpretation of Computer Programs, @.br The MIT Press, Cambridge, Massachusetts, USA @.PP Enchancements in @.I scm not in the standards are detailed in MANUAL in the source directory. @EOF chmod 666 scm.1 echo x - scm.doc cat >scm.doc <<'@EOF' SCM(14 July 1991) UNIX Programmer's Manual SCM(14 July 1991) NAME scm - a Scheme Language Interpreter SYNOPSIS scm [arg ...] DESCRIPTION _S_c_m is an interactive Scheme interpreter. If ScmInit.scm exists in (getenv "HOME") directory then it is loaded; otherwise, each arg is given to LOAD in the order specified. _S_c_m then evaluates and prints all expressions typed into it. Here are some of _s_c_m'_s features: Runs under Amiga, Atari-ST, MacOS, MS-DOS, NOS/VE, VMS, Unix and similar systems. Conforms to Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Enchancements to support files open for simultaneous reading and writing. Setable levels of monitoring and timing information printed interactively (the `verbose' function). User definable responses to interrupts and errors. open-pipe, close-pipe, open-file, close-file, file-exists?, force-output, chdir, alarm, system, quit, program-arguments, getenv, tmpnam, software-type, ed, abort, line-number, get- decoded-time, get-internal-run-time, get-internal-real-time, substring-move-left!, substring-move-right!, substring- fill!, object-hash, object-unhash, delete-file, rename-file, and try-load functions. *Features* and *load-pathname* variables. char-code-limit, most-positive-fixnum, most-negative-fixnum, and internal-time-units-per-second constants. Support for ASCII and EBCDIC character sets. Documentation on the internal representation and how to extend or include scm in other programs (code.doc in the source directory). AUTHOR Aubrey Jaffer (jaffer@ai.mit.edu) Printed 4/5/92 1 SCM(14 July 1991) UNIX Programmer's Manual SCM(14 July 1991) BUGS Integers larger than 30 bits are not supported. SEE ALSO The Scheme specifications for details on specific procedures (altorf.ai.mit.edu:archive/scheme-reports/) or IEEE Std 1178-1990, IEEE Standard for the Scheme Programming Language, Institute of Electrical and Electronic Engineers, Inc., New York, NY, 1991 R. Kent Dybvig, The Scheme Programming Language, Prentice-Hall Inc, Englewood Cliffs, New Jersey 07632, USA H. Abelson, G. J. Sussman, and J. Sussman, Structure and Interpretation of Computer Programs, The MIT Press, Cambridge, Massachusetts, USA Enchancements in _s_c_m not in the standards are detailed in MANUAL in the source directory. Printed 4/5/92 2 @EOF chmod 666 scm.doc echo x - MANUAL cat >MANUAL <<'@EOF' "MANUAL", manual for scm. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. See the file `COPYING' for terms applying to this program Scm conforms to Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178 specification (see BIBLIOGRAPHY at end). All the required features of these specifications are supported. Some of the optional features are supported as well. Integers use 2 bits less than the long integer type of the host machine. OPTIONAL Revised^4 FEATURES SUPPORTED BY SCM (if ) let* do (let ) All varieties of define list-tail string-copy, string-fill! (make-vector k fill) vector-fill! (apply proc arg1 ... args) of more than 2 arguments exp, log, sin, cos, tan, asin, acos, atan, sqrt, expt make-rectangular, make-polar, real-part, imag-part magnitude, angle exact->inexact, inexact->exact delay, force with-input-from-file, with-output-to-file transcript-on, transcript-off OPTIONAL Revised^4 FEATURES NOT SUPPORTED BY SCM (- z1 z2 ...) and (/ z1 z2 ...) of more than 2 arguments numerator denominator rationalize char-ready? Macros Scm has features not required by the IEEE and Revised^4 specifications: ENHANCEMENTS To start scm type: `scm [arg1] [arg2] ...'. Scm is started up and the file Init.scm in the implementation directory is loaded. The distribution version of Init.scm checks to see if there is file "ScmInit.scm" in path specified by the environment variable "HOME" or in the current directory. If there is such a file it is loaded. Otherwise each argument is given as an arguement to LOAD in the order specified. Scm will then evaluate and print all expressions typed into it. If arguments are given, verbose mode will initially be off; if not, verbose mode will initially be on. This can of course be overridden in the init files. Typing the end-of-file character at top level exits from scm. Typing the interrupt character aborts evaluation of the current form and resumes the top level read-eval-print loop. (quit) procedure (quit ) procedure Exits from scm returning error code to the system. The argument may be omitted in which case the default is 0. (error ...) procedure Outputs an error message containing the arguments, aborts evaluation of the current form and resumes the top level read-eval-print loop. Error is defined in Init.scm; change it to suit you. errobj variable If scm encounters a non-fatal error it aborts evaluation of the current form, prints a message explaining the error, and resumes the top level read-eval-print loop. The value of `errobj' is the offending object if appropriate. errobj is not set from calls to the error function. (abort) procedure Resumes the top level Read-Eval-Print loop. (alarm ) procedure Returns the number of seconds remaining till the next alarm interrupt. If is 0, any alarm request is canceled. Otherwise an ALARM-INTERRUPT will be signaled from the current time. ALARM is not supported on all systems. (define (user-interrupt) ...) user procedure (define (alarm-interrupt) ...) user procedure Establishes a response for SIGINT (control-C interrupt) and SIGALRM interrupts. Program execution will resume if the handler returns. This procedure should (abort) or some other action which does not return if it does not want processing to continue after it returns. Interrupt handlers are disabled during execution SYSTEM and ED procedures. To unestablish a response for an interrupt set the handler symbol to #f. For instance, (set! user-interrupt #f). (define (out-of-storage) ...) user procedure (define (could-not-open) ...) user procedure (define (end-of-program) ...) user procedure (define (hang-up) ...) user procedure (define (arithmetic-error) ...) user procedure Establishes a response for storage allocation error, file opening error, end of program, SIGHUP (hang up interrupt) and arithmetic errors respectively. This procedure should (abort) or some other action which does not return if it does not want the default error message to also be displayed. If no procedure is defined for HANG-UP then END-OF-PROGRAM (if defined) will be called. To unestablish a response for an error set the handler symbol to #f. For instance, (set! could-not-open #f). (set-errno! ) procedure Sets the system variable `errno' to . (set-errno! 0) will clear outstanding errors. This is recommended after try-load returns #f since this occurs when the file could not be opened. (perror ) procedure Prints on standard error output the argument , a colon, followed by a space, the error message corresponding to the current value of errno and a newline. The value returned is unspecified. (verbose ) procedure Controls how much monitoring information is printed. If is 0 no information is printed. If is 1 the elapsed time is printed after each top level form evaluated. If is 2 elapsed time and messages about heap growth are printed. If is 3 elapsed time, heap growth, and garbage collection (see gc) messages are printed. (gc) procedure Scans all of scm objects and reclaims for further use those that are no longer accessible. (terms) procedure This command displays the GNU General Public License. (list-file "") procedure Displays the text contents of . (system " ...") procedure Executes the on the computer and returns the integer status code. (ed "") procedure (vms-debug) procedure If scm is compiled under VMS these commands will invoke the editor or debugger respectively. (program-arguments) procedure Returns a list of strings of the arguments scm was called with. (getenv ) procedure Looks up , a string, in the program environment. If is found a string of its value is returned. Otherwise, #f is returned. (tmpnam) procedure Returns a pathname for a file which will likely not be used by any other process. Successive calls to (tmpnam) will return different pathnames. (software-type) procedure Returns a symbol for the type of operating system scm is running on. char-code-limit constant Is an integer 1 larger that the largest value which can be returned by char->integer. most-positive-fixnum constant Is the Immediate integer closest to positive infinity. most-negative-fixnum constant Is the Immediate integer closest to negative infinity. internal-time-units-per-second constant Is the integer number of internal time units in a second. (get-internal-run-time) procedure Returns the integer run time in internal time units from an unspecified starting time. The difference of two calls to get-internal-run-time divided by interal-time-units-per-second will give elapsed run time in seconds. (get-internal-real-time) procedure Returns the integer time in internal time units from an unspecified starting time. The difference of two calls to get-internal-real-time divided by interal-time-units-per-second will give elapsed real time in seconds. (get-decoded-time) procedure Returns a vector of integers: seconds, minutes, hours since midnight, day of month, month, year, day of week, day of year, and nonzero implies daylight savings for the local time. (get-universal-time) procedure The number of seconds since 00:00:00 Jan 1, 1970 GMT is returned. When SCM has bignums this will be the time since 1900 GMT. (decode-universal-time time) procedure Converts time to a vector of integers: seconds, minutes, hours since midnight, day of month, month, year, day of week, day of year, and nonzero implies daylight savings. (string-set-length! string length) procedure (vector-set-length! vector length) procedure Change the length of the first argument to the second. If this shortens the object then the remaining contents are lost. If it enlarges the object the the contents of the extended part are undefined but the original part is unchanged. It is an error to change the length of literal datums. VICINITY A vicinity is a descriptor for a place in the file system. Vicinities hide from the programmer the concepts of host, volume, directory, and version. Vicinities express only the concept of a file environment where a file name can be resolved to a file in a system independent manner. Vicinities can even be used on `flat' file systems (which have no directory structure) by having the vicinity express constraints on the file name. On most systems a vicinity would be a string. All of these procedures are file system dependent. NOTE: a more complete implementation of VICINITY is in the Scheme Library. (program-vicinity) procedure Returns the vicinity of the currently loading Scheme code. For an interpreter this would be the directory containing source code. For a compiled system (with multiple files) this would be the directory where the object or executable files are. If no file is currently loading it the result is undefined. (library-vicinity) procedure Returns the vicinity of the shared Scheme library. (implementation-vicinity) procedure Returns the vicinity of the underlying Scheme implementation. This vicinity will likely contain startup code and messages and a compiler. (in-vicinity ) procedure Returns a filename suitable for use by load, open-input-file, open-output-file, etc. The returned filename is in . For most systems in-vicinity is string-append. (try-load ) procedure Filename should be a string. If filename names an existing file, the try-load procedure reads Scheme source code expressions and definintions from the file and evaluates them sequentially and returns #t. If not, try-load returns #f. The try-load procedure does not affect the values returned by current-input-port and current-output-port. *load-pathname* variable Is set to the pathname given as argument to load try-load. (line-number) procedure Returns the current line number of the file currently being loaded. *features* variable Is a list of symbols denoting features supported in this implementation. SYTAX_EXTENSIONS #. read syntax Is read as the object resulting from the evaluation of . This substitution occurs even inside quoted structure. In order to allow compiled code to work with #. it is good practice to define those symbols used inside of with #.(define ...). For example: #.(define foo 9) ==> # '(#.foo #.(+ foo foo)) ==> (9 18) #||# read syntax Is a balanced comment. Everything up to the matching |# is ignored by the reader. Nested #|...|# can occur inside . If SYNTAX_EXTENSIONS is #defined in config.h or the makefile the following syntax is also defined: (defined? ) syntax Equivalent to #t if is a syntactic keyword (such as IF) or a symbol with a top-level value. Otherwise equivalent to #f. REV2_PROCEDURES If REV2_PROCEDURES is #defined in config.h or the makefile the following functions are also defined: (substring-move-left! ) (substring-move-right! ) procedure and must be a strings, and , and must be exact integers satisfying 0 <= start1 <= end1 <= (string-length ) 0 <= start2 <= end1-start1+start2 <= (string-length ). Substring-move-left! and substring-move-right! store characters of beginning with index (inclusive) and ending with index (exclusive) into beginning with index (inclusive). Substring-move-left! stores characters in time order of increasing indeces. Substring-move-right! stores characters in time order of decreasing indeces. (substring-fill! ) procedure Substring-fill! stores character into beginning with index (inclusive) and ending with index ) procedure Returns a port capable of receiving or delivering characters as specifie by the string. If a file cannot be opened #f is returned. OPEN_READ constant OPEN_WRITE constant OPEN_BOTH constant Contain modes strings specifying that a file is to be opened for reading, writing, and both reading and writing respectively. (open-io-file ) procedure (close-io-port ) procedure These functions are analogous to the standard scheme file functions. The ports are open to in read/write mode. Both input and output functions can be used with io-ports. An end of file must be read or a file-set-position done on the port between a read operation and a write operation or vice-versa. (file-exists? ) procedure Returns #t if the specified file exists. Otherwise, returns #f. If IO_EXTENSIONS is #defined in config.h or the makefile the following functions are also defined: (open-pipe ) procedure If the string contains an "r" returns an input port capable of delivering characters from the standard output of the system command . Otherwise, returns an output port capable of receiving characters which become the standard input of the system command . If a pipe cannot be created #f is returned. (open-input-pipe ) procedure Returns an input port capable of delivering characters from the standard output of the system command . If a pipe cannot be created #f is returned. (open-output-pipe ) procedure Returns an output port capable of receiving characters which become the standard input of the system command . If a pipe cannot be created #f is returned. (close-pipe ) procedure Closes the , rendering it incapable of delivering or accepting characters. This routine has no effect if the pipe has already been closed. The value returned is unspecified. (file-position ) procedure Returns the current position of the character in which will next be read or written. If is not open to a file the result is unspecified. (file-set-position ) procedure Sets the current position in which will next be read or written. If is not open to a file the action of file-set-position is unspecified. The result of file-set-position is unspecified. (force-output) procedure (force-output ) procedure Forces any pending output on to be delivered to the output device and returns an unspecified value. The argument may be omitted, in which case it defaults to the value returned by CURRENT-OUTPUT-PORT. (read-string! ) procedure (read-string! ) procedure Reads (string-length ) characters from . If an end of file is encountered during read-string! the characters up to that point only are put into string (starting at the beginning) and the remainder of the string is unchanged. Read-string! returns the number of characters read. may be omitted, in which case it defaults to the value returned by current-input-port. (chdir ) procedure Changes the current directory to . If does not exist or is not a directory, #f is returned. Otherwise, #t is returned. (delete-file ) procedure Deletes the file specified by . If can not be deleted, #f is returned. Otherwise, #t is returned. (rename-file ) procedure Renames the file specified by to . If the renaming is successful, #t is returned. Otherwise, #f is returned. PROCESS SYNCHRONIZATION (make-arbiter ) procedure Returns an oject of type arbiter and name . Its state is initially unlocked. (try-arbiter ) procedure Returns #t and locks if was unlocked. Otherwise, returns #f. (release-arbiter ) procedure Returns #t and unlocks if was locked. Otherwise, returns #f. SCHEME BIBLIOGRAPHY Revised^4 Report on the Algorithmic Language Scheme can be obtained via anonymous ftp from: altorf.ai.mit.edu:archive/scheme-reports/ IEEE Std 1178-1990, IEEE Standard for the Scheme Programming Language, Institute of Electrical and Electronic Engineers, Inc., New York, NY, 1991 Two books about Scheme are: R. Kent Dybvig, The Scheme Programming Language, Prentice-Hall Inc, Englewood Cliffs, New Jersey 07632, USA H. Abelson, G. J. Sussman, and J. Sussman, Structure and Interpretation of Computer Programs, The MIT Press, Cambridge, Massachusetts, USA, 1985 @EOF chmod 666 MANUAL echo x - ChangeLog sed 's/^@//' >ChangeLog <<'@EOF' Wed May 27 16:02:58 1992 Aubrey Jaffer (jaffer at Ivan) * config.h scl.c (NUMBUFLEN): split into INTBUFLEN and FLOBUFLEN and made proportional to size of numeric types. From: fred@sce.carleton.ca (Fred J Kaudel) * makefile.ast scm.c Init.scm: minor chages for ATARI ST support. * test.scm (test-inexact): created. Thu May 21 11:43:41 1992 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 5 From: hugh@ear.mit.edu (Hugh Secker-Walker) * config.h: better wording for heap allocation strategy explanation. Wed May 20 00:31:18 1992 Aubrey Jaffer (jaffer at Ivan) From S.R.Adams@ecs.southampton.ac.uk * subr.c (stci_leqp st_leqp): reversed order of ^ clauses to avoid Borland 3.0 bug. * sys.c (gc_sweep): missing i-=2; added when splicing out segment. * MANUAL time.c (get-universal-time decode-universal-time): half hearted attempt to add these. Needs bignums. Wed May 13 14:01:07 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c (gc_mark): improved tail recursivness for CONSes. * repl.c (growth_mon): now prints out the hplims table if verbose>3. * sys.c (init_heap_seg): Serious bug in growing hplims fixed. num_heap_segs eliminated; hplims are realloced whenever grown. Tue May 12 15:36:17 1992 Aubrey Jaffer (jaffer at train) * config.h sys.c (alloc_some_heap expmem): expmem captures whether the INIT_HEAP_SIZE allocation was successful. If so, alloc_some_heap uses exponential heap allocation instead of HEAP_SEG_SIZE. Mon May 11 15:29:04 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c (gc_sweep init_heap_seg heap_org): Empty heap segments are now freed. * sc2.c (STR_EXTENSIONS): renamed REV2_PROCEDURES and R2RS and R3RS functions put into sc2.c. Sun May 10 01:34:11 1992 Aubrey Jaffer (jaffer at Ivan) * scm.c (ignore_interrupts unignore_interrupts): added for system, edt$edit, and popen to use. * repl.c (lwrite display newline write_char): Close pipe if EPIPE. * repl.c (file_set_position): now errs on ESPIPE. * scm.c (SIGPIPE): now ignored (errs come back as EPIPE). Sat May 9 17:52:36 1992 Aubrey Jaffer (jaffer at Ivan) From: Stephen Adams * config.h (PROT386): PROT386 added. PTR_LT and CELL_UP modified. Fri May 8 17:57:22 1992 Aubrey Jaffer (jaffer at Ivan) From: hugh@ear.mit.edu (Hugh Secker-Walker) * Init.scm (last-pair append!): last-pair is faster version. Append! corrected for null first arg. (getenv "HOME") now gets a "/" added if not present. * config.scm (MIN_GC_YIELD): now proportional to HEAP_SEG_SIZE. * README: setting environment variables corrected. * subr.c (length): error message now has arg if not a list. * sys.c (open-pipe): now turns off interrupts before forking. * scl.c (lsystem): now turns off interrupts before forking. * scm.c (ignore_signals): created. Sat May 2 01:02:16 1992 Aubrey Jaffer (jaffer at Ivan) * Init.c (WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE): defined in terms of current-input-port and current-output-port. Bug in open-input-pipe and open-output-pipe fixed. * sys.c repl.c (current-input-port current-output-port): moved from sys.c to repl.c. set-current-input-port and set-current-output-port added to repl.c. Mon Apr 13 22:51:32 1992 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h: (PATCHLEVEL): released scm4a1. * makefile.* VMSBUILD.COM VMSGCC.COM: compile time.h. * scm.c (alrm_signal int_signal): now save and restore errno so SYSCALL will work correctly across interrupts. Sun Apr 12 01:44:10 1992 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h: (PATCHLEVEL): released scm4a0. * repl.c (lread): tok_buf now local to each invocation of read. This makes READ interruptable and reentrant. * sys.c MANUAL (STRING-SET-LENGTH! STRING-VECTOR-LENGTH!): created. * sys.c repl.c (grow_tok_buf tok_buf tok_buf_len): moved to repl.c * repl.c (lfwrite): now emulated for VMS. * repl.c scl.c (num_buf): now local to all routines that use it. * time.h: created by moving time functions from repl.c. Read and write functions were moved from sys.c to repl.c. * sys.c repl.c (DEFER_INTS ALLOW_INTS CHECK_INTS): totally rewritten. SIGALRM and SIGINT now execute at interrupt level. Interrupts deferred only for protected code sections, not for reads and writes. * sys.c repl.c (SYSCALL): created to reexecute system calls interrupted (EINTR) by SIGALRM and SIGINT. * sys.c scl.c (flo0): 0.0 is now always flo0. * repl.c sys.c (TRANSCRIPT-ON TRANSCRIPT-OFF): added. This required shadowing putc, fputs, fwrite, and getc with lputc, lputs, lfwrite, and lgetc. Sun Apr 5 00:27:33 1992 Aubrey Jaffer (jaffer at Ivan) From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden) * scl.c (eqp lessp greaterp lesseqp greatereqp): Comparisons with inexact numbers was not being performed correctly. For example, (< 1.0 2.0 1.5) would yield #t. What was missing was a line x=y; in the inexact comparison sections of lessp(), greaterp(), lesseqp() and greatereqp(). In addition, I modified these routines and eqp() to allow for mixed arithmetic types. Sat Apr 4 00:17:29 1992 Aubrey Jaffer (jaffer at Ivan) * scm.h code.doc: tc7_bignum => tc7_spare. Added tc16_bigpos and tc16_bigneg. SMOBS reordered. tc16_record added. * scm.h repl.c sys.c (make-arbiter try-arbiter release-arbiter): added. tc16_arbiter added. Fri Apr 3 01:25:35 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c config.h (TEMPTEMPLATE): created in config.h. * scm.h: removed long aliases for C versions of Scheme functions. * sys.c eval.c scm.h: (delay force makprom): added. Also added tc16_promise data type. * Init.scm (trace untrace): added autoloads and read macros. From: T. Kurt Bond, tkb@mtnet2.wvnet.edu * sys.c (template): correct template for VMS. Tue Mar 31 01:50:12 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c config.h Init.scm (open-file open-pipe): created and expressed other open functions in terms of. Bracketed all i/o system calls with DEFER and ALLOW _SIGINTS. Sat Mar 28 00:24:01 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c MANUAL (#.): read macro syntax added. Balanced comments also documented. Fri Mar 27 22:53:26 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c (iprin1): changed printed representation for unreadable objects from #[...] to #<...>. From: brh@aquila.ahse.cdc.com (brian r hanson x6009): * scm.h config.h (NCELLP PTR_LT): fixes for 64 bit pointers on nosve. Fri Mar 20 01:36:08 1992 Aubrey Jaffer (jaffer at Ivan) * Released scm3c13 * code.doc: corrected some minor inconsistencies and added a section "To add a package of new procedures to scm". Sun Mar 15 19:44:45 1992 Aubrey Jaffer (jaffer at Ivan) * Init.scm: now loads _INIT_PATH when is not "SCM". * config.h (PTR_LT): (x < y) => ((x) < (y)) Wed Mar 4 01:53:15 1992 Aubrey Jaffer (jaffer at Ivan) * Released scm3c12. * scm.h code.doc eval.c sys.c (IXSYM): Eliminated Immediate IXSYM type. Tue Mar 3 00:58:18 1992 Aubrey Jaffer (jaffer at Ivan) * eval.c config.c (ceval DEFINED? SYNTAX_EXTENSIONS): added DEFINED? to ceval conditional on SYNTAX_EXTENSIONS. From: Andrew Wilcox * makefile.unix scm.c (main init_scm display_banner init_signals restore_signals run_scm): RTL support. Mon Mar 2 19:05:29 1992 Aubrey Jaffer (jaffer at Ivan) * subr.c (make-string): now checks for ARG1 >= 0. Fri Feb 28 00:13:00 1992 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 12 * Init.scm: loads JCAL if scm is invoked with name JCAL, JACAL, jcal or jacal. * Init.scm (ABS): set to MAGNITUDE if FLOATS are supported. * gc_mark gc: no longer assume sizeof(short) == 2. * config.h (CELL_UP CELL_DN): no longer assume sizeof(CELL) == 8. From: Brian Hanson, Control Data Corporation. brh@ahse.cdc.com * scl.c config.h repl.c: partial port to Control Data NOS/VE. From: fred@sce.carleton.ca (Fred J Kaudel) * repl.c Init.scm makefile.ast: Port to Atari-ST * sys.c scm.h eval.c (throw): renamed to lthrow to avoid conflict with Gnu CC. Mon Feb 10 14:31:24 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c (delete-file rename-file): added. * sys.c (chdir): now returns #f instead of error. * Init.scm: Calls to PROVIDED? inlined so no longer dependent on SLIB being loaded. (set! ABS MAGNITUDE) if inexacts supported. Support for slib1b3 added. * sys.c (alloc_some_heap): fixed bugs. One fix from bowles@is.s.u-tokyo.ac.jp. * eval.c (ceval): fixed bug with internal (define foo bar) where bar is a global. Put badfun2: back in for better error reporting. * patchlvl.h (PATCHLEVEL): 11 Mon Jan 20 16:19:04 1992 Aubrey Jaffer (jaffer at Ivan) * config.c (INITS): comments added. From: T. Kurt Bond, tkb@mtnet2.wvnet.edu * VMSGCC.COM VMSMAKE.COM: now take arguments. From: "Fred Bayer" * makefile.aztec repl.c: Aztec C (makefile) port. Fri Jan 17 16:36:07 1992 Aubrey Jaffer (jaffer at Ivan) * sys.c (gc init_storage stack_size): stack_size now of type sizet. init_storage no longer uses it. gc() now uses it instead of pointer to local. This fixes bug with gcc -O. * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above fix. Thu Jan 16 22:33:00 1992 Aubrey Jaffer (jaffer at Ivan) * scl.c (real-part): added. Wed Jan 15 13:06:39 1992 Aubrey Jaffer (jaffer at Ivan) From: "Fred Bayer" * scl.c repl.c scm.c config.c: Port for AMIGA * scm.h (REALP): fixed for SINGLES not defined. Sat Jan 11 20:20:40 1992 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 8 released. * README: added hints for EDITING SCHEME CODE. * repl.c (SIGRETTYPE): now int for __TURBOC__. * makefile.tur makefile.djg: created. * config.h: DJGPP (__GO32__) support added. * scm.h (memv): definition added. Sun Jan 5 00:33:44 1992 Aubrey Jaffer (jaffer at Ivan) * repl.c makefile.* (main): INITS added. * scl.c: fixed ASSERT statements with mismatched ARGn and arguments. Thu Dec 19 19:16:50 1991 Aubrey Jaffer (jaffer at train) * sys.c (cons cons2 cons2r): added fix for gcc -O bug. * repl.c (LACK_FTIME LACK_TIMES): more messing with these. * sys.c config.o (HAVE_PIPE): created. * config.h (FLT_RADIX): now #ifdef FLT_RADIX rather than __STDC__. Needed for DJGCC. * sys.c (DBLMANT_DIG DBL_FLOAT_DIG): now tested for directly rather than STDC_INCLUDES. * makefile.unix (subr.o): explicit compilation line added. * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries. Sun Dec 8 23:31:04 1991 Aubrey Jaffer (jaffer at Ivan) * eval.c (apply): added check for number of args to closures. Sat Dec 7 01:30:46 1991 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 7 * sys.c (chdir): THINK_C doesn't support; * repl.c: SVR2 needs instead of * repl.c: SVR2 needs LACK_FTIME * repl.c: #include now automatic ifndef LACK_FTIME. Mon Dec 2 15:42:11 1991 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 5 * sys.c (intern sysintern): made strings and hash unsigned. Fixed bug with characters > 128 in symbols. * scl.c (eqv? memv assv): created if FLOATS is #defined. From boopsy!mike@maccs.dcss.mcmaster.ca (Michael A. Borza). Mon Dec 2 11:37:11 1991 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 4 * sys.c (gc_sweep): usaage of pclose() now conditional on unix. * MANUAL (chdir): documented. from T. Kurt Bond, Adminisoft, Inc. : * repl.c sys.c (errno): VMS GNU C uses a special hack in to get the link-time attributes for the errno variable to match those the VMS C run-time library expects (it makes errno a preprocessor define so that the variable that the compiler sees has a special form that the assember then interprets), so if it is VMS and __GNUC__ is defined needs included. * setjump.h (SETJUMP LONGJUMP): SETJUMP and LONGJUMP changed to setjump and longjump. The VMS linker is case-indifferent. VMS GNU C mangles variable names that have upper case letters in them to preserve their uniqueness. * sys.c (iprint iprin1): Now inline putc loops instead of calls to fwrite for VMS. The VMS `fwrite' has been enhanced to work with VMS's Record Management Sevice, RMS. Part of this enhancement is to treat each call to `fwrite' as producing a seperate record. This works fine if you are writing to a stream_LF file or an actual terminal screen, but if you are writing to a file that has implied carriage control (such as a batch log file, or a mailbox used for subprocess communication), which is a more common file organization for RMS, each call to `fwrite' has a newline appended to it. This causes much of the output to be incorrectly split across lines. * vmsgcc.com: created. Sun Dec 1 00:33:42 1991 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 3 released. * Init.scm (rev2-procedures): all now supported. * Init.scm sys.c MANUAL (flush): flush changed to force-output to be compatible with Common Lisp. * sys.c (chdir): added. Wed Nov 27 09:37:20 1991 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 2 * repl.c (set-errno! perror): added. * sys.c (gc): FLUSH_REGISTER_WINDOWS call added. * sys.c (open-input-pipe open-output-pipe close-pipe): added. Mon Nov 25 13:02:13 1991 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 1 * sys.c (flush): added. * repl.c (mytime): macro was missing (). CLKTCK now defaults to 60. * README Init.scm subr.c scm.c repl.c scl.c: From Yasuaki Honda, honda@csl.SONY.co.jp, support for Macintosh running Think C. Sun Nov 24 15:30:51 1991 Aubrey Jaffer (jaffer at Ivan) * scl.c (str2flo): fixed parsing of -1-i. * repl.c (repl_driver): from jjc@jclark.com, now checks that s_response is non-NULL before INTERNing. * subr.c (equal): Now correct for inexacts. Need to do eqv. * scm.h (REALPART): fixed pixel C compiler bug with doubles inside `?' conditionals. * scl.c (zerop): now checks imaginary half of complex number. Tue Nov 19 00:10:59 1991 Aubrey Jaffer (jaffer at Ivan) * version scm3c0 * documentation: changed revised^3.99 to revised^4. * example.scm: created from Scheme^4 spec. * makefile.msc: -Ox changed to -Oxp to fix over-enthusiastic float optimizations. * Init.scm (ed): defined. * repl.c (def_err_response): UNDEFINED objects don't print out. Sun Nov 17 23:11:03 1991 Aubrey Jaffer (jaffer at Ivan) * scl.c (vms-debug): now returns UNSPECIFIED. * repl.c MANUAL (restart_repl): RESTART-REPL changed to ABORT. * repl.c (err_ctrl_c):now clears sig_pending. Wed Nov 13 23:51:36 1991 Aubrey Jaffer (jaffer at Ivan) * config.h: removed #ifdef sparc #define STDC_HEADERS * makefile.bor: added extra '\' to filepath. * repl.c (everr): fixed bug with ARGx. * repl.c (errmsgs def_err_response): cleaned up error messages. Sun Nov 10 23:10:24 1991 Aubrey Jaffer (jaffer at Ivan) * released scm3b7 Mon Nov 4 18:36:49 1991 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 6 * sys.c (idbl2str): tests for Not-a-Number and Infinity added. * repl.c scm.h: response system rewritten and integrated with error system. * scl.c (/): now returns inexacts if integer arguments do not divide evenly. Mon Oct 28 23:44:16 1991 Aubrey Jaffer (jaffer at Ivan) * makefile.unix: can now make float (scm) and integer-only (escm) versions in same directory. * repl.c (*sigint-response* *arithmetic-response* restart-repl): responses for signals added. * scl.c (lmin lmax sum difference product divide expt exp log): now take mixed types. expt available in non-FLOATS compilation. * repl.c (get-decoded-time): added. Includes and time functions reorganized. * sys.c (object-hash object-unhash): added. Tue Oct 15 00:45:35 1991 Aubrey Jaffer (jaffer at Ivan) * repl.c Init.scm (*features*): moved constant features into Init.scm. Moved tests for numeric features to slib/require.scm. * release scm3b1. * config.h (ANSI_INCLUDES): redid include files. * subr.c scl.c: moved all FLOAT conditionals from subr.c to scl.c. Wed Oct 9 00:28:54 1991 Aubrey Jaffer (jaffer at Ivan) * release scm3a13. * patchlvl.h (PATCHLEVEL): 13 * Init.scm: "vicinity.scm" changed to "require.scm" Mon Oct 7 00:34:07 1991 Aubrey Jaffer (jaffer at Ivan) * test.scm: test of redefining built-in symbol and extra ')' removed. * scm.doc makefile.unix: scm.doc created from scm.1 in makefile.unix. * VMSBUILD.COM setjump.asm setjump.h (setjmp longjmp jmp_buf): put in from comp.sources.reviewed in order to let VMS have full continuations. VMSBUILD.COM is a compile script. Fri Oct 4 00:05:54 1991 Aubrey Jaffer (jaffer at Ivan) * scl.c(sleep): removed; not supported by MSC (although could be written). * scm.h config.h (size_t): moved to config.h. * sys.c (f_getc): -> lgetc for vax, getc otherwise. * patchlvl.h (PATCHLEVEL): 12 Mon Sep 30 01:14:48 1991 Aubrey Jaffer (jaffer at Ivan) * scl.c(sleep): created. * repl.c(internal-time-units-per-second get=internal-run-time): created * repl.c: created from scm.c (shuffled around lots of functions). Sat Sep 28 00:22:30 1991 Aubrey Jaffer (jaffer at Ivan) * scm.c config.h (char-code-limit most-positive-fixnum most-negative-fixnum): created. Tue Sep 24 01:21:43 1991 Aubrey Jaffer (jaffer at Ivan) * scm.c (software-type); created. * scm.c config.h (terms, list-file, library-vicinity, program-vicinity, user-vicinity, make-vicinity, sub-vicinity): moved to Init.scm and library. * scm.c config.h Makefile (PROGPATH): changed to IMPLPATH. * Init.scm: created Fri Sep 20 13:22:08 1991 Aubrey Jaffer (jaffer at Ivan) * patchlvl.h (PATCHLEVEL): 5 * all: changed declarations to size_t where appropriate. scm.h test preprocessor flag _SIZE_T to determine if already declared. size_t should greatly enhance portability to Macintosh and other machines. Tue Sep 17 01:15:31 1991 Aubrey Jaffer (jaffer at Ivan) * scm.c (tmpnam): support for mktemp added. Mon Sep 16 14:06:26 1991 Aubrey Jaffer (jaffer at train) * scm.c (implementation-vicinity): added. (program-vicinity) now returns undefined if called not within a load. * sys.c (call-with-io-file): removed. * scm.c (tmpnam): added. * scm.c config.h (tmporary-vicinity): removed. Sun Sep 15 22:21:30 1991 Aubrey Jaffer (jaffer at Ivan) * subr.c scm.h (remainder): renamed to lremainder to avoid conflict with math.h on SunOS4.1 (from bevan@cs.man.ac.uk). Sat Sep 7 22:27:49 1991 Aubrey Jaffer (jaffer at Ivan) * scm.c (program-arguments load): program-arguments created. * scm.c (getenv): added getenv and used for program-vicinity and library-vicinity. * scm.c (program-vicinity): fixed if load_name is NULL. * scl.c config.h (substring-move-left! substring-move-right!): added under STR_EXTENSIONS flag. Wed Aug 28 22:59:20 1991 Aubrey Jaffer (jaffer at Ivan) * Sending scm3a to comp.sources.reviewed * scm.c (main): prints out feature list at startup. * subr.c (eqp lessp greaterp lesseqp greatereqp): now work for floats. * scl.c (sum difference divide product): moved to scl.c and now work for floats. * all: all masks with low bits explicity cast to (int). Sat Aug 17 00:39:06 1991 Aubrey Jaffer (jaffer at Ivan) * sys.c subr.c scl.c (iint2str istr2int istring2number istr2flo iflo2str idbl2str): number I/O and conversion to strings rewritten. * sys.c (gc_mark): continuations now marked SHORT_ALIGNed. (from Craig Lawson). * added QuickC support from Craig Lawson. Tue Jul 30 01:08:52 1991 Aubrey Jaffer (jaffer at Ivan) * config.h: #ifdef pyr added. * scm.c MANUAL: vicinity functions added. Tue Jul 16 00:51:23 1991 Aubrey Jaffer (jaffer at Ivan) * scl.c sys.c: float functions added. * Documentation reorganized according to comp.sources.reviewed guidelines. * sys.c config.h (open_input_file open_output_file open_rw_file): file mode string moved to defines in config.h Thu Jul 11 23:30:03 1991 Aubrey Jaffer (jaffer at Ivan) * sys.c config.h (EBCDIC ASCII) moved to config.h * subr.c config.h (BADIVSGNS) moved to config.h * scm.h config.h (SRS) moved to config.h Sun Jul 7 23:49:26 1991 Aubrey Jaffer (jaffer at Ivan) * all: started adding comp.sources.reviewed corrections and suggestions. * scm.c patchlvl.h (main): PATCHLEVEL now printed in banner. * subr.c sys.c: read_integer removed. istring2number created. lread and string2number now both use istring2number. Fri Jun 7 13:43:40 1991 Aubrey Jaffer (jaffer at Ivan) * VERSION scm2e sent to comp.sources.reviewed * public.lic: renamed COPYING. * scm.c (gc_status): gc_status renamed prolixity. Now returns old value of verbose. Can take 0 arguments. * sys.c (lreadr): added #| common lisp style |# balanced comments. * scm.h scm.c sys.c (I/O functions): combined **PORTP and OPENP to become OP**PORTP. * scm.h sys.c (gc_sweep): moved OPENP to bit in upper half word of port cells. Sat May 25 00:04:45 1991 Aubrey Jaffer (jaffer at Ivan) * scm.c (stack_start_ptr, repl_driver, main, err functions): exits removed from all err functions. all escapes through repl_driver. * scm.c README (verbose): Now has graded verbosity. * scm.c README (quit): Now takes optional argument which is return value. Wed May 22 01:40:17 1991 Aubrey Jaffer (jaffer at Ivan) * code.doc scm.h eval.c (ceval): Rearanged immediate type codes to create IXSYMs (immediate extension syms) to allow more than 15 special forms. ILOCs now work with up to 32767 in one environment frame. Dispatch is slightly faster for ILOCs in function position. ICHRs can be up to 24 bits. Fri May 10 00:16:32 1991 Aubrey Jaffer (jaffer at Ivan) * scm.h sys.c (gc_mark, gc_sweep): GCMARK moved to bit 8 of CAR for some datatypes. Wed May 1 14:11:05 1991 Aubrey Jaffer (jaffer at Ivan) * patch1 MESSAGE SENT. * sys.c (lreadr) from jclark@bugs.specialix.co.uk.jjc: removed order evaluation bug when growing tok_buf. Fri Apr 26 10:39:41 1991 Aubrey Jaffer (jaffer at Ivan) * scm2d RELEASED * sys.c (closure) no longer calls ilength (ECONS problem). Added ASSERT before call to closure in eval. Thu Apr 25 09:53:40 1991 Aubrey Jaffer (jaffer at Ivan) * scm.c (error): created. Wed Apr 24 16:58:06 1991 Aubrey Jaffer (jaffer at Ivan) * utils.scm: created. * makefile (name8s): code from dmason works in makefile. * eval.c (evalcar): fixed errobj on (else 3 4) error. Inlined function application in (cond ((foo => fun))). * sys.c (lprin1): change looped putcs to fwrite. Wed Apr 24 01:54:09 1991 Aubrey Jaffer (jaffer at Ivan) * sys.c (lreadr): fixed assert for "eof in string". * subr.c (lgcd): changed to work with borland C. * eval.c (eval): added checks to LAMBDA and LET. * eval.c (apply): now checks for null arg1 in lsubr. Fri Apr 12 00:09:03 1991 Aubrey Jaffer (jaffer at kleph) * config.h scm.h (SCMPTR): created to correct address arithmetic on stack bounds under Borland C++. Borland C++ now runs scm2c. Wed Apr 10 21:38:09 1991 Aubrey Jaffer (jaffer at Ivan) * sys.c (open_io_file, cw_io_file, file_position, file_set_pos, read_to_str) created (IO_EXTENSIONS) * config.h (IO_EXTENSIONS): defined * sys.c scm.c: lprin1f changed to iprin1 Wed Apr 10 12:58:59 1991 Aubrey Jaffer (jaffer at Ivan) * sys.c (intern): line 850: for(i = alen;0 <= --i;)changed to for(i = alen;0 < --i;). This fixed b_pos and v_pos mapping to the same symbol. Wed Apr 4 00:00:00 1991 Aubrey Jaffer (jaffer at kleph.ai.mit.edu) * released scm2b Wed Apr 3 22:51:39 1991 Aubrey Jaffer (jaffer at Ivan) * all files: eliminated types tc7_subr_2n and tc7_subr_2xn. Replaced with tc7_subr_2o and tc7_subr_1o so that all subr calls can be checked for number of arguments. Tue Apr 2 23:11:15 1991 Aubrey Jaffer (jaffer at Ivan) * code.doc: cleaned up. Mon Apr 1 14:27:22 1991 Aubrey Jaffer (jaffer at Ivan) * eval.c (ceval): fixed nasty tail recursion bug at carloop:. * scm.c (everr): still fixing error reporting. * eval.c subr.c: added flag PURE_FUNCTIONAL which removes side effect special forms and functions. * subr.c (substring): now allows first index to be equal to length of string * sys.c (lprin1f): dispatches on TYP16 of smobs. * scm.h: fixed typo in unused function defs. Mon Mar 28 00:00:00 1991 Aubrey Jaffer (jaffer at zohar.ai.mit.edu) * scm2a released: too many changes to record. See code.doc. Mon Feb 18 21:48:24 1991 Aubrey Jaffer (jaffer at foxkid) * scm.h: types reformatted (TYP6 -> TYP7). * eval.c (ceval): Now dispatch directly on ISYMs in ceval. Fri Feb 15 23:39:48 1991 Aubrey Jaffer (jaffer at foxkid) * sys.c: #include not done for VMS Wed Feb 13 17:49:33 1991 Aubrey Jaffer (jaffer at foxkid) * scm.c scl.c: added unsigned declarations to some char * definitions in order to fix characters having negative codes. * scm.h (MAKISYM, MAKFLAG, ICHR, MAKICHR, MAKINUM): Now cast to long so that their calls don't have to. Changing MAKICHR fixed problem in scl.c (string2list) on IBMPC. * subr.c (quotient): support for `/' reintroduced; required by r3.99rs but not IEEE. * subr.c (char functions): added isascii tests for char-alphabetic, char-numeric?, char-whitespace?, char-upper-case?, and char-lower-case?. Added test against char_code_limit to int2char. * subr.c (s_char_alphap): is subr_1 not lsubr. * test.scm: added tests for char-alphabetic, char-numeric?, char-whitespace?, char-upper-case?, and char-lower-case?. * sys.c: most `return;'s eliminated to reduce warning messages. Substituted breaks and reordered switch and if clauses. Sun Feb 3 23:12:34 1991 Aubrey Jaffer (jaffer at foxkid) * scm1-2: released. * sys.c (read-char peek-char) added code for EOF. * test.scm (leaf-eq?) added and file "cont.scm" removed. I/O tests added. * sys.c (I/O functions) now check for input and output ports rather than just ports. * sys.c (lprin1f): occurences of stdout changed to f. Newlines after printing port removed. Thu Jan 31 22:52:39 1991 Aubrey Jaffer (jaffer at foxkid) * subr.c (quotient): support for `/' removed; not required. * scm.c (wta): message for OUTOFRANGE fixed. Mon Jan 28 12:45:55 1991 Aubrey Jaffer (jaffer at foxkid) * eval.c (apply): added checks for number of arguments. * scm.h (CHECK_SIGINT): checks for blocked SIGINT. * sys.c (lprin1): added blocking and testing for SIGINT so that output won't hang on VMS. * scm.c (repl): added fflush call. * scm.c (err_head, wta): added fflush calls to error routines so that error message come out in proper order. @EOF chmod 666 ChangeLog echo x - code.doc cat >code.doc <<'@EOF' "code.doc", documentation for scm. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 Scm is a portable Scheme implementation written in C. Scm provides a machine independent platform for JACAL, a symbolic algebra system. SCM runs under VMS, MS-DOS, MacOS, Unix and similar systems. Scm conforms to Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Scm is interpreted and implements tail recursion for interpreted code. Scm has inexacts and 30 bit immediate integers. Scm uses and garbage collects off the C-stack. This allows routines to be written in C without regard to GC visibility. Full call-with-current-continuations are supported. ASCII and EBCDIC are supported. PROJECT HISTORY Siod, written by George Carrette, was the starting point for scm. Here is the Siod notice: /* Scheme In One Defun, but in C this time. * COPYRIGHT (c) 1989 BY * * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * * ALL RIGHTS RESERVED * Permission to use, copy, modify, distribute and sell this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation, and that the name of Paradigm Associates Inc not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. gjc@paradigm.com Paradigm Associates Inc Phone: 617-492-6079 29 Putnam Ave, Suite 6 Cambridge, MA 02138 */ The innovation from Siod which scm uses is being able to garbage collect off the c-stack. All the code has been rewritten. See the file "ChangeLog" for a log of recent changes that have been made to scm. SCM DATA TYPES IMMEDIATEs: inum: immediate 30 bit integers ichr: immediate characters iflags: #t, #f, (), #[eof], #[undefined], and #[unspecified] `=>', `else', `unquote', and `unquote-splicing' isym: immediate special symbols `and', `begin', `case', `cond', `define', `do', `if', `lambda', `let', `let*', `letrec', `or', `quasiquote', `quote', `set!' iloc descriptor of variable's location in environment pointer: pointer to a cell CELLs: cons: cell returned by (cons arg1 arg2). Cells can further be classified as having imcar (immediate car) or nimcar (non-immediate car) since the type code for a cons and the type code for an immediate type in its car are adjacent in the cons cell. cons with gloc: memoized pointer to symbol's value in car. Only in code. closure: applicable object returned by (lambda (args) ...) symbol: scheme symbol MALLOCs: vector: scheme vector string: scheme string spare: spare tc7 type code. contin: applicable object produced by call-with-current-continuation SUBRs: subr_0: C function of no arguments. subr_1: C function of one argument. cxr: car, cdr, cadr, cddr, ... subr_3: C function of 3 arguments. subr_2: C function of 2 arguments. subr_2x: C function of 2 interchanged arguments. subr_1o: C function of one optional argument. subr_2o: C function of 1 required and 1 optional argument. LSUBRs: lsubr: C function of list of arguments. lsubr_2: C function of 2 arguments and a list of arguments. asubr: associative C function of 2 arguments. SMOBS: free_cell: unused cell on the freelist. inport: input port. outport: output port. ioport: input-output port. inpipe: input pipe. outpipe: output pipe. flo: single-precision float. dblr: double-precision float. dblc: double-precision complex. bigpos: positive bignum. bigneg: negative bignum. promise: made by DELAY. arbiter: synchronization object. cptr: C object interface from Andrew Wilcox record: user defined data types. recons: constructor for record. recacc: accessor for record. recmod: modifier for record. recpred: predicate for record. DATA TYPE REPRESENTATIONS IMMEDIATE: B=data bit, C=flag code, P=pointer address bit ................................ inum BBBBBBBBBBBBBBBBBBBBBBBBBBBBBB10 ispcsym 000CCCC00CCCC100 isym CCCCCCC001110100 iflag CCCCCCC101110100 ichr BBBBBBBBBBBBBBBBBBBBBBBB11110100 iloc 0DDDDDDDDDDDDDDDEFFFFFFF11111100 pointer PPPPPPPPPPPPPPPPPPPPPPPPPPPPP000 HEAP CELL: G=gc_mark; 1 during mark, 0 other times. 1s and 0s here indicate type. G missing means sys (not GC'd) cons ..........SCM car..............0 ...........SCM cdr.............G cons with gloc in car ..........SCM car............001 ...........SCM cdr.............G closure ..........SCM code...........011 ...........SCM env.............G symbol ..........SCM name...........101 ...........SCM vcell...........G MALLOCs: vector .........long length....G0000111 ...........SCM **elts........... string .........long length....G0001111 ..........char *chars........... spare G0010111 contin .........long length....G0011111 .......jmp_buf *stack........... SUBRs: subr_0 ..........int hpoff.....00100111 ...........SCM (*f)()........... subr_1 ..........int hpoff.....00101111 ...........SCM (*f)()........... cxr ..........int hpoff.....00110111 ...........SCM (*f)()........... subr_3 ..........int hpoff.....00111111 ...........SCM (*f)()........... SUBR2s: subr_2 ..........int hpoff.....01000111 ...........SCM (*f)()........... subr_2x ..........int hpoff.....01001111 ...........SCM (*f)()........... subr_1o ..........int hpoff.....01010111 ...........SCM (*f)()........... subr_2o ..........int hpoff.....01011111 ...........SCM (*f)()........... LSUBRs: lsubr ..........int hpoff.....01100111 ...........SCM (*f)()........... lsubr_2 ..........int hpoff.....01101111 ...........SCM (*f)()........... asubr ..........int hpoff.....01110111 ...........SCM (*f)()........... SMOBS: free_cell 00000000000000000000000001111111 ...........*free_cell........000 flo 000000000000000000000001G1111111 ...........float num............ dblr 000000000000000100000001G1111111 ..........double *real.......... dblc 000000000000001100000001G1111111 .........complex *cmpx.......... bignum ...int length...0000001 G1111111 .........short *digits.......... bigpos ...int length...00000010G1111111 .........short *digits.......... bigneg ...int length...00000011G1111111 .........short *digits.......... port 0 00000100G1111111 ..........FILE *stream.......... inport 000000000000001100000100G1111111 ..........FILE *stream.......... outport 000000000000010100000100G1111111 ..........FILE *stream.......... ioport 000000000000011100000100G1111111 ..........FILE *stream.......... pipe 1 00000100G1111111 ..........FILE *stream.......... inpipe 000000000000101100000100G1111111 ..........FILE *stream.......... outpipe 000000000000110100000100G1111111 ..........FILE *stream.......... promise 000000000000000f00000101G1111111 ...........SCM val.............. arbiter 000000000000000l00000110G1111111 ...........SCM name............. cptr ...int length...00000111G1111111 ..........char *ptr............. record ...int length...00001000G1111111 ...........SCM **elts........... recons ...int length...00001001G1111111 ...........SCM rtd.............. recacc ....int pos.....00001010G1111111 ...........SCM rtd.............. recmod ....int pos.....00001011G1111111 ...........SCM rtd.............. recpred 00001100G1111111 ...........SCM rtd.............. SMOBS SMOBs are a collection of miscellaneous types. The type code and GCMARK bit occupy the lower order 16 bits of the CAR half of the cell. The rest of the CAR can be used for sub-type or other information. The CDR contains data of size long. Inexact data types are subtypes of type tc16_flo. If the sub-type is: 0 - a single precision float is contained in the CDR. 1 - CDR is a pointer to a malloced double. 3 - CDR is a pointer to a malloced pair of doubles. GARBAGE COLLECTION The garbage collector is in the latter half of sys.c. There is a heap (which can grow but not shrink) in which all cons cells and type headers reside. All objects in the heap are the same size (8 bytes). Strings, vectors, continuations, and bignums are managed by malloc. There is only one pointer to each malloc object from its type header. This allows malloc objects to be freed when the associated heap object is garbage collected. To garbage collect, first certain protected objects are marked (such as the obarray). Then the stack (and marked continuations) are traversed. Each longword in the stack is tried to see if it is a valid SCM pointer into the heap. If it is, the object is marked. If not, it is ignored. If the stack is word rather than longword aligned (#define WORD_ALIGN), both alignments are tried. The heap is then swept. If a type header cell pointing to malloc space is collected the malloc object is then freed. This arrangement will occasionally mark objects which are no longer used. These objects can be collected at any later time. This has not been a problem in practice and the advantage of using the c-stack far outweighs it. INTERRUPTS If they are supported by the C implementation, init_signals() in scm.c sets up handlers for SIGINT and SIGALRM. The low level handlers for SIGINT and SIGALRM are int_signal() and alrm_signal(). All of the signal handlers immediately reestablish themselves by a call to signal(). If an interrupt handler is defined when the interrupt is received, the code is interpreted. If the code returns execution resumes from where the interrupt happened. Call-with-current-continuation allows the stack to be saved and restored. SCM does not use any signal masking system calls. These are not a portable feature. However, code can run uninterrupted by use of the C macros DEFER_INTS and ALLOW_INTS. DEFER_INTS sets the global variable ints_disabled to 1. If an interrupt occurs during a time when ints_disabled is 1 one of the global variables sig_deferred or alrm_deferred is set to 1 and the handler returns. When ALLOW_INTS is executed the deferred variables are checked and if set the appropriate handler is called. DEFER_INTS can not be nested. An ALLOW_INTS must happen before another DEFER_INTS can be done. In order to check that this constraint is satisfied #define CAREFUL_INTS in config.h. CHANGING SCM When writing C-code a precaution is recommended. If your routine allocates from the heap and accesses some malloc object make sure that some local variable in your routine points to the type header of the malloc object. This will prevent the malloc object from being freed before you are done with it. Also, if you maintain a static pointer to some (non-immediate) SCM object, you must either make your pointer be the value cell of a symbol (see errobj for an example) or make your pointer be one of the sys_protects (see symhash for an example). The macro ASSERT(_cond,_arg,_pos,_subr) signals an error if the expression (_cond) is 0. _arg is the offending object, _subr is the string naming the subr, and _pos indicates the position or type of error. _pos can be one of `ARG1', `ARG2', `ARG3', `ARG4', `ARG5', `WNA' (wrong number of args), `OVFLOW' `OUTOFRANGE' `NALLOC' `EXIT' `HUP_SIGNAL' `INT_SIGNAL' `FPE_SIGNAL' `BUS_SIGNAL' `SEGV_SIGNAL' `ALRM_SIGNAL' or a C string (char *). Error checking is not done by ASSERT if the flag RECKLESS is defined. An error condition can still be signaled in this case with a call to wta(_arg,_pos,_subr). To add a C routine to scm: [1] choose the appropriate subr type from the type list. [2] write the code and put into scm.c. [3] add a make_subr call to init_scm. Or put an entry into the appropriate iproc structure. To add a package of new procedures to scm (see subr.c for example): [1] create a new C file (foo.c). [2] at the front of foo.c put declarations for strings for your procedure names. static char s_twiddle_bits[]="twiddle-bits!"; static char s_bitsp[]="bits?"; [3] choose the appropriate subr types from the type list in code.doc. [4] write the code for the procedures and put into foo.c [5] create one iproc structure for each subr type used in foo.c static iproc subr3s[]={ {s_twiddle-bits,twiddle-bits}, {s_bitsp,bitsp}, {0,0}}; [6] create an init_ routine at the end of the file which calls init_iprocs with the correct type for each of the iprocs created in step 5. void init_foo() { init_iprocs(subr1s, tc7_subr_1); init_iprocs(subr3s, tc7_subr_3); } [7] put any scheme code which needs to be run as part of your package into Ifoo.scm. [8] put an IF into Init.scm which calls Ifoo.scm if your package is included: (if (defined? twiddle-bits!) (load (in-vicinity (implementation-vicinity) "Ifoo" (scheme-file-suffix)))) [9] put documentation of the new procedures into foo.doc [10] add lines to your makefile to compile and link SCM with your object file. Add a line INITS = initfoo() at the beginning of the makefile. These steps should allow your package to be linked into SCM with a minimum of difficulty. Your package should also work with dynamic loading when SCM gets this capability. Special forms (new syntax) can be added to scm. [1] define a new MAKISYM in scm.h and increment NUM_XSPCSYMS. [2] add a string with the new name in the corresponding place in isymnames in sys.c. [3] add case clause to ceval near I_QUASIQUOTE (in eval.c). To add a new type to scm: [1] choose an unused SMOB type code from the previous type table. [2] add #define tc16_???? ???? to scm.h to define your type. [3] add code to gc_mark and gc_sweep in the case tc7_smob: sections (sys.c). [4] add code to iprin1 (in repl.c) in the case tc7_smob: section to print your type (if desired). [5] add code to equalp (in subr.c) to compare 2 objects of the new type (if desired). To use scm from another program call init_scm or run_scm as is done in main() in "scm.c". CONTINUATIONS The scm procedure call-with-current-continuation calls it's argument with an object of type `contin'. If CHEAP_CONTINUATIONS is #defined (in "config.h") the contin just contains a jmp_buf. When the contin is applied, a longjmp of the jmp_buf is done. If CHEAP_CONTINUATIONS is not #defined the contin contains the jmp_buf and a copy of the C stack between the call_cc stack frame and stack_start_ptr. When the contin is applied: [1] the stack is grown larger than the saved stack, if neccessary. [2] the saved stack is copied back into it's original position. [3] longjmp of the jmp_buf is called. On systems with nonlinear stack disciplines (multiple stacks or non-contiguous stack frames) copying the stack will not work properly. These systems need to #define CHEAP_CONTINUATIONS in "config.h". INTEGERS Scm has 30 bit immediate signed numbers called INUMs. An INUM instead of a pointer to a cell is flagged by a `1' in the second to low order bit position. Since cells are always 8 byte aligned a pointer to a cell has the low order 3 bits `0'. The high order 30 bits are used for the integer's value. Computations on INUMs are performed by converting the arguments to C integers (by a shift), operating on the integers, and converting the result to an INUM. The result is checked for overflow by converting back to integer and checking the reverse operation. The shifts used for conversion need to be signed shifts. If the C implementation does not support signed right shift this fact is detected in a #if statement in scm.h and one is constructed in terms of unsigned right shift. EVALUATION Whenever a symbol's value is found in the local environment the pointer to the symbol in the code is replaced with an immediate object (ILOC) which specifies how many environment frames down and how far in to go for the value. When this immediate object is subsequently encountered, the value can be retrieved quickly. Pointers to symbols not defined in local environments are incremented. This incremented pointer is called a GLOC. The low order bit is normally reserved for GCmark; But, since references to variables in the code always occur in the CAR position and the GCmark is in the CDR, there is no conflict. Number of argument checks for closures are made only when the function position (whose value is the closure) of a combination is not an ILOC or GLOC. When the function position of a combination is a symbol it will be checked only the first time it is evaluated because it will then be replaced with an ILOC or GLOC. IMPROVEMENTS TO MAKE If an open fails because there are no unused file handles, GC should be done so that file handles which are no longer used can be collected. Copying all of the stack is wasteful of storage. Any time a call-with-current-continuation is called the stack could be re-rooted with a frame which calls the contin just created. This in combination with checking stack depth could also be used to allow stacks deeper than 64K on the IBM PC. If the symhash array is specially marked in garbage collection symbols with value #[undefined] which have no pointers to them can be collected. In Maclisp this was called GCTWA. Compaction could be done to malloced objects by freeing and reallocing all the malloc objects encountered in a scan of the heap. Whether compactions would actually occur is system depenedent. Unamed (let ((var ..))) expressions are destructively replaced with the equivalent lambda expression. (do ((var val)) ...) binding clauses without clauses can be moved up and out of the `do' into a new surrounding let or lambda. @EOF chmod 666 code.doc echo x - ANNOUNCE cat >ANNOUNCE <<'@EOF' This message announces the availability of Scheme release scm4a5. All reported bugs have been fixed. fred@sce.carleton.ca (Fred J Kaudel) has added tests for inexact numbers to test.scm. Scm conforms to Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Scm is written in C and runs under Amiga, Atari-ST, MacOS, MS-DOS, NOS/VE, VMS, Unix and similar systems. ASCII and EBCDIC are supported. Documentation is included explaining the many Scheme Language extensions in scm, the internal representation and how to extend or include scm in other programs. SCM can be obtained via FTP (detailed instructions follow) from: altdorf.ai.mit.edu:archive/scm/scm4a5.shar altdorf.ai.mit.edu:archive/scm/scm4a5.tar.Z nexus.yorku.ca:pub/scheme/new/scm4a5.shar nexus.yorku.ca:pub/scheme/new/scm4a5.tar.Z SLIB is a portable scheme library which SCM uses: altdorf.ai.mit.edu:archive/scm/slib1b7.shar altdorf.ai.mit.edu:archive/scm/slib1b7.tar.Z nexus.yorku.ca:pub/scheme/new/slib1b7.shar nexus.yorku.ca:pub/scheme/new/slib1b7.tar.Z ftp altdorf.ai.mit.edu [18.43.0.246] (anonymous) cd archive/scm or ftp nexus.yorku.ca (anonymous) cd pub/scheme/new This directory contains the distribution version 4a5 of scm. `scm4a5.shar' is a shar file of the C code distribution. `scm4a5.tar.Z' is a compressed tar file of the C code distribution. `slib1b7.shar' is a shar file of a Scheme Library. `slib1b7.tar.Z' is a compressed tar file of a Scheme Library. Remember to use binary mode when transferring the *.tar.Z files. Be sure to get and read the GNU General Public License (COPYING). It is included in the scm4a5.shar and scm4a5.tar.Z files. To receive an IBM PC floppy disk with the source files and MSDOS executable send $60 ($65 for i386 version) to Aubrey Jaffer, 84 Pleasant St. Wakefield MA 01880, USA. Net 30 day purchase orders are minimum $100. If you like scm you can support the developement and maintainence of it by buying a disk from me or by sending money to the above address. Money received will also help speed the release of a free symbolic mathematics system (written in scheme). @EOF chmod 666 ANNOUNCE echo x - scm.c cat >scm.c <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ #include #include #include "scm.h" #include "patchlvl.h" void init_banner() { fputs("SCM version ",stdout); fputs(SCMVERSION,stdout); intprint((long)PATCHLEVEL,10,stdout); puts(", Copyright (C) 1990, 1991, 1992 Aubrey Jaffer.\n\ SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.\n\ This is free software, and you are welcome to redistribute it\n\ under certain conditions; type `(terms)' for details."); } #if (__TURBOC__==1) #define signal ssignal /* Needed for TURBOC V1.0 */ #endif /* SIGRETTYPE is the type that signal handlers return. See */ #ifdef STDC_HEADERS # if (__TURBOC__ == 1) # define SIGRETTYPE int # else # define SIGRETTYPE void # endif #else # define SIGRETTYPE int #endif #ifdef SIGHUP SIGRETTYPE hup_signal(sig) int sig; { signal(SIGHUP,hup_signal); wta(UNDEFINED,(char *)HUP_SIGNAL,""); } #endif SIGRETTYPE int_signal(sig) int sig; { sig = errno; signal(SIGINT,int_signal); if (ints_disabled) sig_deferred = 1; else han_sig(); errno = sig; } /* If doesn't have SIGFPE, disable FLOATS for the rest of this file. */ #ifndef SIGFPE #undef FLOATS #endif #ifdef FLOATS SIGRETTYPE fpe_signal(sig) int sig; { signal(SIGFPE,fpe_signal); wta(UNDEFINED,(char *)FPE_SIGNAL,""); } #endif #ifdef SIGBUS SIGRETTYPE bus_signal(sig) int sig; { signal(SIGBUS,bus_signal); wta(UNDEFINED,(char *)BUS_SIGNAL,""); } #endif #ifdef SIGSEGV /* AMIGA lacks! */ SIGRETTYPE segv_signal(sig) int sig; { signal(SIGSEGV,segv_signal); wta(UNDEFINED,(char *)SEGV_SIGNAL,""); } #endif #ifdef atarist #undef SIGALRM /* only available via MiNT libs */ #endif #ifdef SIGALRM SIGRETTYPE alrm_signal(sig) int sig; { sig = errno; signal(SIGALRM,alrm_signal); if (ints_disabled) alrm_deferred = 1; else han_alrm(); errno = sig; } static char s_alarm[]="alarm"; SCM lalarm(i) SCM i; { SCM j; ASSERT(INUMP(i) && (INUM(i) >= 0),i,ARG1,s_alarm); SYSCALL(j = MAKINUM(alarm(INUM(i)));); return j; } #endif #ifdef SIGHUP static SIGRETTYPE (*oldhup)(); #endif static SIGRETTYPE (*oldint)(); #ifdef FLOATS static SIGRETTYPE (*oldfpe)(); #endif #ifdef SIGBUS static SIGRETTYPE (*oldbus)(); #endif #ifdef SIGSEGV /* AMIGA lacks! */ static SIGRETTYPE (*oldsegv)(); #endif #ifdef SIGALRM static SIGRETTYPE (*oldalrm) (); #endif #ifdef SIGPIPE static SIGRETTYPE (*oldpipe) (); #endif void init_scm( display_banner ) int display_banner; { SCM i; stack_start_ptr = &i; /* stack_start_ptr gets set */ if (display_banner) init_banner(); init_tables(); init_storage(); init_subrs(); init_io(); init_scl(); init_features(); init_time(); init_repl(); #ifdef SIGALRM make_subr(s_alarm,tc7_subr_1,lalarm); #endif #ifdef REV2_PROCEDURES init_sc2(); #endif INITS; /* call initialization of user extensions */ } void init_signals() { oldint = signal(SIGINT,int_signal); #ifdef SIGHUP oldhup = signal(SIGHUP,hup_signal); #endif #ifdef FLOATS oldfpe = signal(SIGFPE,fpe_signal); #endif #ifdef SIGBUS oldbus = signal(SIGBUS,bus_signal); #endif #ifdef SIGSEGV /* AMIGA lacks! */ oldsegv = signal(SIGSEGV,segv_signal); #endif #ifdef SIGALRM oldalrm = signal(SIGALRM,alrm_signal); #endif #ifdef SIGPIPE oldpipe = signal(SIGPIPE,SIG_IGN); #endif } /* This is used in preparation for a possible fork(). Ignore all signals before the fork so that child will catch only if it establishes a handler */ void ignore_signals() { signal(SIGINT,SIG_IGN); #ifdef SIGHUP signal(SIGHUP,SIG_DFL); #endif #ifdef FLOATS signal(SIGFPE,SIG_DFL); #endif #ifdef SIGBUS signal(SIGBUS,SIG_DFL); #endif #ifdef SIGSEGV /* AMIGA lacks! */ signal(SIGSEGV,SIG_DFL); #endif /* Some documentation claims that ALRMs are cleared accross forks. If this is not always true then the value returned by alarm(0) will have to be saved and unignore_signals() will have to reinstate it. */ /* This code should be neccessary only if the forked process calls alarm() without establishing a handler: #ifdef SIGALRM oldalrm = signal(SIGALRM,SIG_DFL); #endif */ /* These flushes are per warning in man page on fork(). */ fflush(stdout); fflush(stderr); } void unignore_signals() { signal(SIGINT,int_signal); #ifdef SIGHUP signal(SIGHUP,hup_signal); #endif #ifdef FLOATS signal(SIGFPE,fpe_signal); #endif #ifdef SIGBUS signal(SIGBUS,bus_signal); #endif #ifdef SIGSEGV /* AMIGA lacks! */ signal(SIGSEGV,segv_signal); #endif #ifdef SIGALRM signal(SIGALRM,alrm_signal); #endif } void restore_signals() { signal(SIGINT,oldint); #ifdef SIGHUP signal(SIGHUP,oldhup); #endif #ifdef FLOATS signal(SIGFPE,oldfpe); #endif #ifdef SIGBUS signal(SIGBUS,oldbus); #endif #ifdef SIGSEGV /* AMIGA lacks! */ signal(SIGSEGV,oldsegv); #endif #ifdef SIGALRM signal(SIGALRM,oldalrm); #endif #ifdef SIGPIPE signal(SIGPIPE,oldpipe); #endif } int run_scm(display_banner,argc,argv) int display_banner; int argc; char **argv; { SCM i; init_scm( display_banner ); init_signals(); i = repl_driver(argc, argv); restore_signals(); if (display_banner) puts(";EXIT"); return (int)INUM(i); } #ifndef RTL int main( argc, argv ) int argc; char **argv; { return run_scm( argc <= 1, argc, argv ); } #endif @EOF chmod 666 scm.c echo x - time.c cat >time.c <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ #include #include "scm.h" #if (__TURBOC__==1) /* Needed for TURBOC V1.0 */ #define LACK_FTIME #define LACK_TIMES #undef MSDOS #endif #ifdef STDC_HEADERS # include # ifdef sun # include # include # endif # ifdef nosve # include # include # endif #else # ifdef SVR2 # include # else # include # endif # include # include #endif /* Define this if your system lacks ftime(). */ /* #define LACK_FTIME */ /* Define this if your system lacks times(). */ /* #define LACK_TIMES */ #ifdef THINK_C # define LACK_FTIME # define LACK_TIMES # define CLK_TCK 60 #endif #ifdef SVR2 # define LACK_FTIME #endif #ifdef nosve # define LACK_FTIME #endif #ifdef GNUDOS # define LACK_FTIME # define LACK_TIMES #endif #ifdef atarist # define LACK_FTIME # define LACK_TIMES #endif #ifdef MSDOS # include # include #endif #ifndef LACK_FTIME # ifdef unix # include # endif #endif #ifdef CLK_TCK # define CLKTCK CLK_TCK # ifdef CLOCKS_PER_SEC # ifdef unix # include # define LACK_CLOCK /* This is because clock() might be POSIX rather than ANSI. This occurs on HP-UX machines */ # endif # endif #else # define LACK_CLOCK # ifdef AMIGA # include # define LACK_TIMES # define LACK_FTIME # define CLKTCK 1000 # else # define CLKTCK 60 # endif #endif #ifdef __STDC__ #define timet time_t #else #define timet long #endif #ifdef LACK_CLOCK # ifdef LACK_TIMES # ifdef AMIGA /* From: "Fred Bayer" */ # ifdef AZTEC_C /* AZTEC_C */ # include long mytime() { long sec,mic,mili=0; struct timerequest *timermsg; struct MsgPort *timerport; if(!(timerport = (struct MsgPort *)CreatePort(0,0))){ lputs("No mem for port.\n",STREAM(def_outp)); return mili; } if(!(timermsg = (struct timerequest *) CreateExtIO(timerport,sizeof(struct timerequest)))){ lputs("No mem for timerequest.\n",STREAM(def_outp)); DeletePort(timermsg->tr_node.io_Message.mn_ReplyPort); return mili; } if(!(OpenDevice(TIMERNAME,UNIT_MICROHZ,timermsg,0))){ timermsg->tr_node.io_Command = TR_GETSYSTIME; timermsg->tr_node.io_Flags = 0; DoIO(timermsg); sec = timermsg->tr_time.tv_secs; mic = timermsg->tr_time.tv_micro; mili = sec*1000+mic/1000; CloseDevice(timermsg); } else lputs("No Timer available.\n",STREAM(def_outp)); DeletePort(timermsg->tr_node.io_Message.mn_ReplyPort); DeleteExtIO(timermsg); return mili ; } # else /* this is for SAS/C */ long mytime() { unsigned int cl[2]; timer(cl); return(cl[0]*1000+cl[1]/1000); } # endif /* AZTEC_C */ # else /* AMIGA */ # define mytime() ((time(0L) - your_base) * CLKTCK) # endif /* AMIGA */ # else /* LACK_TIMES */ long mytime() { struct tms time_buffer; times(&time_buffer); return time_buffer.tms_utime + time_buffer.tms_stime; } # endif /* LACK_TIMES */ #else /* LACK_CLOCK */ # define mytime clock #endif /* LACK_CLOCK */ #ifdef LACK_FTIME # ifdef AMIGA SCM your_time() { return MAKINUM(mytime()); } # else timet your_base; SCM your_time() { return MAKINUM((time(0L) - your_base) * (int)CLKTCK); } # endif /* AMIGA */ #else /* LACK_FTIME */ struct timeb your_base; SCM your_time() { struct timeb time_buffer; long tmp; ftime(&time_buffer); time_buffer.time -= your_base.time; tmp = time_buffer.millitm - your_base.millitm; tmp = time_buffer.time*1000L + tmp; tmp *= CLKTCK; tmp /= 1000; return MAKINUM(tmp); } #endif /* LACK_FTIME */ long my_base=0; SCM my_time() { return MAKINUM(mytime()-my_base); } #ifndef STDC_HEADERS struct tm *localtime(); #endif SCM dcdtime() { int i=sizeof(struct tm)/sizeof(int); SCM ans=make_vector(MAKINUM((long)i),UNDEFINED); timet timv=time(0L); struct tm *tmptr=localtime(&timv); while(i--) VELTS(ans)[i]=MAKINUM((long)(((int *)tmptr)[i])); return ans; } SCM get_univ_time() { timet timv=time(0L); #ifdef STDC_HEADERS timv = mktime(gmtime(&timv)); #endif return MAKINUM(timv); } static char s_dcdunivtime[]="decode-universal-time"; SCM dcdunivtime(ut) SCM ut; { timet timv=INUM((unsigned long)ut); ASSERT(INUMP(ut),ut,ARG1,s_dcdunivtime); { int i=sizeof(struct tm)/sizeof(int); SCM ans=make_vector(MAKINUM((long)i),UNDEFINED); struct tm *tmptr=localtime(&timv); while(i--) VELTS(ans)[i]=MAKINUM((long)(((int *)tmptr)[i])); return ans; } } long time_in_msec(x) long x; { if (CLKTCK==60) return (x*50)/3; else return x*(long)(1000/CLKTCK); } static iproc subr0s[]={ {"get-internal-run-time",my_time}, {"get-internal-real-time",your_time}, {"get-decoded-time",dcdtime}, {"get-universal-time",get_univ_time}, {0,0}}; SCM sym_itups = BOOL_F; void init_time() { sym_itups=sysintern("internal-time-units-per-second"); VCELL(sym_itups)=MAKINUM((long)CLKTCK); #ifdef LACK_FTIME # ifndef AMIGA time(&your_base); # endif #else ftime(&your_base); #endif my_base = mytime(); init_iprocs(subr0s, tc7_subr_0); make_subr(s_dcdunivtime, tc7_subr_1, dcdunivtime); } @EOF chmod 666 time.c echo x - repl.c cat >repl.c <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ #include #include "scm.h" #ifdef vms # ifndef CHEAP_CONTINUATIONS # include "setjump.h" # else # include # endif #else # include #endif /* vms */ unsigned char upcase[CHAR_CODE_LIMIT]; unsigned char downcase[CHAR_CODE_LIMIT]; unsigned char lowers[]="abcdefghijklmnopqrstuvwxyz"; unsigned char uppers[]="ABCDEFGHIJKLMNOPQRSTUVWXYZ"; void init_tables() { int i; for(i=0;i", "else", "unquote", "unquote-splicing", ".", /* Flags */ "#f", "#t", "#", "#", "()", "#" }; SCMPTR stack_start_ptr = 0; static char s_read_char[]="read-char", s_peek_char[]="peek-char"; char s_read[]="read", s_write[]="write", s_newline[]="newline"; static char s_display[]="display", s_write_char[]="write-char"; static char s_eofin[]="end of file in "; static char s_unknown_sharp[]="unknown # object"; SCM lreadr(),lreadparen(),istring2number(); sizet read_token(); void intprint(n,radix,f) long n; int radix; FILE *f; { char num_buf[INTBUFLEN]; lfwrite(num_buf,(sizet)1,iint2str(n,radix,num_buf),f); } #ifdef FLOATS void floprint(exp,f) SCM exp; FILE *f; { char num_buf[FLOBUFLEN]; lfwrite(num_buf,(sizet)1,iflo2str(exp,num_buf),f); } #endif void ipruk(hdr,ptr,f) char *hdr; SCM ptr; FILE *f; { lputs("#',f); } void iprlist(hdr,exp,tlr,f,writing) char *hdr, tlr; SCM exp; FILE *f; int writing; { lputs(hdr,f); /* CHECK_INTS; */ iprin1(CAR(exp),f,writing); exp = CDR(exp); for(;NIMP(exp);exp=CDR(exp)) { if NECONSP(exp) break; lputc(' ',f); /* CHECK_INTS; */ iprin1(CAR(exp),f,writing); } if NNULLP(exp) { lputs(" . ",f); iprin1(exp,f,writing); } lputc(tlr,f); } void iprin1(exp,f,writing) SCM exp; FILE *f; int writing; { register long i; taloop: switch (7 & (int)exp) { case 2: case 6: intprint(INUM(exp),10,f); break; case 4: if ICHRP(exp) { i = ICHR(exp); if (writing) lputs("#\\",f); if (!writing) lputc((int)i,f); else if ((i<=' ') && charnames[i]) lputs(charnames[i],f); #ifndef EBCDIC else if (i=='\177') lputs(charnames[(sizeof charnames/sizeof(char *))-1],f); #endif /* ndef EBCDIC */ else lputc((int)i,f); } else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *)))) lputs(ISYMCHARS(exp),f); else if ILOCP(exp) { lputs("#@",f); intprint((long)IFRAME(exp),10,f); lputc(ICDRP(exp)?'-':'+',f); intprint((long)IDIST(exp),10,f); } else goto idef; break; case 1: /* gloc */ lputs("#@",f); exp--; goto taloop; default: idef: ipruk("immediate",exp,f); break; case 0: switch TYP7(exp) { case tcs_cons_gloc: case tcs_cons_imcar: case tcs_cons_nimcar: iprlist("(",exp,')',f,writing); break; case tcs_closures: exp = CODE(exp); iprlist("#',f,writing); break; case tc7_string: if (writing) { lputc('\"',f); for(i=0;i',f); break; case tc7_contin: lputs("#',f); break; case tc7_smob: switch TYP16(exp) { case tc16_port: lputs("#<",f); if (RDNG & CAR(exp)) lputs("input-",f); if (WRTNG & CAR(exp)) lputs("output-",f); lputs((PIP & CAR(exp))?"pipe ":"port ",f); if CLOSEDP(exp) lputs("closed",f); else intprint((long)fileno(STREAM(exp)),10,f); lputc('>',f); break; case tc16_promise: lputs("#',f); break; case tc16_arbiter: lputs("#',f); break; #ifdef FLOATS case tc16_flo: floprint(exp,f); break; #endif /* def FLOATS */ default: goto cdef; } break; default: cdef: ipruk("type",exp,f); } } } SCM eof_objectp(x) SCM x; { return (EOF_VAL == x) ? BOOL_T : BOOL_F; } SCM lwrite(obj,port) SCM obj,port; { if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port),port,ARG2,s_write); iprin1(obj,STREAM(port),1); #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) close_pipe(port); # endif #endif return UNSPECIFIED; } SCM display(obj,port) SCM obj,port; { if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port),port,ARG2,s_display); iprin1(obj,STREAM(port),0); #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) close_pipe(port); # endif #endif return UNSPECIFIED; } SCM newline(port) SCM port; { if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port),port,ARG1,s_newline); lputc('\n',STREAM(port)); #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) close_pipe(port); else # endif #endif if (port == cur_outp) fflush(STREAM(port)); return UNSPECIFIED; } SCM write_char(chr,port) SCM chr,port; { if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port),port,ARG2,s_write_char); ASSERT(ICHRP(chr),chr,ARG1,s_write_char); lputc((int)ICHR(chr),STREAM(port)); #ifdef HAVE_PIPE # ifdef EPIPE if (EPIPE == errno) close_pipe(port); # endif #endif return UNSPECIFIED; } FILE *trans = 0; SCM trans_on(fil) SCM fil; { transcript = open_file(fil, makfromstr("w", (sizet) 1)); if FALSEP(transcript) trans = 0; else trans = STREAM(transcript); return UNSPECIFIED; } SCM trans_off() { if (!FALSEP(transcript)) close_port(transcript); transcript = BOOL_F; trans = 0; return UNSPECIFIED; } void lputc(c,f) int c; FILE *f; { SYSCALL(putc(c,f);); if (trans && (f == STREAM(def_outp))) SYSCALL(putc(c,trans);); } void lputs(s,f) char *s; FILE *f; { SYSCALL(fputs(s,f);); if (trans && (f == STREAM(def_outp))) SYSCALL(fputs(s,trans);); } int lfwrite(ptr, size, nitems, stream) char *ptr; sizet size; sizet nitems; FILE *stream; { #ifdef vms sizet l = size * nitems; int i=0; for(;i < l;++i) lputc(ptr[i],stream); return l; #else int ret; SYSCALL(ret = fwrite(ptr, size, nitems, stream);); if (trans && (stream == STREAM(def_outp))) SYSCALL(fwrite(ptr, size, nitems, trans);); return ret; #endif } int ungetted = 0; #ifdef vms /* THIS CODE IS NO LONGER CORRECT */ int lgetc(f) FILE *f; { int c; long old_sig_deferred; DEFER_INTS; old_sig_deferred = sig_deferred; c = getc(f); if ((old_sig_deferred == 0) && sig_deferred && (f == stdin)) while(c && (c != EOF)) c = getc(f); if (trans && (f == stdin)) SYSCALL(putc(c,trans);); ALLOW_INTS; return c; } #else int lgetc(f) FILE *f; { int c; SYSCALL(c = getc(f);); if (trans && (f == stdin)) { if (ungetted) ungetted = 0; else SYSCALL(putc(c,trans);); } return c; } #endif /* def vms */ void lungetc(c,f) int c; FILE *f; { if ((f == stdin) && trans) ungetted = 1; ungetc(c,f); } SCM read_char(port) SCM port; { int c; if UNBNDP(port) port = cur_inp; else ASSERT(NIMP(port) && OPINPORTP(port),port,ARG1,s_read_char); c = lgetc(STREAM(port)); if (c == EOF) return EOF_VAL; return MAKICHR(c); } SCM peek_char(port) SCM port; { FILE *f; int c; if UNBNDP(port) port = cur_inp; else ASSERT(NIMP(port) && OPINPORTP(port), port,ARG1,s_peek_char); f = STREAM(port); SYSCALL(c = getc(f);); if (c == EOF) return EOF_VAL; ungetc(c,f); return MAKICHR(c); } char *grow_tok_buf(tok_buf) SCM tok_buf; { sizet len = LENGTH(tok_buf); len += len / 2; resizstr(tok_buf,MAKINUM(len)); return CHARS(tok_buf); } int flush_ws(f,eoferr) FILE *f; char *eoferr; { register int c; while(1) switch (c = lgetc(f)) { case EOF: goteof: if (eoferr) wta(UNDEFINED,s_eofin,eoferr); return c; case ';': lp: switch (c = lgetc(f)) { case EOF: goto goteof; default: goto lp; case LINE_INCREMENTORS: break; } case LINE_INCREMENTORS: linum++; case WHITE_SPACES: break; default: return c; } } SCM lread(port) SCM port; { FILE *f; int c; if UNBNDP(port) port = cur_inp; else ASSERT(NIMP(port) && OPINPORTP(port),port,ARG1,s_read); f = STREAM(port); c = flush_ws(f,(char *)NULL); if (c == EOF) return EOF_VAL; lungetc(c,f); { SCM tok_buf = makstr(30L); return lreadr(tok_buf,f); } } SCM lreadr(tok_buf,f) SCM tok_buf; FILE *f; { int c; sizet j; SCM p; tryagain: c = flush_ws(f,s_read); switch (c) { case '(': return lreadparen(tok_buf,f,s_list); case ')': warn("unexpected \")\"",""); goto tryagain; case '\'': return cons2(I_QUOTE,lreadr(tok_buf,f),EOL); case '`': return cons2(I_QUASIQUOTE,lreadr(tok_buf,f),EOL); case ',': c = lgetc(f); if (c == '@') p = I_UQ_SPLICING; else { lungetc(c,f); p = I_UNQUOTE; } return cons2(p,lreadr(tok_buf,f),EOL); case '#': c = lgetc(f); switch (c) { case '(': return vector(lreadparen(tok_buf,f,s_vector)); case 't': case 'T': return BOOL_T; case 'f': case 'F': return BOOL_F; case 'b': case 'B': case 'o': case 'O': case 'd': case 'D': case 'x': case 'X': case 'i': case 'I': case 'e': case 'E': lungetc(c,f); c = '#'; goto num; case '\\': c = lgetc(f); j = read_token(c,tok_buf,f); if (j==1) return MAKICHR(c); for (c=0;c= LENGTH(tok_buf)) grow_tok_buf(tok_buf); if (c == '\\') c = lgetc(f); CHARS(tok_buf)[j] = c; ++j; } if (j == 0) return nullstr; CHARS(tok_buf)[j] = 0; return makfromstr(CHARS(tok_buf),j); case DIGITS: case '.': case '-': case '+': num: j = read_token(c,tok_buf,f); p = istring2number(CHARS(tok_buf), (long)j, 10L); if (p != BOOL_F) return p; ASSERT(c != '#',UNDEFINED,s_unknown_sharp,CHARS(tok_buf)); goto tok; default: j = read_token(c,tok_buf,f); tok: return intern(CHARS(tok_buf),j); } } sizet read_token(ic,tok_buf,f) int ic; SCM tok_buf; FILE *f; { register sizet j = 1; register int c = ic; register char *p = CHARS(tok_buf); p[0] = downcase[c]; while(1) { if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf); switch (c = lgetc(f)) { case '(': case ')': case '\"': case ';': case WHITE_SPACES: getout: lungetc(c,f); case EOF: p[j] = 0; return j; case LINE_INCREMENTORS: linum++; goto getout; default: p[j++] = downcase[c]; } } } SCM lreadparen(tok_buf,f,name) SCM tok_buf; FILE *f; char *name; { SCM tmp; int c; c = flush_ws(f,name); if (c == ')') return EOL; lungetc(c,f); tmp = lreadr(tok_buf,f); if (tmp != I_DOT) return cons(tmp,lreadparen(tok_buf,f,name)); tmp = lreadr(tok_buf,f); c = flush_ws(f,name); if (c != ')') wta(UNDEFINED,"missing close paren",""); return tmp; } #ifdef IO_EXTENSIONS static char s_file_position[]="file-position", s_file_set_pos[]="file-set-position"; static char s_flush[]="force-output", s_read_to_str[]="read-string!"; SCM file_position(port) SCM port; { ASSERT(NIMP(port) && OPPORTP(port), port,ARG1,s_file_position); SYSCALL(port = MAKINUM(ftell(STREAM(port)));); return port; } SCM file_set_position(port, pos) SCM port, pos; { ASSERT(NIMP(port) && OPPORTP(port), port,ARG1,s_file_set_pos); SYSCALL(port = (fseek(STREAM(port),INUM(pos),0)) ? BOOL_F : BOOL_T;); #ifdef HAVE_PIPE # ifdef ESPIPE ASSERT(ESPIPE != errno, port, ARG1, s_file_set_pos); # endif #endif return port; } SCM lflush(port) SCM port; { if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port),port,ARG1,s_flush); SYSCALL(fflush(STREAM(port));); return UNSPECIFIED; } SCM read_to_string(str,port) SCM str,port; { if UNBNDP(port) port = cur_inp; else ASSERT(NIMP(port) && OPINPORTP(port),port,ARG2,s_read_to_str); ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_read_to_str); SYSCALL(str = MAKINUM(fread(CHARS(str),(sizet)1, (sizet)LENGTH(str),STREAM(port)));); return str; } #endif /* def IO_EXTENSIONS */ /* These procedures implement synchronization primitives. Processors with an atomic test-and-set instruction can use it here (and not DEFER_INTS). */ char s_tryarb[]="try-arbiter"; char s_relarb[]="release-arbiter"; SCM tryarb(arb) SCM arb; { ASSERT((TYP16(arb)==tc16_arbiter),arb,ARG1,s_tryarb); DEFER_INTS; if (CAR(arb) & (1L<<16)) arb = BOOL_F; else { CAR(arb) = tc16_arbiter | (1L<<16); arb = BOOL_T; } ALLOW_INTS; return arb; } SCM relarb(arb) SCM arb; { ASSERT((TYP16(arb)==tc16_arbiter),arb,ARG1,s_relarb); if (!(CAR(arb) & (1L<<16))) return BOOL_F; CAR(arb) = tc16_arbiter; return BOOL_T; } SCM sym_features=EOL; static char s_tryload[]="try-load"; #define s_load (&s_tryload[4]) char *features[] = { #ifdef IO_EXTENSIONS # ifdef HAVE_PIPE "pipe", # endif "i/o-extensions", #endif #ifdef REV2_PROCEDURES "rev2-procedures", #endif #ifndef CHEAP_CONTINUATIONS "full-continuation", #endif #ifdef RECKLESS "reckless", #endif #ifdef vms "ed", #endif 0}; void init_features() { char **feats = features; sym_features = sysintern("*features*"); VCELL(sym_features) = EOL; for(;*feats;feats++) { VCELL(sym_features) = cons(sysintern(*feats), VCELL(sym_features)); } } struct errdesc {char *msg;char *s_response;short parent_err;}; struct errdesc errmsgs[] = { {"Wrong number of args",0,0}, {"numerical overflow",0,FPE_SIGNAL}, {"Argument out of range",0,FPE_SIGNAL}, {"Could not allocate","out-of-storage",0}, {"EXIT","end-of-program",-1}, {"hang up","hang-up",EXIT}, {"user interrupt","user-interrupt",0}, {"arithmetic error","arithmetic-error",0}, {"bus error",0,0}, {"segment violation",0,0}, {"alarm","alarm-interrupt",0} }; jmp_buf errjmp; int errjmp_ok = 0, ints_disabled = 1, sig_deferred = 0, alrm_deferred; SCM err_exp,err_env; char *err_pos, *err_s_subr; SCM sym_errobj = BOOL_F; SCM sym_loadpath = BOOL_F; long linum = 1; int verbose = 0; long cells_allocated = 0, rt = 0, gc_rt, gc_time_taken; long gc_cells_collected, gc_malloc_collected, gc_ports_collected; void def_err_response(); int handle_it(i) int i; { char *name = errmsgs[i-WNA].s_response; SCM proc; if (name) { proc = VCELL(intern(name,strlen(name))); if NIMP(proc) { apply(proc,EOL,EOL); return i; } } return errmsgs[i-WNA].parent_err; } SCM repl_driver(argc,argv) int argc; char **argv; { long i; stack_start_ptr = &i; i=setjmp(errjmp); drloop: switch ((int)i) { default: { char *name = errmsgs[i-WNA].s_response; if (name) { SCM proc = VCELL(intern(name,strlen(name))); if NIMP(proc) apply(proc,EOL,EOL); } if (i=errmsgs[i-WNA].parent_err) goto drloop; def_err_response(); goto reset_toplvl; } case 0: errjmp_ok = 1; errno = 0; alrm_deferred = 0; sig_deferred = 0; ints_disabled = 0; progargs = EOL; while (argc--) progargs = cons(makfromstr(argv[argc], strlen(argv[argc])), progargs); { #ifdef nosve char *init_path= INIT_PATH ; SCM name = makfromstr(init_path, (sizet) (strlen(init_path))); #else SCM name = lgetenv(makfromstr("SCM_INIT_PATH", (sizet) (sizeof "SCM_INIT_PATH"-1))); if FALSEP(name) # ifdef IMPLINIT name = makfromstr(IMPLINIT, (sizet) (sizeof IMPLINIT-1)); # else goto noname; # endif /* IMPLINIT */ #endif /* nosve */ if (BOOL_T != tryload(name)) noname: wta(name,"Could not open file",s_load); } case -2: reset_toplvl: errjmp_ok = 1; alrm_deferred = 0; sig_deferred = 0; ints_disabled = 0; VCELL(sym_loadpath) = BOOL_F; repl(); err_pos = (char *)EXIT; i= EXIT; goto drloop; /* encountered EOF on stdin */ case -1: return throwval; } } SCM line_num() { return MAKINUM(linum); } SCM prog_args() { return progargs; } extern char s_heap[]; extern sizet hplim_ind; extern CELLPTR *hplims; void growth_mon(obj, size, units) char *obj; long size; char *units; { if (verbose>1) { lputs("; grew ",STREAM(def_outp)); lputs(obj,STREAM(def_outp)); lputs(" to ",STREAM(def_outp)); intprint(size,10,STREAM(def_outp)); lputc(' ',STREAM(def_outp)); lputs(units,STREAM(def_outp)); if ((verbose>3) && (obj==s_heap)) { sizet i=0; lputs("; heap segments:",STREAM(def_outp)); while(i2) lputs(";GC ",STREAM(def_outp)); fflush(STREAM(def_outp)); gc_rt = INUM(my_time()); gc_cells_collected = 0; gc_malloc_collected = 0; gc_ports_collected = 0; } void gc_end() { gc_rt = INUM(my_time()) - gc_rt; gc_time_taken = gc_time_taken + gc_rt; if (verbose>2) { intprint(time_in_msec(gc_rt),10,STREAM(def_outp)); lputs(" cpu mSec, ",STREAM(def_outp)); intprint(gc_cells_collected,10,STREAM(def_outp)); lputs(" cells, ",STREAM(def_outp)); intprint(gc_malloc_collected,10,STREAM(def_outp)); lputs(" malloc, ",STREAM(def_outp)); intprint(gc_ports_collected,10,STREAM(def_outp)); lputs(" ports collected\n",STREAM(def_outp)); fflush(STREAM(def_outp)); } } void repl_report() { if (verbose) { lputs(";Evaluation took ",STREAM(def_outp)); intprint(time_in_msec(INUM(my_time())-rt),10,STREAM(def_outp)); lputs(" mSec (",STREAM(def_outp)); intprint(time_in_msec(gc_time_taken),10,STREAM(def_outp)); lputs(" in gc) ",STREAM(def_outp)); intprint(cells_allocated,10,STREAM(def_outp)); lputs(" cons work\n",STREAM(def_outp)); } } SCM prolixity(arg) SCM arg; { int old = verbose; if (!UNBNDP(arg)) { if FALSEP(arg) verbose = 0; else verbose = INUM(arg); } return MAKINUM(old); } void repl() { SCM x; while(1) { lputs("> ",STREAM(def_outp)); fflush(STREAM(def_outp)); cur_inp = def_inp; cur_outp = def_outp; x = lread(def_inp); if (x == EOF_VAL) break; if (trans && !ungetted) lungetc(lgetc(stdin),stdin); /* assure newline out */ rt = INUM(my_time()); cells_allocated = 0; gc_time_taken = 0; x = EVAL(x,EOL); repl_report(); iprin1(x,STREAM(def_outp),1); lputc('\n',STREAM(def_outp)); } } SCM quit(n) SCM n; { if UNBNDP(n) n=INUM0; throwval = n; longjmp(errjmp,-1); } void han_sig() { sig_deferred=0; if (handle_it(INT_SIGNAL) != INT_SIGNAL) wta(UNDEFINED,(char *)INT_SIGNAL,""); } void han_alrm() { alrm_deferred = 0; if (handle_it(ALRM_SIGNAL) != ALRM_SIGNAL) wta(UNDEFINED,(char *)ALRM_SIGNAL,""); } SCM abrt() { longjmp(errjmp,-2); } SCM tryload(filename) SCM filename; { ASSERT(NIMP(filename) && STRINGP(filename),filename,ARG1,s_load); { SCM oloadpath = VCELL(sym_loadpath); long olninum = linum; SCM form,port; port = open_file(filename, makfromstr("r", (sizet) 1)); if FALSEP(port) return port; VCELL(sym_loadpath) = filename; linum = 1; while(1) { form = lread(port); if (EOF_VAL == form) break; SIDEVAL(form,EOL); } close_port(port); linum = olninum; VCELL(sym_loadpath) = oloadpath; } return BOOL_T; } void err_head(str) char *str; { lputc('\n',STREAM(def_outp)); if(BOOL_F != VCELL(sym_loadpath)) { iprin1(VCELL(sym_loadpath),STREAM(def_outp),1); lputs(", line ",STREAM(def_outp)); intprint((long)linum,10,STREAM(def_outp)); lputs(": ",STREAM(def_outp)); } fflush(STREAM(def_outp)); if (errno>0) perror(str); fflush(stderr); } void warn(str1,str2) char *str1,*str2; { err_head("WARNING"); lputs("WARNING: ",STREAM(def_outp)); lputs(str1,STREAM(def_outp)); lputs(str2,STREAM(def_outp)); lputc('\n',STREAM(def_outp)); fflush(STREAM(def_outp)); } SCM seterrno(arg) SCM arg; { errno = INUM(arg); return UNSPECIFIED; } static char s_perror[]="perror"; SCM lperror(arg) SCM arg; { ASSERT(NIMP(arg) && STRINGP(arg),arg,ARG1,s_perror); err_head(CHARS(arg)); return UNSPECIFIED; } extern cell dummy_cell; void def_err_response() { SCM obj = VCELL(sym_errobj); DEFER_INTS; err_head("ERROR"); lputs("ERROR: ",STREAM(def_outp)); if (err_s_subr && *err_s_subr) { lputs(err_s_subr,STREAM(def_outp)); lputs(": ",STREAM(def_outp)); } #ifdef nosve if ((~0x1fL) & (short)err_pos) lputs(err_pos,STREAM(def_outp)); else if (WNA>(short)err_pos) { lputs("Wrong type in arg",STREAM(def_outp)); lputc('0'+(short)err_pos,STREAM(def_outp)); } #else if ((~0x1fL) & (long)err_pos) lputs(err_pos,STREAM(def_outp)); else if (WNA>(long)err_pos) { lputs("Wrong type in arg",STREAM(def_outp)); lputc('0'+(int)err_pos,STREAM(def_outp)); } #endif else { lputs(errmsgs[((int)err_pos)-WNA].msg,STREAM(def_outp)); goto outobj; } if (IMP(obj) || SYMBOLP(obj)) { outobj: if (!UNBNDP(obj)) { lputs(((long)err_pos == WNA)?" to ":" ",STREAM(def_outp)); iprin1(obj,STREAM(def_outp),1); } } else lputs(" (see errobj)",STREAM(def_outp)); if UNBNDP(err_exp) goto getout; if NIMP(err_exp) { lputs("\n; in expression: ",STREAM(def_outp)); if (err_exp == (SCM)&dummy_cell) iprin1(CAR(err_exp),STREAM(def_outp),1); else if ECONSP(err_exp) iprlist("(... ",err_exp,')',STREAM(def_outp),1); else iprin1(err_exp,STREAM(def_outp),1); } if NULLP(err_env) lputs("\n; in top level environment.",STREAM(def_outp)); else { SCM env=err_env; lputs("\n; in scope:",STREAM(def_outp)); while NNULLP(env) { lputc('\n',STREAM(def_outp)); lputs("; ",STREAM(def_outp)); iprin1(CAR(CAR(env)),STREAM(def_outp),1); env = CDR(env); } } getout: lputc('\n',STREAM(def_outp)); fflush(STREAM(def_outp)); err_exp = err_env = UNDEFINED; if (!errjmp_ok) { iprin1(obj,STREAM(def_outp),1); lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION\n",STREAM(def_outp)); quit(MAKINUM(errno?(long)errno:1L)); } errno=0; ALLOW_INTS; } void everr(exp,env,arg,pos,s_subr) SCM exp,env,arg; char *pos, *s_subr; { err_exp=exp; err_env=env; VCELL(sym_errobj)=arg; err_pos=pos; err_s_subr=s_subr; if (((~0x1fL) & (long)pos) || (WNA>(long)pos)) { def_err_response(); abrt(); } longjmp(errjmp,(int)pos); } void wta(arg,pos,s_subr) SCM arg; char *pos, *s_subr; { everr(UNDEFINED,EOL,arg,pos,s_subr); } SCM cur_input_port() { return cur_inp; } SCM cur_output_port() { return cur_outp; } char s_set_cur_inp[]="set-current-input-port"; char s_set_cur_outp[]="set-current-output-port"; SCM set_cur_inp(port) SCM port; { SCM oinp = cur_inp; ASSERT(NIMP(port) && OPINPORTP(port), port,ARG1,s_set_cur_inp); cur_inp = port; return oinp; } SCM set_cur_outp(port) SCM port; { SCM ooutp = cur_outp; ASSERT(NIMP(port) && OPOUTPORTP(port), port,ARG1,s_set_cur_outp); cur_outp = port; return ooutp; } static iproc subr0s[]={ {&s_set_cur_inp[4],cur_input_port}, {&s_set_cur_outp[4],cur_output_port}, {"transcript-off",trans_off}, {"program-arguments",prog_args}, {"line-number",line_num}, {"abort",abrt}, {0,0}}; static iproc subr1s[]={ {s_set_cur_inp,set_cur_inp}, {s_set_cur_outp,set_cur_outp}, #ifdef IO_EXTENSIONS {s_file_position,file_position}, #endif {"transcript-on",trans_on}, {s_load,tryload}, {s_tryload,tryload}, {"set-errno!",seterrno}, {s_perror,lperror}, {"make-arbiter", makarb}, {s_tryarb, tryarb}, {s_relarb, relarb}, {0,0}}; static iproc subr1os[]={ {s_read,lread}, {s_read_char,read_char}, {s_peek_char,peek_char}, {s_newline,newline}, #ifdef IO_EXTENSIONS {s_flush,lflush}, #endif /* def IO_EXTENSIONS */ {"quit",quit}, {"verbose",prolixity}, {0,0}}; static iproc subr2os[]={ {s_write,lwrite}, {s_display,display}, {s_write_char,write_char}, #ifdef IO_EXTENSIONS {s_file_set_pos,file_set_position}, {s_read_to_str,read_to_string}, #endif /* def IO_EXTENSIONS */ {0,0}}; SCM sym_char_code_limit; void init_repl() { sym_char_code_limit = sysintern("char-code-limit"); VCELL(sym_char_code_limit) = MAKINUM(CHAR_CODE_LIMIT); sym_errobj=sysintern("errobj"); VCELL(sym_errobj)=UNDEFINED; sym_loadpath=sysintern("*load-pathname*"); VCELL(sym_loadpath)=BOOL_F; transcript = BOOL_F; init_iprocs(subr0s, tc7_subr_0); init_iprocs(subr1os, tc7_subr_1o); init_iprocs(subr1s, tc7_subr_1); init_iprocs(subr2os, tc7_subr_2o); } @EOF chmod 666 repl.c echo x - scl.c cat >scl.c <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ #include "scm.h" #ifdef FLOATS #include static char s_makrect[]="make-rectangular",s_makpolar[]="make-polar", s_magnitude[]="magnitude",s_angle[]="angle", s_real_part[]="real-part",s_imag_part[]="imag-part", s_in2ex[]="inexact->exact"; #endif char s_inexactp[]="inexact?"; static char s_expt[]="expt",s_zerop[]="zero?", s_positivep[]="positive?",s_negativep[]="negative?"; static char s_eqp[]="=",s_lessp[]="<",s_grp[]=">", s_lesseqp[]="<=",s_greqp[]=">="; static char s_max[]="max",s_min[]="min"; static char s_sum[]="+",s_difference[]="-",s_product[]="*",s_divide[]="/"; static char s_number2string[]="number->string", s_str2number[]="string->number"; static char s_list_tail[]="list-tail"; static char s_str2list[]="string->list"; static char s_st_copy[]="string-copy", s_st_fill[]="string-fill!"; static char s_vect2list[]="vector->list", s_ve_fill[]="vector-fill!"; #ifdef FLOATS static char s_memv[]="memv",s_assv[]="assv"; SCM eqv(x,y) SCM x,y; { if (x == y) return BOOL_T; if IMP(x) return BOOL_F; if IMP(y) return BOOL_F; /* this ensures that types and length are the same. */ if (CAR(x) != CAR(y)) return BOOL_F; if INEXP(x) return eqp(x,y,EOL); return BOOL_F; } SCM memv(x,lst) /* m.borza 12.2.91 */ SCM x,lst; { for(;NIMP(lst);lst = CDR(lst)) { ASSERT(CONSP(lst),lst,ARG2,s_memv); if (eqv(CAR(lst),x) == BOOL_T) return lst; } ASSERT(NULLP(lst),lst,ARG2,s_memv); return BOOL_F; } SCM assv(x,alist) /* m.borza 12.2.91 */ SCM x,alist; { SCM tmp; for(;NIMP(alist);alist=CDR(alist)) { ASSERT(CONSP(alist),alist,ARG2,s_assv); tmp = CAR(alist); ASSERT(CONSP(tmp),alist,ARG2,s_assv); if (eqv(CAR(tmp),x) == BOOL_T) return tmp; } ASSERT(NULLP(alist),alist,ARG2,s_assv); return BOOL_F; } #endif /* FLOATS */ SCM list_tail(lst,k) SCM lst, k; { register long i; ASSERT(INUMP(k),k,ARG2,s_list_tail); i = INUM(k); while (i-- > 0) { ASSERT(NIMP(lst) && CONSP(lst),lst,ARG1,s_list_tail); lst=CDR(lst); } return lst; } SCM string2list(str) SCM str; { long i; SCM res = EOL; unsigned char *src; ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_str2list); src = (unsigned char *)CHARS(str); for(i=LENGTH(str)-1;i>=0;i--) res = cons(MAKICHR(src[i]),res); return res; } SCM string_copy(str) SCM str; { ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_st_copy); return makfromstr(CHARS(str),(sizet)LENGTH(str)); } SCM string_fill(str,chr) SCM str,chr; { register char *dst,c; register long k; ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_st_fill); ASSERT(ICHRP(chr),chr,ARG2,s_st_fill); c = ICHR(chr); dst = CHARS(str); for(k=LENGTH(str)-1;k>=0;k--) dst[k] = c; return UNSPECIFIED; } SCM vector2list(v) SCM v; { SCM res = EOL; long i; SCM *data; ASSERT(NIMP(v) && VECTORP(v),v,ARG1,s_vect2list); data=VELTS(v); for(i=LENGTH(v)-1;i>=0;i--) res = cons(data[i],res); return res; } SCM vector_fill(v,fill) SCM v,fill; { register long i; register SCM *data; ASSERT(NIMP(v) && VECTORP(v),v,ARG1,s_ve_fill); data = VELTS(v); for(i=LENGTH(v)-1;i>=0;i--) data[i] = fill; return UNSPECIFIED; } SCM numberp(x) SCM x; { if INUMP(x) return BOOL_T; #ifdef FLOATS if (NIMP(x) && INEXP(x)) return BOOL_T; #endif return BOOL_F; } #ifdef FLOATS #define NUMBERP(x) (INUMP(x) || (NIMP(x) && INEXP(x))) SCM realp(x) SCM x; { if INUMP(x) return BOOL_T; if IMP(x) return BOOL_F; if REALP(x) return BOOL_T; return BOOL_F; } SCM intp(x) SCM x; { double r; if INUMP(x) return BOOL_T; if IMP(x) return BOOL_F; if (!INEXP(x)) return BOOL_F; if CPLXP(x) return BOOL_F; r = REALPART(x); if (r == floor(r)) return BOOL_T; return BOOL_F; } #else #define NUMBERP(x) INUMP(x) #endif /* FLOATS */ SCM inexactp(x) SCM x; { #ifdef FLOATS if (NIMP(x) && INEXP(x)) return BOOL_T; #endif return BOOL_F; } SCM eqp(x,y,args) SCM x,y,args; { #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x) && INEXP(x),x,ARG1,s_eqp); for(;;) { if INUMP(y) { if (REALPART(x) != ((double)INUM(y))) return BOOL_F; if CPLXP(x) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_int; } ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_eqp); if (REALPART(x) != REALPART(y)) return BOOL_F; if CPLXP(x) if CPLXP(y) { if (IMAG(x) != IMAG(y)) return BOOL_F; } else return BOOL_F; else if CPLXP(y) return BOOL_F; if NULLP(args) return BOOL_T; y = CAR(args); args = CDR(args); } } #else ASSERT(INUMP(x),x,ARG1,s_eqp); #endif for(;;) { #ifdef FLOATS do_int: if NINUMP(y) { ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_eqp); if (((double)INUM(x)) != REALPART(y)) return BOOL_F; if CPLXP(y) return BOOL_F; } else #else ASSERT(INUMP(y),y,ARG2,s_eqp); #endif if ((long)x != (long)y) return BOOL_F; if NULLP(args) return BOOL_T; y = CAR(args); args = CDR(args); } } SCM lessp(x,y,args) SCM x,y,args; { #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x) && REALP(x),x,ARG1,s_lessp); for(;;) { do_flt: if INUMP(y) { if (REALPART(x) >= ((double)INUM(y))) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_int; } ASSERT(NIMP(y) && REALP(y),y,ARG2,s_lessp); if (REALPART(x) >= REALPART(y)) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); } } #else ASSERT(INUMP(x),x,ARG1,s_lessp); #endif for(;;) { #ifdef FLOATS do_int: if NINUMP(y) { ASSERT(NIMP(y) && REALP(y),y,ARG2,s_lessp); if (((double)INUM(x)) >= REALPART(y)) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_flt; } #else ASSERT(INUMP(y),y,ARG2,s_lessp); #endif if ((long)x >= (long)y) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); } } SCM greaterp(x,y,args) SCM x,y,args; { #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x) && REALP(x),x,ARG1,s_grp); for(;;) { do_flt: if INUMP(y) { if (REALPART(x) <= ((double)INUM(y))) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_int; } ASSERT(NIMP(y) && REALP(y),y,ARG2,s_grp); if (REALPART(x) <= REALPART(y)) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); } } #else ASSERT(INUMP(x),x,ARG1,s_grp); #endif for(;;) { #ifdef FLOATS do_int: if NINUMP(y) { ASSERT(NIMP(y) && REALP(y),y,ARG2,s_grp); if (((double)INUM(x)) <= REALPART(y)) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_flt; } #else ASSERT(INUMP(y),y,ARG2,s_grp); #endif if ((long)x <= (long)y) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); } } SCM lesseqp(x,y,args) SCM x,y,args; { #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x) && REALP(x),x,ARG1,s_lesseqp); for(;;) { do_flt: if INUMP(y) { if (REALPART(x) > ((double)INUM(y))) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_int; } ASSERT(NIMP(y) && REALP(y),y,ARG2,s_lesseqp); if (REALPART(x) > REALPART(y)) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); } } #else ASSERT(INUMP(x),x,ARG1,s_lesseqp); #endif for(;;) { #ifdef FLOATS do_int: if NINUMP(y) { ASSERT(NIMP(y) && REALP(y),y,ARG2,s_lesseqp); if (((double)INUM(x)) > REALPART(y)) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_flt; } #else ASSERT(INUMP(y),y,ARG2,s_lesseqp); #endif if ((long)x > (long)y) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); } } SCM greatereqp(x,y,args) SCM x,y,args; { #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x) && REALP(x),x,ARG1,s_greqp); for(;;) { do_flt: if INUMP(y) { if (REALPART(x) < ((double)INUM(y))) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_int; } ASSERT(NIMP(y) && REALP(y),y,ARG2,s_greqp); if (REALPART(x) < REALPART(y)) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); } } #else ASSERT(INUMP(x),x,ARG1,s_greqp); #endif for(;;) { #ifdef FLOATS do_int: if NINUMP(y) { ASSERT(NIMP(y) && REALP(y),y,ARG2,s_greqp); if (((double)INUM(x)) < REALPART(y)) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); goto do_flt; } #else ASSERT(INUMP(y),y,ARG2,s_greqp); #endif if ((long)x < (long)y) return BOOL_F; if NULLP(args) return BOOL_T; x = y; y = CAR(args); args = CDR(args); } } SCM zerop(z) SCM z; { #ifdef FLOATS if NINUMP(z) { ASSERT(NIMP(z) && INEXP(z),z,ARG1,s_zerop); return (z == flo0) ? BOOL_T : BOOL_F; } #else ASSERT(INUMP(z),z,ARG1,s_zerop); #endif return (z==INUM0) ? BOOL_T: BOOL_F; } SCM positivep(x) SCM x; { #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x) && REALP(x),x,ARG1,s_positivep); return (REALPART(x)>0.0) ? BOOL_T : BOOL_F; } #else ASSERT(INUMP(x),x,ARG1,s_positivep); #endif return (x>INUM0) ? BOOL_T : BOOL_F; } SCM negativep(x) SCM x; { #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x) && REALP(x),x,ARG1,s_negativep); return (REALPART(x)<0.0) ? BOOL_T : BOOL_F; } #else ASSERT(INUMP(x),x,ARG1,s_negativep); #endif return (xREALPART(y))?y:makdbl((double)INUM(x),0.0); ASSERT(NIMP(x) && REALP(x),x,ARG1,s_min); return (REALPART(x) > REALPART(y)) ? y : x; } if NINUMP(x) { ASSERT(NIMP(x) && REALP(x),x,ARG1,s_min); return (REALPART(x)>INUM(y))?makdbl((double)INUM(y),0.0):x; } #else ASSERT(INUMP(x),x,ARG1,s_min); if NINUMP(y) if UNBNDP(y) return x; else ASSERT(INUMP(y),y,ARG2,s_min); #endif return ((long)x > (long)y) ? y : x; } SCM sum(x,y) SCM x,y; { if UNBNDP(y) { if UNBNDP(x) return INUM0; ASSERT(NUMBERP(x),x,ARG1,s_sum); return x; } #ifdef FLOATS if NINUMP(x) { double i=0.0; ASSERT(NIMP(x) && INEXP(x),x,ARG1,s_sum); if INUMP(y) {SCM t=x; x=y; y=t; goto intx;} ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_sum); if CPLXP(x) i = IMAG(x); if CPLXP(y) i += IMAG(y); return makdbl(REALPART(x) + REALPART(y),i); } if NINUMP(y) { ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_sum); intx: return makdbl(INUM(x)+REALPART(y),CPLXP(y)?IMAG(y):0.0); } #else ASSERT(INUMP(x),x,ARG1,s_sum); ASSERT(INUMP(y),y,ARG2,s_sum); #endif { long z; z = INUM(x)+INUM(y); y = MAKINUM(z); ASSERT(INUM(y) == z,y,OVFLOW,s_sum); return y; } } SCM difference(x,y) SCM x,y; { #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x),x,ARG1,s_difference); if UNBNDP(y) { ASSERT(INEXP(x),x,ARG1,s_difference); return makdbl(-REALPART(x),CPLXP(x)?-IMAG(x):0.0); } if INUMP(y) return sum(x,MAKINUM(-INUM(y))); ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_difference); if CPLXP(x) if CPLXP(y) return makdbl(REAL(x)-REAL(y), IMAG(x)-IMAG(y)); else return makdbl(REAL(x)-REALPART(y), IMAG(x)); return makdbl(REALPART(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); } if NINUMP(y) if UNBNDP(y) {y = x; x = INUM0;} else { ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_difference); return makdbl(INUM(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); } #else ASSERT(INUMP(x),x,ARG1,s_difference); if UNBNDP(y) {y = x; x = INUM0;} else ASSERT(INUMP(y),y,ARG2,s_difference); #endif x = INUM(x)-INUM(y); y = MAKINUM(x); ASSERT(INUM(y) == x,y,OVFLOW,s_difference); return y; } SCM product(x,y) SCM x,y; { if UNBNDP(y) { if UNBNDP(x) return MAKINUM(1L); ASSERT(NUMBERP(x),x,ARG1,s_product); return x; } #ifdef FLOATS if NINUMP(x) { ASSERT(NIMP(x) && INEXP(x),x,ARG1,s_product); if INUMP(y) {SCM t=x; x=y; y=t; goto intx;} ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_product); if CPLXP(x) if CPLXP(y) return makdbl(REAL(x)*REAL(y)-IMAG(x)*IMAG(y), REAL(x)*IMAG(y)+IMAG(x)*REAL(y)); else return makdbl(REAL(x)*REALPART(y), IMAG(x)*REALPART(y)); return makdbl(REALPART(x)*REALPART(y), CPLXP(y)?REALPART(x)*IMAG(y):0.0); } if NINUMP(y) { ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_product); intx: return makdbl(INUM(x)*REALPART(y), CPLXP(y)?INUM(x)*IMAG(y):0.0); } #else ASSERT(INUMP(x),x,ARG1,s_product); ASSERT(INUMP(y),y,ARG2,s_product); #endif { long i, j, k; i = INUM(x); if (0 == i) return x; j = INUM(y); k = i * j; y = MAKINUM(k); ASSERT((k == INUM(y)) && (k/i == j),y,OVFLOW,s_product); return y; } } SCM divide(x,y) SCM x,y; { #ifdef FLOATS if NINUMP(x){ double d; ASSERT(NIMP(x) && INEXP(x),x,ARG1,s_divide); if UNBNDP(y) { if REALP(x) return makdbl(1.0/REALPART(x),0.0); ASSERT(CPLXP(x),x,ARG1,s_divide); { double r=REAL(x),i=IMAG(x); d=r*r+i*i; return makdbl(r/d,-i/d); } } if INUMP(y) return makdbl(REALPART(x)/INUM(y), CPLXP(x)?IMAG(x)/INUM(y):0.0); ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_divide); if CPLXP(y) { double r=REAL(y),i=IMAG(y),a=REALPART(x); d=r*r+i*i; if CPLXP(x) return makdbl((a*r+IMAG(x)*i)/d,(IMAG(x)*r-a*i)/d); return makdbl((a*r)/d,(-a*i)/d); } d=REALPART(y); return makdbl(REALPART(x)/d, CPLXP(x)?IMAG(x)/d:0.0); } if NINUMP(y) if UNBNDP(y) return makdbl(1.0/INUM(x),0.0); else { ASSERT(NIMP(y) && INEXP(y),y,ARG2,s_divide); if CPLXP(y) { double r=REAL(y),i=IMAG(y); long a=INUM(x); double d=r*r+i*i; if CPLXP(x) return makdbl((a*r+IMAG(x)*i)/d,(IMAG(x)*r-a*i)/d); return makdbl((a*r)/d,(-a*i)/d); } return makdbl(INUM(x)/REALPART(y) ,0.0); ov: return makdbl(INUM(x)/(double)INUM(y),0.0); } #else ASSERT(INUMP(x),x,ARG1,s_divide); if UNBNDP(y) { ASSERT(((x== MAKINUM(1L)) || (x== MAKINUM(-1L))), x,OVFLOW,s_divide); return x; ov: wta(y,OVFLOW,s_divide); } ASSERT(INUMP(y),y,ARG2,s_divide); #endif { long z; z = INUM(y); ASRTGO(z && !(INUM(x)%z),ov); z = INUM(x)/z; y = MAKINUM(z); ASRTGO(INUM(y) == z,ov); return y; } } #ifdef FLOATS static char s_exp[]="exp",s_log[]="log"; SCM lexp(z) SCM z; { if NINUMP(z) { ASSERT(NIMP(z),z,ARG1,s_exp); if REALP(z) return makdbl(exp(REALPART(z)),0.0); ASSERT(CPLXP(z),z,ARG1,s_exp); { double m=exp(REAL(z)); return makdbl(m*cos(IMAG(z)),m*sin(IMAG(z))); } } return makdbl(exp((double)INUM(z)),0.0); } SCM llog(z) SCM z; { if NINUMP(z) { ASSERT(NIMP(z),z,ARG1,s_log); if REALP(z) if (REALPART(z)>0.0) return makdbl(log(REALPART(z)),0.0); else return makdbl(log(-REALPART(z)),atan(-1.0)); ASSERT(CPLXP(z),z,ARG1,s_log); { double i=IMAG(z),r=REAL(z); return makdbl(log(sqrt(i*i+r*r)),atan2(IMAG(z),REAL(z))); } } if (z>INUM0) return makdbl(log((double)INUM(z)),0.0); else return makdbl(log(-(double)INUM(z)),atan(-1.0)); } #endif SCM expt(z1,z2) SCM z1,z2; { #ifdef FLOATS double d1; tloop: if NINUMP(z2) { ASSERT(NIMP(z2),z2,ARG2,s_expt); if INUMP(z1) d1=(double)INUM(z1); else { ASSERT(NIMP(z1),z1,ARG1,s_expt); if REALP(z1) d1=REALPART(z1); else return lexp(product(z2,llog(z1))); } if REALP(z2) { if (d1<0.0) return makdbl(0.0,pow(-d1, REALPART(z2))); else return makdbl(pow(d1, REALPART(z2)),0.0); } ASSERT(CPLXP(z2),z2,ARG2,s_expt); if (d1<0.0) { double mag=pow(-d1,REAL(z2)); double l=IMAG(z2)*log(-d1); return makdbl(mag*sin(l),mag*cos(l)); } else { double mag=pow(d1,REAL(z2)); double l=IMAG(z2)*log(d1); return makdbl(mag*cos(l),mag*sin(l)); } } #else tloop: ASSERT(INUMP(z2),z2,ARG2,s_expt); ASSERT(INUMP(z1),z1,ARG1,s_expt); #endif if (z2 0;n /= rad) i++; j = i; n = num; if (n < 0) {n = -n; *p++ = '-'; i--;} while (i--) { d = n % rad; n /= rad; p[i] = d + ((d < 10) ? '0' : 'a' - 10); } return j; } #ifdef FLOATS SCM istr2flo(str,len) char *str; long len; { char *p = str; int c,j=0,prec=0,point= -999; double r=0.0,n=0.0; /* r is real part; n is current part */ lp: if (len > 1) if ((p[1]=='i') || (p[1]=='I')) { if (len!=2) return BOOL_F; switch (p[0]) { case '-': return makdbl(r,-1.0); case '+': return makdbl(r,1.0); default: return BOOL_F; } } if (len > 0) switch (p[0]) { case '-': case '+': j++; default:; } while(j < len) switch(c = p[j++]) { case '.': if (len == 1) return BOOL_F; if (point> -900) return BOOL_F; point = 0; continue; case 'e': case 'E': case 'd': case 'D': case 'l': case 'L': case 's': case 'S': case 'f': case 'F': prec=2; { int xpo=0,sgn=1; if ((len-j) > 1) switch (p[j]) { case '-': sgn= -1; case '+': j++; default:; } while(j < len) switch(c = p[j++]) { case DIGITS: xpo = xpo * 10 + c - '0'; continue; case '+': case '-': case 'i': case 'I': j--; goto out; default: return BOOL_F; } out: point=((point< -900)?0:point)-xpo*sgn; if (point<0) for(;point;point++) n*=10.0; outq: continue; } case '/': { int xpo=0; if (point >= -900) return BOOL_F; while(j < len) { switch(c = p[j++]) { case DIGITS: xpo = xpo * 10 + c - '0'; continue; default: return BOOL_F; case '+': case '-': case 'i': case 'I': j--; } break; } if (!xpo) return BOOL_F; n /= xpo; goto outq; } case '+': case '-': if (point>0) while(point--) n/=10.0; r=(p[0]=='-')?-n:n;n=0.0;point= -999;prec=3; p += --j;len -= j;j = 0; goto lp; case 'i': case 'I': if (j!=len) return BOOL_F; if (point>0) while(point--) n/=10.0; return makdbl(r,(p[0]=='-')?-n:n); case '#': c = '0'; case DIGITS: point++; n = n * 10.0 + c - '0'; continue; default: return BOOL_F; } if (point>0) while(point--) n/=10.0; if (p[0]=='-') n = -n; switch (prec) { default: case 2: return makdbl(n,0.0); case 3: return BOOL_F; } } #endif /* FLOATS */ SCM number2string(x,radix) SCM x,radix; { if UNBNDP(radix) radix=MAKINUM(10L); else ASSERT(INUMP(radix),radix,ARG2,s_number2string); #ifdef FLOATS if NINUMP(x) { char num_buf[FLOBUFLEN]; ASSERT(NIMP(x) && INEXP(x),x,ARG1,s_number2string); return makfromstr(num_buf,iflo2str(x,num_buf)); } #else ASSERT(INUMP(x),x,ARG1,s_number2string); #endif { char num_buf[INTBUFLEN]; return makfromstr(num_buf,iint2str(INUM(x),(int)INUM(radix),num_buf)); } } SCM istr2int(str,len,radix) char *str; long len; long radix; { SCM res; register char *p = str; register int c,rad = radix,i = 0; register long n = 0; if ((len) > 1) switch (p[0]) { case '-': case '+': i++; default:;} while(i < len) switch(c = p[i++]) { case DIGITS: c = c - '0'; goto accumulate; case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': c = c-'A'+10; goto accumulate; case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': c = c-'a'+10; accumulate: if ((c<0)||(c>=rad)) return BOOL_F; res = n; n = n * rad - c; if ((n + c)/rad != res) return BOOL_F; continue; default: return BOOL_F;} if (p[0]!='-') n = -n; res = MAKINUM(n); if (INUM(res) != n) return BOOL_F; return res; } SCM istring2number(str,len,radix) char *str; long len; long radix; { char ex = 0; int i = 0; switch ((int)len) { case 0: return BOOL_F; case 1: switch (str[0]) { case '-': case '+': return BOOL_F; default:;} default:;} while (((len-i) > 2) && str[i] == '#' && ++i) switch (str[i++]) { case 'b': case 'B': radix = 2; break; case 'o': case 'O': radix = 8; break; case 'd': case 'D': radix = 10; break; case 'x': case 'X': radix = 16; break; case 'i': case 'I': ex = 2; break; case 'e': case 'E': ex = 1; } switch (ex) { case 1: return istr2int(&str[i],len-i,radix); case 0: { SCM res=istr2int(&str[i],len-i,radix); if ((res!=BOOL_F) || (radix!=10)) return res; } #ifdef FLOATS case 2: return istr2flo(&str[i],len-i); #endif } return BOOL_F; } SCM string2number(str,radix) SCM str,radix; { if UNBNDP(radix) radix=MAKINUM(10L); else ASSERT(INUMP(radix),radix,ARG2,s_str2number); ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_str2number); return istring2number(CHARS(str),LENGTH(str),INUM(radix)); } char s_getenv[]="getenv"; char s_system[]="system"; SCM lsystem(cmd) SCM cmd; { ASSERT(NIMP(cmd) && STRINGP(cmd),cmd,ARG1,s_system); ignore_signals(); #ifdef AZTEC_C cmd = MAKINUM(Execute(CHARS(cmd),0,0)); #else cmd = MAKINUM(system(CHARS(cmd))); #endif unignore_signals(); return cmd; } char *getenv(); SCM lgetenv(nam) SCM nam; { char *val; ASSERT(NIMP(nam) && STRINGP(nam),nam,ARG1,s_getenv); val = getenv(CHARS(nam)); if (!val) return BOOL_F; return makfromstr(val, strlen(val)); } SCM softtype() { return #ifdef nosve intern("nosve", 5); #endif #ifdef MSDOS intern("msdos", sizeof "msdos" -1); #endif #ifdef vms intern("vms", sizeof "vms" -1); #endif #ifdef unix intern("unix", sizeof "unix" -1); #endif #ifdef MWC intern("coherent", sizeof "coherent" -1); #endif #ifdef THINK_C intern("thinkc", (sizet)(sizeof "thinkc" -1)); #endif #ifdef AMIGA intern("amiga", (sizet)(sizeof "amiga" -1)); #endif #ifdef atarist intern("atarist", (sizet)(sizeof "atarist" -1)); #endif } #ifdef vms #include #include static char s_ed[]="ed"; SCM ed(fname) SCM fname; { struct dsc$descriptor_s d; ASSERT(NIMP(fname) && STRINGP(fname),fname,ARG1,s_ed); d.dsc$b_dtype = DSC$K_DTYPE_T; d.dsc$b_class = DSC$K_CLASS_S; d.dsc$w_length = LENGTH(fname); d.dsc$a_pointer = CHARS(fname); /* I don't know what VMS does with signal handlers across the edt$edit call. */ ignore_signals(); edt$edit(&d); unignore_signals(); return fname; } SCM vms_debug() { lib$signal(SS$_DEBUG); return UNSPECIFIED; } #endif static iproc subr0s[]={ {"software-type",softtype}, #ifdef vms {"vms-debug",vms_debug}, #endif {0,0}}; static iproc subr1s[]={ {"number?",numberp}, {"complex?",numberp}, {s_inexactp,inexactp}, #ifdef FLOATS {"real?",realp}, {"rational?",realp}, {"integer?",intp}, {s_real_part,real_part}, {s_imag_part,imag_part}, {s_magnitude,magnitude}, {s_angle,angle}, {s_in2ex,in2ex}, {s_exp,lexp}, {s_log,llog}, #else {"real?",numberp}, {"rational?",numberp}, {"integer?",exactp}, {"floor",numident}, {"ceiling",numident}, {s_trunc,numident}, {"round",numident}, #endif {s_zerop,zerop}, {s_positivep,positivep}, {s_negativep,negativep}, {s_str2list,string2list}, {"list->string",string}, {s_st_copy,string_copy}, {"list->vector",vector}, {s_vect2list,vector2list}, {s_system,lsystem}, {s_getenv,lgetenv}, #ifdef vms {s_ed,ed}, #endif {0,0}}; static iproc asubrs[]={ {s_max,lmax}, {s_min,lmin}, {s_sum,sum}, {s_product,product}, {0,0}}; static iproc subr2s[]={ {s_expt,expt}, #ifdef FLOATS {s_makrect,makrect}, {s_makpolar,makpolar}, {"eqv?",eqv}, {s_memv,memv}, {s_assv,assv}, #else {"eqv?",eq}, {"memv",memq}, {"assv",assq}, #endif {s_list_tail,list_tail}, #ifndef PURE_FUNCTIONAL {s_ve_fill,vector_fill}, {s_st_fill,string_fill}, #endif {0,0}}; static iproc subr2os[]={ {s_difference,difference}, {s_divide,divide}, {s_str2number,string2number}, {s_number2string,number2string}, {0,0}}; static iproc lsubr2s[]={ {s_eqp,eqp}, {s_lessp,lessp}, {s_grp,greaterp}, {s_lesseqp,lesseqp}, {s_greqp,greatereqp}, {0,0}}; #ifdef FLOATS static dblproc cxrs[] = { {"floor",floor}, {"ceiling",ceil}, {"truncate",ltrunc}, {"round",round}, {"sin",sin}, {"cos",cos}, {"tan",tan}, {"asin",asin}, {"acos",acos}, {"atan",atan}, {"sqrt",sqrt}, {"exact->inexact",floident}, {0,0}}; #endif void init_scl() { #ifdef FLOATS init_iprocs(cxrs, tc7_cxr); #endif /* FLOATS */ init_iprocs(subr0s, tc7_subr_0); init_iprocs(subr1s,tc7_subr_1); init_iprocs(subr2os,tc7_subr_2o); init_iprocs(subr2s,tc7_subr_2); init_iprocs(asubrs, tc7_asubr); init_iprocs(lsubr2s,tc7_lsubr_2); } @EOF chmod 666 scl.c echo x - sys.c cat >sys.c <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ #include #include #define IN_SYS #include "scm.h" #ifdef vms # ifndef CHEAP_CONTINUATIONS # include "setjump.h" # else # include # endif /* ndef CHEAP_CONTINUATIONS */ #else # include #endif /* def vms */ #define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\ else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}} char s_make_vector[]="make-vector"; char s_nogrow[]="could not grow", s_heap[]="heap", s_hplims[]="hplims"; void grow_throw(), gc_mark(), mark_locations(), gc_sweep(); static char s_input_portp[]="input-port?", s_output_portp[]="output-port?"; static char s_close_port[]="close-port"; static char s_open_file[]="open-file"; SCM open_file(filename, modes) SCM filename, modes; { FILE *f; register SCM z; ASSERT(NIMP(filename) && STRINGP(filename), filename,ARG1,s_open_file); ASSERT(NIMP(modes) && STRINGP(modes), modes,ARG1,s_open_file); NEWCELL(z); DEFER_INTS; SYSCALL(f = fopen(CHARS(filename),CHARS(modes));); if (!f) z = BOOL_F; else { SETLENGTH(z,0L,(((strchr(CHARS(modes),'r') || strchr(CHARS(modes),'+') )?tc_inport:0) | ((strchr(CHARS(modes),'w') || strchr(CHARS(modes),'a') || strchr(CHARS(modes),'+') )?tc_outport:0))); SETSTREAM(z,f); } ALLOW_INTS; return z; } #ifdef IO_EXTENSIONS #ifdef HAVE_PIPE FILE *popen(); static char s_op_pipe[]="open-pipe"; static char s_cls_pipe[]="close-pipe"; SCM open_pipe(pipestr,modes) SCM pipestr,modes; { FILE *f; register SCM z; ASSERT(NIMP(pipestr) && STRINGP(pipestr),pipestr,ARG1,s_op_pipe); ASSERT(NIMP(modes) && STRINGP(modes),modes,ARG1,s_op_pipe); NEWCELL(z); /* DEFER_INTS, SYSCALL, and ALLOW_INTS are probably paranoid here*/ DEFER_INTS; ignore_signals(); SYSCALL(f = popen(CHARS(pipestr),CHARS(modes));); unignore_signals(); if (!f) z = BOOL_F; else { SETLENGTH(z,0L,strchr(CHARS(modes),'r')?tc_inpipe:tc_outpipe); SETSTREAM(z,f); } init_signals(); ALLOW_INTS; return z; } SCM close_pipe(f) SCM f; { int ans; ASSERT(NIMP(f) && PIPEP(f),f,ARG1,s_cls_pipe); if CLOSEDP(f) return UNSPECIFIED; DEFER_INTS; SYSCALL(ans = pclose(STREAM(f));); SETSTREAM(f,0); CAR(f) &= ~OPN; ALLOW_INTS; return MAKINUM(ans); } #endif /* HAVE_PIPE */ #endif /* def IO_EXTENSIONS */ SCM close_port(f) SCM f; { ASSERT(NIMP(f) && PORTP(f),f,ARG1,s_close_port); if CLOSEDP(f) return UNSPECIFIED; DEFER_INTS; SYSCALL(fclose(STREAM(f));); SETSTREAM(f,0); CAR(f) &= ~OPN; ALLOW_INTS; return UNSPECIFIED; } SCM input_portp(x) SCM x; { if IMP(x) return BOOL_F; return INPORTP(x) ? BOOL_T : BOOL_F; } SCM output_portp(x) SCM x; { if IMP(x) return BOOL_F; return OUTPORTP(x) ? BOOL_T : BOOL_F; } #if (__TURBOC__==1) # undef L_tmpnam /* Not supported in TURBOC V1.0 */ #endif #ifdef GNUDOS # undef L_tmpnam #endif #ifdef L_tmpnam SCM ltmpnam() { char *name; SYSCALL(name = tmpnam(NULL);); if (name) return makfromstr(name, strlen(name)); return BOOL_F; } #else char template[]=TEMPTEMPLATE; # define TEMPLEN (sizeof template - 1) SCM ltmpnam() { SCM name; int temppos=TEMPLEN-9; name = makfromstr(template,(sizet)TEMPLEN); DEFER_INTS; inclp: template[temppos]++; if (!isalpha(template[temppos])) { template[temppos++]='a'; goto inclp; } # ifndef AMIGA # ifndef __MSDOS__ SYSCALL(temppos = !mktemp(CHARS(name));); if (temppos) name = BOOL_F; # endif # endif ALLOW_INTS; return name; } #endif /* L_tmpnam */ #ifdef IO_EXTENSIONS #ifndef THINK_C static char s_chdir[]="chdir"; SCM lchdir(str) SCM str; { ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_chdir); SYSCALL(str = chdir(CHARS(str));); return (str) ? BOOL_F : BOOL_T; } #endif static char s_del_fil[]="delete-file"; SCM del_fil(str) SCM str; { SCM ans; ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil); #ifdef STDC_HEADERS SYSCALL(ans = (remove(CHARS(str))) ? BOOL_F : BOOL_T;); #else SYSCALL(ans = (unlink(CHARS(str))) ? BOOL_F : BOOL_T;); #endif return ans; } static char s_ren_fil[]="rename-file"; SCM ren_fil(oldname, newname) SCM oldname, newname; { SCM ans; ASSERT(NIMP(oldname) && STRINGP(oldname), oldname, ARG1, s_ren_fil); ASSERT(NIMP(newname) && STRINGP(newname), newname, ARG2, s_ren_fil); #ifdef STDC_HEADERS SYSCALL(ans = (rename(CHARS(oldname), CHARS(newname))) ? BOOL_F: BOOL_T;); return ans; #else DEFER_INTS; SYSCALL(ans = link(CHARS(oldname),CHARS(newname)) ? BOOL_F : BOOL_T;); if (!FALSEP(ans)) { SYSCALL(ans = unlink(CHARS(oldname)) ? BOOL_F : BOOL_T;); if FALSEP(ans) SYSCALL(unlink(CHARS(newname));); /* unlink failed. remove new name */ } ALLOW_INTS; return ans; #endif } #endif extern SCM obhash(), obunhash(); static char s_obunhash[]="object-unhash"; static iproc subr0s[]={ {"gc",gc}, {"tmpnam",ltmpnam}, {0,0}}; static iproc subr1s[]={ {"call-with-current-continuation",call_cc}, {s_input_portp,input_portp}, {s_output_portp,output_portp}, {s_close_port,close_port}, {"eof-object?",eof_objectp}, #ifdef IO_EXTENSIONS # ifdef HAVE_PIPE {s_cls_pipe,close_pipe}, # endif # ifndef THINK_C {s_chdir,lchdir}, # endif {s_del_fil, del_fil}, #endif /* def IO_EXTENSIONS */ {"object-hash",obhash}, {s_obunhash,obunhash}, {0,0}}; static iproc subr2s[]={ {s_open_file,open_file}, #ifdef IO_EXTENSIONS # ifdef HAVE_PIPE {s_op_pipe,open_pipe}, # endif {s_ren_fil, ren_fil}, #endif /* def IO_EXTENSIONS */ {0,0}}; void init_io(){ init_iprocs(subr0s, tc7_subr_0); init_iprocs(subr1s, tc7_subr_1); init_iprocs(subr2s, tc7_subr_2); } int expmem = 0; sizet hplim_ind = 0; long heap_size = 0; CELLPTR *hplims, heap_org; SCM freelist = EOL; char *must_malloc(len,what) long len; char *what; { char *ptr; sizet size = len; if (len != size) malerr: wta(MAKINUM(len),(char *)NALLOC,what); SYSCALL(ptr = malloc(size);); if (ptr != NULL) return ptr; gc(); SYSCALL(ptr = malloc(size);); if (ptr != NULL) return ptr; goto malerr; } int symhash_dim = NUM_HASH_BUCKETS; void init_isyms() { int hash,i = NUM_ISYMS,n = symhash_dim; char *cname,c; while (0 <= --i) { hash = 0; cname = isymnames[i]; while(c = *cname++) hash = ((hash * 17) ^ c) % n; VELTS(symhash)[hash] = cons((i<14)?MAKSPCSYM(i):MAKISYM(i), VELTS(symhash)[hash]); } } /* if length is negative, use the given string directly if possible */ SCM intern(name,len) unsigned char *name; sizet len; { SCM lsym; register sizet i = len; register unsigned char *tmp = name; register unsigned int hash = 0, n = symhash_dim; while(i--) hash = ((hash * 17) ^ *tmp++) % n; for(lsym=VELTS(symhash)[hash];NIMP(lsym);lsym=CDR(lsym)) { if ISYMP(CAR(lsym)) { tmp = (unsigned char *)ISYMCHARS(CAR(lsym)); for(i = 0;i < len;i++) { if (tmp[i] == 0) goto trynext; if (name[i] != tmp[i]) goto trynext; } if (tmp[i] == 0) return CAR(lsym); } else { tmp = (unsigned char *)CHARS(NAMESTR(CAR(lsym))); if (len != LENGTH(NAMESTR(CAR(lsym)))) goto trynext; for(i = len;i--;) if (name[i] != tmp[i]) goto trynext; return CAR(lsym); } trynext: ; } lsym = makfromstr(name, len); { SCM z = lsym; NEWCELL(lsym); DEFER_INTS; VCELL(lsym) = UNDEFINED; SETNAMESTR(lsym,z); VELTS(symhash)[hash] = cons(lsym,VELTS(symhash)[hash]); ALLOW_INTS; } return lsym; } SCM sysintern(name) unsigned char *name; { SCM lsym; sizet len = strlen((char *) name); register sizet i = len; register unsigned char *tmp = name; register unsigned int hash = 0, n = symhash_dim; while(i--) hash = ((hash * 17) ^ *tmp++) % n; NEWCELL(lsym); SETLENGTH(lsym,(long)len,tc7_string); SETCHARS(lsym,name); { SCM z = lsym; NEWCELL(lsym); VCELL(lsym) = UNDEFINED; SETNAMESTR(lsym,z); } VELTS(symhash)[hash] = cons(lsym,VELTS(symhash)[hash]); return lsym; } SCM cons(x,y) SCM x,y; { register SCM z; NEWCELL(z); CAR(z) = x; CDR(z) = y; return z; } SCM cons2(w,x,y) SCM w,x,y; { register SCM z; NEWCELL(z); CAR(z) = x; CDR(z) = y; x = z; NEWCELL(z); CAR(z) = w; CDR(z) = x; return z; } SCM cons2r(w,x,y) SCM w,x,y; { register SCM z; NEWCELL(z); CAR(z) = w; CDR(z) = x; x = z; NEWCELL(z); CAR(z) = x; CDR(z) = y; return z; } SCM makstr(len) long len; { SCM s; NEWCELL(s); DEFER_INTS; SETLENGTH(s,len,tc7_string); SETCHARS(s,must_malloc(len+1,s_string)); ALLOW_INTS; CHARS(s)[len] = 0; return s; } SCM makfromstr(src, len) char *src; sizet len; { SCM s; register char *dst; s = makstr((long)len); dst = CHARS(s); while (len--) *dst++ = *src++; return s; } char s_resizstr[]="string-set-length!"; SCM resizstr(str, len) SCM str, len; { char *tmp; sizet l = INUM(len); ASSERT(NIMP(str) && STRINGP(str) && (str != nullstr),str,ARG1,s_resizstr); ASSERT(INUMP(len) && (len == MAKINUM(l)),len,ARG2,s_resizstr); DEFER_INTS; SYSCALL(tmp = realloc(CHARS(str),l+1);); if (tmp) { SETCHARS(str,tmp); SETLENGTH(str,l,tc7_string); } ALLOW_INTS; if (!tmp) wta(len,(char *)NALLOC,s_resizstr); return UNSPECIFIED; } char s_resizvect[]="vector-set-length!"; SCM resizvect(vect, len) SCM vect, len; { char *tmp; sizet oldl; sizet l = INUM(len)*sizeof(SCM); ASSERT(NIMP(vect) && VECTORP(vect) && (vect != nullvect), vect,ARG1,s_resizvect); ASSERT(INUMP(len) && (len == MAKINUM(l/sizeof(SCM))),len,ARG2,s_resizvect); oldl = LENGTH(vect); DEFER_INTS; SYSCALL(tmp = realloc(CHARS(vect),l);); if (tmp) { SETCHARS(vect,tmp); SETLENGTH(vect,INUM(len),tc7_vector); } for(l=INUM(len);l > oldl;) VELTS(vect)[--l]=UNSPECIFIED; ALLOW_INTS; if (!tmp) wta(len,(char *)NALLOC,s_resizvect); return UNSPECIFIED; } SCM make_vector(k,fill) SCM k,fill; { SCM v; register long i; register SCM *velts; ASSERT(INUMP(k),k,ARG1,s_make_vector); i = INUM(k); if (i == 0) return nullvect; NEWCELL(v); DEFER_INTS; SETLENGTH(v,i,tc7_vector); SETCHARS(v,must_malloc(i*sizeof(SCM),s_vector)); velts = VELTS(v); while(--i>=0) (velts)[i] = fill; ALLOW_INTS; return v; } #ifdef FLOATS SCM makdbl (x,y) double x,y; { SCM z; if ((y == 0.0) && (x == 0.0)) return flo0; NEWCELL(z); DEFER_INTS; if (y == 0.0) { # ifdef SINGLES float fx = x; #ifndef SINGLESONLY if ((-FLTMAXjmpbuf) #define SETJMPBUF(x,v) SETCDR(x,v) SCM throwval = UNDEFINED; SCM call_cc(proc) SCM proc; { long j; SCM cont; #ifdef CHEAP_CONTINUATIONS NEWCELL(cont); DEFER_INTS; SETLENGTH(cont,0L,tc7_contin); SETJMPBUF(cont,must_malloc((long)sizeof(regs),"continuation")); ALLOW_INTS; #else register SCM *src,*dst; NEWCELL(cont); DEFER_INTS; FLUSH_REGISTER_WINDOWS; SETLENGTH(cont,stack_size(stack_start_ptr),tc7_contin); SETJMPBUF(cont,must_malloc(sizeof(regs)+LENGTH(cont)*sizeof(SCM *) ,"continuation")); ALLOW_INTS; src = stack_start_ptr; # ifndef STACK_GROWS_UP src -= LENGTH(cont); # endif /* ndef STACK_GROWS_UP */ dst = (SCM *)(CHARS(cont)+sizeof(regs)); for (j = LENGTH(cont);0 <= --j;) *dst++ = *src++; #endif /* def CHEAP_CONTINUATIONS */ if (setjmp(JMPBUF(cont))) return throwval; return apply(proc,cont,listofnull); } #define PTR_GT(x,y) PTR_LT(y,x) #define PTR_LE(x,y) (!PTR_GT(x,y)) #define PTR_GE(x,y) (!PTR_LT(x,y)) void lthrow(cont,val) SCM cont,val; { #ifndef CHEAP_CONTINUATIONS register long j; register SCM *src; register SCMPTR dst = stack_start_ptr; # ifdef STACK_GROWS_UP if PTR_GE(dst + LENGTH(cont),(SCMPTR)&cont) grow_throw(cont,val); # else dst -= LENGTH(cont); if PTR_LE(dst,(SCMPTR)&cont) grow_throw(cont,val); # endif /* def STACK_GROWS_UP */ FLUSH_REGISTER_WINDOWS; src = (SCM *)(CHARS(cont)+sizeof(regs)); for (j = LENGTH(cont);0 <= --j;) *dst++ = *src++; #endif /* ndef CHEAP_CONTINUATIONS */ throwval = val; longjmp(JMPBUF(cont),1); } #ifndef CHEAP_CONTINUATIONS void grow_throw(cont,val) /* Grow the stack so that there is room */ SCM cont,val; /* to copy in the continuation. Then */ { /* retry the throw. */ long growth[100]; lthrow(cont,val); } #endif /* ndef CHEAP_CONTINUATIONS */ SCM obhash(obj) SCM obj; { return (obj<<1)+2L; } SCM obunhash(obj) SCM obj; { ASSERT(INUMP(obj),obj,ARG1,s_obunhash); obj = SRS(obj,1) & ~1L; if IMP(obj) return obj; /* if NCELLP(obj) return BOOL_F; */ { /* code is adapted from mark_locations */ register CELLPTR ptr = (CELLPTR)obj; register int i=0, j=hplim_ind; do { if PTR_GT(hplims[i++], ptr) break; if PTR_LE(hplims[--j], ptr) break; if ((i != j) && PTR_LE(hplims[i++], ptr) && PTR_GT(hplims[--j], ptr)) continue; if NFREEP(obj) return obj; break; } while(i ni) hplims[i+2] = hplims[i]; hplim_ind += 2; hplims[ni++] = ptr; /* same as seg_org here */ hplims[ni++] = seg_end; ptr = CELL_UP(ptr); ni = seg_end - ptr; for (i=ni;i--;ptr++) { CAR(ptr) = (SCM)tc_free_cell; CDR(ptr) = (SCM)(ptr+1); } CDR(--ptr) = freelist; freelist = (SCM) CELL_UP(seg_org); heap_size += ni; growth_mon(s_heap,heap_size,"cells"); return size; } void alloc_some_heap() { CELLPTR ptr, *tmplims; sizet len = (2+hplim_ind)*sizeof(CELLPTR); ASRTGO(len == (2+hplim_ind)*sizeof(CELLPTR),badhplims); SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len);); if (!tmplims) badhplims: wta(UNDEFINED,s_nogrow,s_hplims); else { hplims = tmplims; growth_mon("number of heaps", 1L+hplim_ind/2,"segments"); } /* hplim_ind gets incremented in init_heap_seg() */ if (expmem) { len = heap_size/2*sizeof(cell); if (len != heap_size/2*sizeof(cell)) len = 0; } else { len = HEAP_SEG_SIZE; if (len != HEAP_SEG_SIZE) fixconfig("reduce","size of HEAP_SEG_SIZE"); } while (len >= MIN_HEAP_SEG_SIZE) { SYSCALL(ptr = (CELLPTR) malloc(len);); if (ptr) { init_heap_seg(ptr, len); return; } len /= 2; } wta(UNDEFINED, s_nogrow, s_heap); } #ifdef FLOATS # include # ifdef ENGNOT # define MANTRAD 1000.0 # define EXPINC 3 # else # define MANTRAD 10.0 # define EXPINC 1 # endif /* def ENGNOT */ double dbl1 = 1.0; int dblprec=55; # ifdef SINGLES float flo1 = 1.0; int floprec=25; # endif /* def SINGLES */ sizet idbl2str(f,prec,ec,str) double f; int prec; char ec,*str; { register sizet i=1; register int xpo=0,c; if (f == 0.0) {str[0]='0'; str[i++]='.'; str[i++]='0'; return i;} if (f < 0.0) {f = -f;str[0]='-';} else if (f > 0.0) str[0]='+'; else { i=0; funny: str[i++]='#'; str[i++]='.'; str[i++]='#'; return i; } if (f == f/2) goto funny; while(f >= MANTRAD) {xpo++;f /= MANTRAD;} while(f < 1.0) {xpo--;f *= MANTRAD;} c = floor(f); # ifdef ENGNOT i += iint2str((long)c,10,&str[i]); # else str[i++] = c+'0'; # endif /* def ENGNOT */ str[i++] = '.'; { double M = pow((double)FLTRADIX, -floor(prec - 1 - log(f)/log((double)FLTRADIX)))/2; f -= c; do { f *= 10; c = floor(f); f -= c; M *= 10; str[i++] = c + '0'; /* printf("prec= %d f= %g c= %d M= %g i= %d\n",prec,f,c,M,i); */ } while ((f >= M) && (f <= 1 - M)); if (f >= .5) str[i-1]++; } if (xpo) { str[i++] = ec; i += iint2str((long)xpo*EXPINC,10,&str[i]); } return i; } sizet iflo2str(flt,str) SCM flt; char *str; { sizet i; # ifdef SINGLES if SINGP(flt) return idbl2str(FLO(flt),floprec,'e',str); # endif /* def SINGLES */ i = idbl2str(REAL(flt),dblprec,'e',str); if CPLXP(flt) { i += idbl2str(IMAG(flt),dblprec,'e',&str[i]); str[i++] = 'i'; } return i; } # ifndef SINGLES double dbl0s[2] = {0.0, 0.0}; # endif #endif /* FLOATS */ SCM sys_protects[NUM_PROTECTS]; void init_storage() { sizet j = NUM_PROTECTS; /* Because not all protects may get initialized */ while(j) sys_protects[--j] = BOOL_F; #ifdef SINGLES if (sizeof (float) != sizeof (long)) fixconfig("remove\n#","define SINGLES"); #endif /* def SINGLES */ if (stack_start_ptr==0) wta(INUM0,"stack_start_ptr not ",ISYMCHARS(I_SET)); #ifdef STACK_GROWS_UP if (((SCMPTR)&j - stack_start_ptr) < 0) fixconfig("remove\n#","define STACK_GROWS_UP"); #else if ((stack_start_ptr - (SCMPTR)&j) < 0) fixconfig("add\n#","define STACK_GROWS_UP"); #endif hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR),s_hplims); j = INIT_HEAP_SIZE; if ((j != INIT_HEAP_SIZE) || !init_heap_seg((CELLPTR) malloc(j),j)) alloc_some_heap(); else expmem=1; heap_org = CELL_UP(hplims[0]); /* hplims[0] can change. do not remove heap_org */ NEWCELL(def_inp); SETLENGTH(def_inp,0L,tc_inport); SETSTREAM(def_inp,stdin); NEWCELL(def_outp); SETLENGTH(def_outp,0L,tc_outport); SETSTREAM(def_outp,stdout); cur_inp = def_inp; cur_outp = def_outp; listofnull = cons(EOL,EOL); undefineds = cons(UNDEFINED,EOL); CDR(undefineds) = undefineds; nullstr = makstr(0L); NEWCELL(nullvect); SETLENGTH(nullvect,0L,tc7_vector); SETCHARS(nullvect,NULL); symhash = make_vector(MAKINUM(symhash_dim),EOL); init_isyms(); VCELL(sysintern("most-positive-fixnum")) = MAKINUM(MOST_POSITIVE_FIXNUM); VCELL(sysintern("most-negative-fixnum")) = MAKINUM(MOST_NEGATIVE_FIXNUM); #ifdef FLOATS NEWCELL(flo0); # ifdef SINGLES CAR(flo0) = tc_flo; FLO(flo0) = 0.0; # else CAR(flo0) = tc_dblr; CDR(flo0) = dbl0s; # endif # ifdef DBL_MANT_DIG dblprec=DBL_MANT_DIG; # else { double d=1.0/FLTRADIX; double dsum = dbl1+d; dblprec = 1; while (dsum != 1.0) { d /= FLTRADIX; dblprec++; dsum = dbl1+d; } } # endif # ifdef SINGLES # ifdef FLT_MANT_DIG floprec=FLT_MANT_DIG; # else { float f=1.0/FLTRADIX; float fx=(flo1+f); floprec = 1; while (fx != 1.0) { f /= FLTRADIX; floprec++; fx=(flo1+f); } } # endif # endif /* printf("dblprec = %d, floprec = %d\n",dblprec,floprec); */ #endif /* def FLOATS */ } /* The way of garbage collecting which allows use of the cstack is due to */ /* Scheme In One Defun, but in C this time. * COPYRIGHT (c) 1989 BY * * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * * ALL RIGHTS RESERVED * Permission to use, copy, modify, distribute and sell this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation, and that the name of Paradigm Associates Inc not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. gjc@paradigm.com Paradigm Associates Inc Phone: 617-492-6079 29 Putnam Ave, Suite 6 Cambridge, MA 02138 */ SCM gc_for_newcell() { SCM fl; gc(); if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) alloc_some_heap(); ++cells_allocated; fl = freelist; freelist = CDR(fl); return fl; } static char s_bad_type[]="unknown type in "; jmp_buf save_regs_gc_mark; SCM gc() { int j = NUM_PROTECTS; gc_start(); DEFER_INTS; errjmp_ok = 0; while(j--) gc_mark(sys_protects[j]); FLUSH_REGISTER_WINDOWS; /* This assumes that all registers are saved into the jmp_buf */ setjmp(save_regs_gc_mark); mark_locations((SCM *) save_regs_gc_mark, (sizet) sizeof(save_regs_gc_mark)/sizeof(SCM *)); { /* stack_len is long rather than sizet in order to guarantee that &stack_len is long aligned */ #ifdef STACK_GROWS_UP # ifdef nosve long stack_len = (SCMPTR)(&stack_len) - stack_start_ptr; # else long stack_len = stack_size(stack_start_ptr); # endif mark_locations(stack_start_ptr,(sizet)stack_len); #else # ifdef nosve long stack_len = stack_start_ptr - (SCMPTR)(&stack_len); # else long stack_len = stack_size(stack_start_ptr); # endif mark_locations((stack_start_ptr - stack_len),(sizet)stack_len); #endif #ifdef SHORT_ALIGN mark_locations((SCM *) (((char *)save_regs_gc_mark)+sizeof(short)), (sizet)(sizeof(save_regs_gc_mark)-sizeof(short))/ sizeof(SCM *)); # ifdef STACK_GROWS_UP mark_locations((SCMPTR)(((char *)stack_start_ptr)+sizeof(short)), (sizet)stack_len); # else mark_locations((SCMPTR)(((char *)(stack_start_ptr - stack_len))+ sizeof(short)), (sizet)stack_len); # endif #endif } gc_sweep(); gc_end(); errjmp_ok = 1; ALLOW_INTS; return UNSPECIFIED; } #ifndef NULL SCM freeall() { gc_start(); DEFER_INTS; errjmp_ok = 0; gc_mark(def_inp); /* don't want to close stdin */ gc_mark(def_outp); /* don't want to close stdout */ gc_mark(nullstr); /* has NULL pointer */ gc_mark(nullvect); /* has NULL pointer */ /* system symbols have strings which are not malloced. Need to mark all those strings. */ gc_sweep(); gc_end(); /* need to free the heap_org segment here; but which one is it? */ free((char *)hplims); errjmp_ok = 1; ALLOW_INTS; throwval = INUM0; longjmp(errjmp,-1); /* same as quit(0) */ } #endif void gc_mark(p) SCM p; { register long i; register SCM ptr = p; gc_mark_loop: if IMP(ptr) return; gc_mark_nimp: if (NCELLP(ptr) /* #ifndef RECKLESS || PTR_GT(hplims[0], (CELLPTR)ptr) || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1]) #endif */ ) wta(ptr,"rogue pointer in ",s_heap); switch TYP7(ptr) { case tcs_cons_nimcar: if GCMARKP(ptr) break; SETGCMARK(ptr); if IMP(CDR(ptr)) { /* IMP works even with a GC mark */ ptr = CAR(ptr); goto gc_mark_nimp; } gc_mark(CAR(ptr)); ptr = GCCDR(ptr); goto gc_mark_nimp; case tcs_cons_imcar: case tcs_cons_gloc: if GCMARKP(ptr) break; SETGCMARK(ptr); ptr = GCCDR(ptr); goto gc_mark_loop; case tcs_symbols: if GCMARKP(ptr) break; SETGCMARK(ptr); gc_mark(NAMESTR(ptr)); /* this could be bummed. */ ptr = GCCDR(ptr); goto gc_mark_loop; case tcs_closures: if GCMARKP(ptr) break; SETGCMARK(ptr); if IMP(CDR(ptr)) { ptr = CODE(ptr); goto gc_mark_nimp; } gc_mark(CODE(ptr)); ptr = GCCDR(ptr); goto gc_mark_nimp; case tc7_vector: if GC8MARKP(ptr) break; SETGC8MARK(ptr); i=LENGTH(ptr); if (i == 0) break; while(--i>0) if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]); ptr = VELTS(ptr)[0]; goto gc_mark_loop; case tc7_contin: if GC8MARKP(ptr) break; SETGC8MARK(ptr); mark_locations(VELTS(ptr), (sizet) (LENGTH(ptr) + sizeof(regs)/sizeof(SCM *))); #ifdef SHORT_ALIGN mark_locations(CHARS(ptr)+sizeof(short), (sizet) (LENGTH(ptr)+(sizeof(regs)-sizeof(short))/sizeof(SCM *))); #endif /* def SHORT_ALIGN */ break; case tc7_string: /* if GC8MARKP(ptr) break;*/ SETGC8MARK(ptr); case tcs_subrs: break; case tc7_smob: if GC8MARKP(ptr) break; switch TYP16(ptr) { #ifdef FLOATS case tc16_flo: #endif /* def FLOATS */ case tc16_port: SETGC8MARK(ptr); break; case tc16_promise: case tc16_arbiter: if GC8MARKP(ptr) break; SETGC8MARK(ptr); ptr = CDR(ptr); goto gc_mark_loop; default: goto def; } break; default: def: wta(ptr,s_bad_type,"gc_mark"); } } void mark_locations(x,n) SCM x[]; sizet n; { register long m = n; register int i,j; register CELLPTR ptr; while(0 <= --m) if CELLP(x[m]) { ptr = (CELLPTR)x[m]; i=0; j=hplim_ind; do { if PTR_GT(hplims[i++], ptr) break; if PTR_LE(hplims[--j], ptr) break; if ((i != j) && PTR_LE(hplims[i++], ptr) && PTR_GT(hplims[--j], ptr)) continue; if NFREEP(x[m]) gc_mark(x[m]); break; } while(i>16)) { case (IMAG_PART | REAL_PART)>>16: m += 2*sizeof(double); case REAL_PART>>16: case IMAG_PART>>16: m += sizeof(double); free(CHARS(ptr)); #ifdef SINGLES case 0: #endif /* def SINGLES */ break; default: goto sweeperr; } break; #endif /* FLOATS */ default: goto sweeperr; } break; default: sweeperr: wta((SCM)ptr,s_bad_type,"gc_sweep"); } ++n; CAR(ptr) = (SCM)tc_free_cell; CDR(ptr) = nfreelist; nfreelist = (SCM)ptr; continue; c8mrkcontinue: CLRGC8MARK(ptr); continue; cmrkcontinue: CLRGCMARK(ptr); } if (n==seg_size) { heap_size -= seg_size; free((char *)hplims[i-2]); for(j=i;j < hplim_ind;j++) hplims[j-2] = hplims[j]; hplim_ind -= 2; i -= 2; /* need to scan segment just moved. */ growth_mon(s_heap,heap_size,"cells"); nfreelist = freelist; } else freelist = nfreelist; gc_cells_collected += n; n=0; } gc_malloc_collected = m; } @EOF chmod 666 sys.c echo x - eval.c cat >eval.c <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ #include "scm.h" typedef struct {long sname;double (*dproc)();} dsubr; #define DSUBRF(x) (((dsubr *)(x))->dproc) #define I_VAL(x) (CDR((x)-1L)) #define EVALCELLCAR(x,env) SYMBOLP(CAR(x))?*lookupcar(x,env):ceval(CAR(x),env) #ifdef MEMOIZE_LOCALS #define EVALIMP(x,env) (ILOCP(x)?*ilookup((x),env):x) #else #define EVALIMP(x,env) x #endif #define EVALCAR(x,env) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x),env):\ I_VAL(CAR(x))):EVALCELLCAR(x,env)) /* #define EVALCAR(x,env) (IMP(CAR(x))?CAR(x):ceval(CAR(x),(env))) */ char s_apply[]="apply", s_map[]="map", s_for_each[]="for-each"; #define EXTEND_ENV(formals,actuals,env) cons2r(formals,actuals,env) #ifdef MEMOIZE_LOCALS SCM *ilookup(iloc,env) SCM iloc,env; { register int ir = IFRAME(iloc); register SCM er = env; for(;ir != 0;--ir) er = CDR(er); er = CAR(er); for(ir = IDIST(iloc);ir != 0;--ir) er = CDR(er); if ICDRP(iloc) return &CDR(er); return &CAR(CDR(er)); } #endif SCM *lookupcar(vloc,genv) SCM vloc,genv; { SCM env = genv; register SCM *al, fl, var = CAR(vloc); #ifdef MEMOIZE_LOCALS register SCM iloc = ILOC00; #endif for(;NIMP(env);env = CDR(env)) { al = &CAR(env); for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) { if NCONSP(fl) if (fl == var) { #ifdef MEMOIZE_LOCALS CAR(vloc) = iloc + ICDR; #endif return &CDR(*al); } else break; al = &CDR(*al); if (CAR(fl) == var) { #ifdef MEMOIZE_LOCALS CAR(vloc) = iloc; #endif return &CAR(*al); } #ifdef MEMOIZE_LOCALS iloc += IDINC; #endif } #ifdef MEMOIZE_LOCALS iloc = (~IDSTMSK) & (iloc + IFRINC); #endif } #ifndef RECKLESS if (NNULLP(env) || UNBNDP(VCELL(var))) everr(vloc,genv,var, NULLP(env)?"unbound variable: ":"damaged environment",""); #endif CAR(vloc) += 1; return &VCELL(var); } SCM eval_args(l,env) SCM l,env; { SCM res = EOL,*lloc = &res; while NIMP(l) { *lloc = cons(EVALCAR(l,env),EOL); lloc = &CDR(*lloc); l = CDR(l); } return res; } SCM iqq(form, env, depth) SCM form, env; int depth; { SCM tmp; int edepth = depth; if IMP(form) return form; if VECTORP(form) { long i = LENGTH(form); SCM *data = VELTS(form); tmp = EOL; for(;--i>=0;) tmp = cons(data[i],tmp); return vector(iqq(tmp,env,depth)); } if NCONSP(form) return form; tmp = CAR(form); if (tmp == I_QUASIQUOTE) { depth++; goto label; } if (tmp == I_UNQUOTE) { --depth; label: form = CDR(form); ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)), form,ARG1,ISYMCHARS(I_QUASIQUOTE)); if (depth == 0) return EVALCAR(form,env); return cons2(tmp,iqq(CAR(form),env,depth),EOL); } if (NIMP(tmp) && (CAR(tmp) == I_UQ_SPLICING)) { tmp = CDR(tmp); if (--edepth == 0) return append(cons2(EVALCAR(tmp,env),iqq(CDR(form),env,depth),EOL)); } return cons(iqq(CAR(form),env,edepth),iqq(CDR(form),env,depth)); } cell dummy_cell = {EOL, EOL}; SCM ceval(x,env) SCM x,env; { union {SCM *lloc; SCM arg1;} t; SCM proc; loop: switch TYP7(x) { case tcs_symbols: /* only happens when called at top level */ CAR(&dummy_cell) = x; /* CDR(&dummy_cell) = EOL; */ x = (SCM)&dummy_cell; goto retval; case (127 & I_AND): x = CDR(x); if NULLP(x) return BOOL_T; t.arg1 = x; while(NNULLP(t.arg1 = CDR(t.arg1))) if FALSEP(EVALCAR(x,env)) return BOOL_F; else x = t.arg1; goto carloop; case (127 & I_BEGIN): cdrxbegin: x = CDR(x); begin: t.arg1 = x; while(NNULLP(t.arg1 = CDR(t.arg1))) { SIDEVAL(CAR(x),env); x = t.arg1; } carloop: /* eval car of last form in list */ if NCELLP(CAR(x)) { x = CAR(x); return IMP(x)?EVALIMP(x,env):I_VAL(x); } if SYMBOLP(CAR(x)) retval: return *lookupcar(x,env); x = CAR(x); goto loop; /* tail recurse */ case (127 & I_CASE): x = CDR(x); proc = EVALCAR(x,env); while(NIMP(x = CDR(x))) { ASSERT(CONSP(x),x,ARG1,ISYMCHARS(I_CASE)); t.arg1 = CAR(x); ASSERT(NIMP(t.arg1) && CONSP(t.arg1),t.arg1,ARG1,ISYMCHARS(I_CASE)); #ifndef FLOATS #define memv memq #endif if ((I_ELSE == CAR(t.arg1)) || NFALSEP(memv(proc,CAR(t.arg1)))) { x = CDR(t.arg1); goto begin; } } return UNSPECIFIED; case (127 & I_COND): x = CDR(x); while(NIMP(x)) { ASSERT(CONSP(x),x,ARG1,ISYMCHARS(I_COND)); t.arg1 = CAR(x); ASSERT(NIMP(t.arg1) && ECONSP(t.arg1),t.arg1,ARG1,ISYMCHARS(I_COND)); t.arg1 = EVALCAR(t.arg1,env); if NFALSEP(t.arg1) { x = CDR(CAR(x)); if NULLP(x) return t.arg1; ASSERT(ECONSP(x),x,ARG2,ISYMCHARS(I_COND)); if (I_ARROW != CAR(x)) goto begin; proc = CDR(x); ASSERT(ECONSP(proc),proc,ARG3,ISYMCHARS(I_COND)); proc = EVALCAR(proc,env); /* was return apply(proc,t.arg1,listofnull); */ ASRTGO(NIMP(proc),badfun); goto evap1; } x = CDR(x); } return UNSPECIFIED; case (127 & I_DO): x = CDR(x); { SCM vars = EOL,inits = EOL; t.arg1 = CAR(x); while NIMP(t.arg1) { ASSERT(CONSP(t.arg1),x,ARG1,ISYMCHARS(I_DO)); proc = CAR(t.arg1); ASSERT(NIMP(proc) && CONSP(proc) && SYMBOLP(CAR(proc)), x,ARG1,ISYMCHARS(I_DO)); vars = cons(CAR(proc),vars); proc = CDR(proc); ASSERT(NIMP(proc) && ECONSP(proc), x,ARG1,ISYMCHARS(I_DO)); if IMP(CDR(proc)) CDR(proc) = cons(CAR(vars),EOL); inits = cons(EVALCAR(proc,env),inits); t.arg1 = CDR(t.arg1); } env = EXTEND_ENV(vars,inits,env); while (1) { env = EXTEND_ENV(vars,inits,CDR(env)); t.arg1 = CDR(x); proc = CAR(t.arg1); if NFALSEP(EVALCAR(proc,env)) { x = CDR(proc); if NULLP(x) return UNSPECIFIED; goto begin; } while NIMP(t.arg1 = CDR(t.arg1)) SIDEVAL(CAR(t.arg1),env); inits = EOL; t.arg1=CAR(x); for(;NIMP(t.arg1);t.arg1=CDR(t.arg1)) { proc=CDR(CDR(CAR(t.arg1))); inits = cons(EVALCAR(proc,env), inits); } } } case (127 & I_IF): x = CDR(x); if NFALSEP(EVALCAR(x,env)) x = CDR(x); else if IMP(x = CDR(CDR(x))) return UNSPECIFIED; goto carloop; case (127 & I_LET): t.arg1 = CDR(x); if IMP(CAR(t.arg1)) { x = t.arg1; nullet: ASSERT(NULLP(CAR(x)),x,ARG1,ISYMCHARS(I_LET)); env = EXTEND_ENV(EOL,EOL,env); x = CDR(x); ASSERT(NIMP(x),x,ARG2,ISYMCHARS(I_LET)); goto begin; } if SYMBOLP(CAR(t.arg1)) t.arg1 = CAR(CDR(t.arg1)); /* named let */ else t.arg1 = CAR(t.arg1); { /* binding list is now in t.arg1 */ SCM vars = NULLP(t.arg1) ? t.arg1 : CAR(t.arg1); while NIMP(t.arg1) { /* destructively rearrange let-list */ ASSERT(CONSP(t.arg1),t.arg1,ARG1,ISYMCHARS(I_LET)); proc = CAR(t.arg1); /* arg list */ ASSERT(ilength(proc)==2,t.arg1,ARG1,ISYMCHARS(I_LET)); CAR(t.arg1) = CAR(CDR(proc)); if IMP(CDR(t.arg1)) CDR(proc) = EOL; else CDR(proc) = CAR(CDR(t.arg1)); t.arg1 = CDR(t.arg1); } if SYMBOLP(CAR(CDR(x))) { /* named let */ t.arg1 = CDR(x); CAR(x) = cons2(I_LAMBDA, vars, CDR(CDR(t.arg1))); CAR(x) = cons2(I_LETREC, cons2r(CAR(t.arg1), cons(CAR(x),EOL), EOL), cons(CAR(t.arg1),EOL)); CDR(x) = CAR(CDR(t.arg1)); goto loop; } CAR(x) = cons2(I_LAMBDA,vars,CDR(CDR(x))); CDR(x) = CAR(CDR(x)); goto loop; } case (127 & I_LETSTAR): x = CDR(x); proc = CAR(x); if IMP(proc) goto nullet; while NIMP(proc) { ASSERT(CONSP(proc),x,ARG1,ISYMCHARS(I_LETSTAR)); t.arg1 = CAR(proc); /* ASSERT(CONSP(t.arg1) && ECONSP(CDR(t.arg1)) && SYMBOLP(CAR(t.arg1)),x,ARG1,ISYMCHARS(I_LETSTAR)); */ env = EXTEND_ENV(CAR(t.arg1), EVALCAR(CDR(t.arg1),env), env); proc = CDR(proc); } goto cdrxbegin; case (127 & I_LETREC): x = CDR(x); proc = CAR(x); if IMP(proc) goto nullet; t.arg1 = EOL; while NIMP(proc) { ASSERT((NIMP(proc) && CONSP(proc)) || (NIMP(CAR(proc)) && CONSP(CAR(proc)) && SYMBOLP(CAR(CAR(proc)))), x,ARG1,ISYMCHARS(I_LETREC)); t.arg1 = cons(CAR(CAR(proc)),t.arg1); proc = CDR(proc); } env = EXTEND_ENV(t.arg1,undefineds,env); t.arg1 = EOL; proc = CAR(x); while NIMP(proc) { SCM tmp = CDR(CAR(proc)); t.arg1 = cons(EVALCAR(tmp,env), t.arg1); proc = CDR(proc); } CDR(CAR(env)) = t.arg1; goto cdrxbegin; case (127 & I_OR): x = CDR(x); if NULLP(x) return BOOL_F; t.arg1 = x; while(NNULLP(t.arg1 = CDR(t.arg1))) { x = EVALCAR(x,env); if NFALSEP(x) return x; x = t.arg1; } goto carloop; case (127 & I_DEFINE): x = CDR(x); proc = CAR(x); x = CDR(x); while (NIMP(proc) && CONSP(proc)) { x = cons(cons2(I_LAMBDA,CDR(proc),x),EOL); proc = CAR(proc); } ASSERT(NIMP(proc) && SYMBOLP(proc),proc,ARG1,ISYMCHARS(I_DEFINE)); ASSERT(NIMP(x) && ECONSP(x),x,WNA,ISYMCHARS(I_DEFINE)); x = EVALCAR(x,env); if NNULLP(env) { env = CAR(env); CAR(env) = cons(proc,CAR(env)); CDR(env) = cons(x,CDR(env)); } else { t.arg1 = VCELL(proc); #ifndef RECKLESS if (NIMP(t.arg1) && SUBRP(t.arg1) && ((SCM) SNAME(t.arg1) == NAMESTR(proc))) warn("redefining built-in ", CHARS(NAMESTR(proc))); #endif VCELL(proc) = x; } return UNSPECIFIED; case (127 & I_LAMBDA): x = CDR(x); ASSERT(NIMP(x) && CONSP(x) && NIMP(CDR(x)) && ECONSP(CDR(x)),x,ARG1,ISYMCHARS(I_LAMBDA)); return closure(x,env); case (127 & I_QUOTE): x = CDR(x); return CAR(x); #ifndef PURE_FUNCTIONAL case (127 & I_SET): x = CDR(x); proc = CAR(x); switch (7 & (int)proc) { case 0: ASRTGO(SYMBOLP(proc),badset); t.lloc = lookupcar(x,env); break; case 1: t.lloc = &VCELL(proc-1); break; #ifdef MEMOIZE_LOCALS case 4: ASRTGO(ILOCP(proc),badset); t.lloc = ilookup(proc, env); break; #endif default: badset: everr(x,env,proc,(char *)ARG1,ISYMCHARS(I_SET)); } x = CDR(x); *t.lloc = EVALCAR(x,env); return UNSPECIFIED; #endif /* ~PURE_FUNCTIONAL */ case (127 & MAKISYM(0)): proc = CAR(x); ASRTGO(ISYMP(proc),badfun); switch ISYMNUM(proc) { case ISYMNUM(I_QUASIQUOTE): x = CDR(x); ASSERT(NIMP(x) && CONSP(x) && NULLP(CDR(x)), x,ARG1,ISYMCHARS(I_QUASIQUOTE)); return iqq(CAR(x), env, 1); case ISYMNUM(I_DELAY): return makprom(closure(cons(EOL,CDR(x)),env)); #ifdef SYNTAX_EXTENSIONS /* extension special forms go here */ case ISYMNUM(I_DEFINEDP): CAR(x) = I_QUOTE; x = CDR(x); proc = CAR(x); CAR(x) = (ISYMP(proc) || (NIMP(proc) && SYMBOLP(proc) && !UNBNDP(VCELL(proc))))? BOOL_T : BOOL_F; return CAR(x); #endif /* SYNTAX_EXTENSIONS */ default: goto badfun; } default: badfun2: proc = x; badfun: everr(x,env,proc,"Wrong type to apply: ",""); case tc7_vector: case tc7_string: case tc7_smob: return x; #ifdef MEMOIZE_LOCALS case (127 & ILOC00): /* ASRTGO(ILOCP(CAR(x)),badfun2); */ proc = *ilookup(CAR(x),env); goto checkprocbreak; #endif case tcs_cons_gloc: proc = I_VAL(CAR(x)); checkprocbreak: ASRTGO(NIMP(proc),badfun); break; case tcs_cons_nimcar: proc = EVALCELLCAR(x,env); ASRTGO(NIMP(proc),badfun); #ifndef RECKLESS if CLOSUREP(proc) { SCM varl = CAR(CODE(proc)); t.arg1 = CDR(x); while NIMP(varl) { if NCONSP(varl) goto evapply; if IMP(t.arg1) goto wrongnumargs; varl = CDR(varl); t.arg1 = CDR(t.arg1); } if NNULLP(t.arg1) goto wrongnumargs; } #endif } evapply: x = CDR(x); if NULLP(x) switch TYP7(proc) { /* no arguments given */ case tc7_subr_0: return SUBRF(proc)(); case tc7_subr_1o: return SUBRF(proc) (UNDEFINED); case tc7_lsubr: return SUBRF(proc)(EOL); case tc7_asubr: return SUBRF(proc)(UNDEFINED,UNDEFINED); case tcs_closures: x = CODE(proc); env = EXTEND_ENV(CAR(x),EOL,ENV(proc)); goto cdrxbegin; case tc7_contin: case tc7_subr_1: case tc7_subr_2: case tc7_subr_2x: case tc7_subr_2o: case tc7_cxr: case tc7_subr_3: case tc7_lsubr_2: wrongnumargs: everr(x,env,proc,(char *)WNA,""); default: goto badfun; } t.arg1 = EVALCAR(x,env); x = CDR(x); if NULLP(x) evap1: switch TYP7(proc) { /* have one argument in t.arg1 */ case tc7_subr_2o: return SUBRF(proc)(t.arg1,UNDEFINED); case tc7_subr_1: case tc7_subr_1o: return SUBRF(proc)(t.arg1); case tc7_cxr: #ifdef FLOATS if SUBRF(proc) { if INUMP(t.arg1) return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0); ASRTGO(NIMP(t.arg1),floerr); if REALP(t.arg1) return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0); floerr: wta(t.arg1,(char *)ARG1,CHARS(SNAME(proc))); } #endif { char *chrs = CHARS(SNAME(proc)); while(*++chrs != 'r'); while(*--chrs != 'c') { ASSERT(NIMP(t.arg1) && CONSP(t.arg1), t.arg1,ARG1,CHARS(SNAME(proc))); t.arg1 = (*chrs == 'a')?CAR(t.arg1):CDR(t.arg1); } return t.arg1; } case tc7_asubr: return t.arg1 = SUBRF(proc)(t.arg1,UNDEFINED); case tc7_lsubr: return SUBRF(proc)(cons(t.arg1,EOL)); case tcs_closures: x = CODE(proc); env = EXTEND_ENV(CAR(x),cons(t.arg1,EOL),ENV(proc)); goto cdrxbegin; case tc7_contin: lthrow(proc,t.arg1); case tc7_subr_2x: case tc7_subr_2: case tc7_subr_0: case tc7_subr_3: case tc7_lsubr_2: goto wrongnumargs; default: goto badfun; } { /* have two or more arguments */ SCM arg2 = EVALCAR(x,env); x = CDR(x); if NULLP(x) switch TYP7(proc) { /* have two arguments */ case tc7_subr_2: case tc7_subr_2o: return SUBRF(proc)(t.arg1,arg2); case tc7_subr_2x: return SUBRF(proc)(arg2,t.arg1); case tc7_lsubr: return SUBRF(proc)(cons2(t.arg1,arg2,EOL)); case tc7_lsubr_2: return SUBRF(proc)(t.arg1, arg2, EOL); case tc7_asubr: return t.arg1 = SUBRF(proc)(t.arg1,arg2); case tc7_subr_0: case tc7_cxr: case tc7_subr_1o: case tc7_subr_1: case tc7_subr_3: case tc7_contin: goto wrongnumargs; default: goto badfun; case tcs_closures: env =EXTEND_ENV(CAR(CODE(proc)),cons2(t.arg1,arg2,EOL),ENV(proc)); x = CODE(proc); goto cdrxbegin; } switch TYP7(proc) { /* have 3 or more arguments */ case tc7_subr_3: ASRTGO(NULLP(CDR(x)), wrongnumargs); return SUBRF(proc)(t.arg1,arg2,EVALCAR(x,env)); case tc7_asubr: t.arg1 = SUBRF(proc)(t.arg1,arg2); while NIMP(x) { t.arg1 = SUBRF(proc)(t.arg1,EVALCAR(x,env)); x = CDR(x); } return t.arg1; case tc7_lsubr_2: return SUBRF(proc)(t.arg1, arg2, eval_args(x,env)); case tc7_lsubr: return SUBRF(proc)(cons2(t.arg1,arg2,eval_args(x,env))); case tcs_closures: env = EXTEND_ENV(CAR(CODE(proc)), cons2(t.arg1,arg2,eval_args(x,env)), ENV(proc)); x = CODE(proc); goto cdrxbegin; case tc7_subr_2: case tc7_subr_2x: case tc7_subr_1o: case tc7_subr_2o: case tc7_subr_0: case tc7_cxr: case tc7_subr_1: case tc7_contin: goto wrongnumargs; default: goto badfun; } } } SCM procedurep(obj) SCM obj; { if NIMP(obj) switch TYP7(obj) { case tcs_closures: case tc7_contin: case tcs_subrs: return BOOL_T; } return BOOL_F; } SCM apply(proc,arg1,args) SCM proc,arg1,args; { ASRTGO(NIMP(proc),badproc); /* This code is for lsubr apply. it is destructive on multiple args. this will only screw you if you do (apply apply '( ... )) */ if NULLP(args) if NULLP(arg1) arg1 = UNDEFINED; else { args = CDR(arg1); arg1 = CAR(arg1); } else { /* ASRTGO(NIMP(args) && CONSP(args),wrongnumargs); */ SCM *lloc = &args; while NNULLP(CDR(*lloc)) lloc = &CDR(*lloc); *lloc = CAR(*lloc); } switch TYP7(proc) { case tc7_subr_2o: args = NULLP(args)?UNDEFINED:CAR(args); return SUBRF(proc)(arg1,args); case tc7_subr_2x: ASRTGO(NULLP(CDR(args)),wrongnumargs); args = CAR(args); return SUBRF(proc)(args,arg1); case tc7_subr_2: ASRTGO(NULLP(CDR(args)),wrongnumargs); args = CAR(args); return SUBRF(proc)(arg1,args); case tc7_subr_0: ASRTGO(UNBNDP(arg1),wrongnumargs); return SUBRF(proc)(); case tc7_subr_1: case tc7_subr_1o: ASRTGO(NULLP(args),wrongnumargs); return SUBRF(proc)(arg1); case tc7_cxr: ASRTGO(NULLP(args),wrongnumargs); #ifdef FLOATS if SUBRF(proc) { if INUMP(arg1) return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0); ASRTGO(NIMP(arg1),floerr); if REALP(arg1) return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0); floerr: wta(arg1,(char *)ARG1,CHARS(SNAME(proc))); } #endif { char *chrs = CHARS(SNAME(proc)); while(*++chrs != 'r'); while(*--chrs != 'c') { ASSERT(NIMP(arg1) && CONSP(arg1), arg1,ARG1,CHARS(SNAME(proc))); arg1 = (*chrs == 'a')?CAR(arg1):CDR(arg1); } return arg1; } case tc7_subr_3: return SUBRF(proc)(arg1,CAR(args),CAR(CDR(args))); case tc7_lsubr: return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1,args)); case tc7_lsubr_2: ASRTGO(NIMP(args) && CONSP(args),wrongnumargs); return SUBRF(proc)(arg1,CAR(args),CDR(args)); case tc7_asubr: if NULLP(args) return SUBRF(proc)(arg1,UNDEFINED); while NIMP(args) { ASSERT(CONSP(args),args,ARG2,s_apply); arg1 = SUBRF(proc)(arg1,CAR(args)); args = CDR(args); } return arg1; case tcs_closures: #ifndef RECKLESS { SCM formals = CAR(CODE(proc)); arg1 = (UNBNDP(arg1) ? EOL : cons(arg1,args)); args = EXTEND_ENV(formals,arg1,ENV(proc)); while (1) { if IMP(arg1) if (IMP(formals) || SYMBOLP(formals)) break; else goto wrongnumargs; else if IMP(formals) goto wrongnumargs; else if SYMBOLP(formals) break; arg1 = CDR(arg1); formals = CDR(formals); } } #else args = EXTEND_ENV(CAR(CODE(proc)), (UNBNDP(arg1) ? EOL : cons(arg1,args)), ENV(proc)); #endif proc = CODE(proc); while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc,args); return arg1; case tc7_contin: ASRTGO(NULLP(args),wrongnumargs); lthrow(proc,arg1); wrongnumargs: wta(proc,(char *)WNA,s_apply); default: badproc: wta(proc,(char *)ARG1,s_apply); return arg1; } } SCM map(proc,arg1,args) SCM proc,arg1,args; { long i; SCM res = EOL,*pres = &res,*ve; if NULLP(arg1) return res; ASSERT(NIMP(arg1),arg1,ARG1,s_map); if NULLP(args) { while NIMP(arg1) { ASSERT(CONSP(arg1),arg1,ARG2,s_map); *pres = cons(apply(proc,CAR(arg1),listofnull),EOL); pres = &CDR(*pres); arg1 = CDR(arg1); } return res; } args = vector(cons(arg1,args)); ve = VELTS(args); while (1) { arg1 = EOL; for (i = LENGTH(args)-1;i >= 0;i--) { if IMP(ve[i]) return res; arg1 = cons(CAR(ve[i]),arg1); ve[i] = CDR(ve[i]); } *pres = cons(apply(proc,arg1,EOL),EOL); pres = &CDR(*pres); } } SCM for_each(proc,arg1,args) SCM proc,arg1,args; { SCM *ve; long i; if NULLP(arg1) return UNSPECIFIED; ASSERT(NIMP(arg1),arg1,ARG1,s_for_each); if NULLP(args) { while NIMP(arg1) { ASSERT(CONSP(arg1),arg1,ARG2,s_for_each); apply(proc,CAR(arg1),listofnull); arg1 = CDR(arg1); } return UNSPECIFIED; } args = vector(cons(arg1,args)); ve = VELTS(args); while (1) { arg1 = EOL; for (i = LENGTH(args)-1;i >= 0;i--) { if IMP(ve[i]) return UNSPECIFIED; arg1 = cons(CAR(ve[i]),arg1); ve[i] = CDR(ve[i]); } apply(proc,arg1,EOL); } } /* inits are in subr.c */ @EOF chmod 666 eval.c echo x - subr.c cat >subr.c <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ #include #include "scm.h" /* Yasuaki Honda */ /* Think C lacks isascii macro */ #ifdef THINK_C #define isascii(c) ((unsigned)(c) <= 0x7f) #endif char s_list[]="list", s_vector[]="vector", s_string[]="string"; static char s_setcar[]="set-car!", s_setcdr[]="set-cdr!"; static char s_length[]="length", s_append[]="append", s_reverse[]="reverse", s_list_ref[]="list-ref"; static char s_memq[]="memq",s_member[]="member", s_assq[]="assq",s_assoc[]="assoc"; static char s_symbol2string[]="symbol->string", s_str2symbol[]="string->symbol"; extern char s_inexactp[]; #define s_exactp (s_inexactp+2) static char s_oddp[]="odd?",s_evenp[]="even?"; static char s_abs[]="abs", s_quotient[]="quotient",s_remainder[]="remainder",s_modulo[]="modulo"; static char s_gcd[]="gcd",s_lcm[]="lcm"; static char s_ch_lessp[]="charinteger",s_int2char[]="integer->char", s_ch_upcase[]="char-upcase",s_ch_downcase[]="char-downcase"; static char s_st_length[]="string-length", s_make_string[]="make-string", s_st_ref[]="string-ref",s_st_set[]="string-set!"; static char s_st_equal[]="string=?",s_stci_equal[]="string-ci=?", s_st_lessp[]="string=0;i--) if FALSEP(equal(VELTS(x)[i],VELTS(y)[i])) return BOOL_F; return BOOL_T; } SCM equal(x,y) SCM x,y; { tailrecurse: if (x == y) return BOOL_T; if IMP(x) return BOOL_F; if IMP(y) return BOOL_F; if (CONSP(x) && CONSP(y)) { if (BOOL_F == equal(CAR(x),CAR(y))) return BOOL_F; x = CDR(x); y = CDR(y); goto tailrecurse; } /* this ensures that types and length are the same. */ if (CAR(x) != CAR(y)) return BOOL_F; if STRINGP(x) return st_equal(x,y); if VECTORP(x) return vector_equal(x,y); if (numberp(x) == BOOL_T) return eqp(x,y,EOL); /* Numberp could be bummed by moving this to scl.c */ return BOOL_F; } SCM consp(x) SCM x; { if IMP(x) return BOOL_F; return CONSP(x) ? BOOL_T : BOOL_F; } SCM setcar(pair,value) SCM pair, value; { ASSERT(NIMP(pair) && CONSP(pair),pair,ARG1,s_setcar); CAR(pair) = value; return UNSPECIFIED; } SCM setcdr(pair,value) SCM pair, value; { ASSERT(NIMP(pair) && CONSP(pair),pair,ARG1,s_setcdr); CDR(pair) = value; return UNSPECIFIED; } SCM nullp(x) SCM x; { return NULLP(x) ? BOOL_T : BOOL_F; } long ilength(sx) SCM sx; { register long i=0; register SCM x=sx; do { if IMP(x) return NULLP(x) ? i : -1; if NCONSP(x) return -1; x = CDR(x); i++; if IMP(x) return NULLP(x) ? i : -1; if NCONSP(x) return -1; x = CDR(x); i++; sx=CDR(sx); } while (x != sx); return -1; } SCM listp(x) SCM x; { if (ilength(x)<0) return BOOL_F; else return BOOL_T; } SCM list(objs) SCM objs; { return objs; } SCM length(x) SCM x; { SCM i=MAKINUM(ilength(x)); ASSERT(i>=INUM0,x,ARG1,s_length); return i; } SCM append(args) SCM args; { SCM res = EOL; SCM *lloc = &res, arg; if IMP(args) { ASSERT(NULLP(args),args,ARG1,s_append); return res; } ASSERT(CONSP(args),args,ARG1,s_append); while (1) { arg = CAR(args); args = CDR(args); if IMP(args) { *lloc = arg; ASSERT(NULLP(args),args,ARG1,s_append); return res; } ASSERT(CONSP(args),args,ARG1,s_append); for(;NIMP(arg);arg = CDR(arg)) { ASSERT(CONSP(arg),args,ARG1,s_append); *lloc = cons(CAR(arg),EOL); lloc = &CDR(*lloc); } } } SCM reverse(lst) SCM lst; { SCM res = EOL; SCM p = lst; for(;NIMP(p);p = CDR(p)) { ASSERT(CONSP(p),lst,ARG1,s_reverse); res = cons(CAR(p),res); } ASSERT(NULLP(p),lst,ARG1,s_reverse); return res; } SCM list_ref(lst,k) SCM lst, k; { register long i; ASSERT(INUMP(k),k,ARG2,s_list_ref); i = INUM(k); ASSERT(i >= 0,k,ARG2,s_list_ref); while (i-- > 0) { ASSERT(NIMP(lst) && CONSP(lst),lst,ARG1,s_list_ref); lst=CDR(lst); } ASSERT(NIMP(lst) && CONSP(lst),lst,ARG1,s_list_ref); return CAR(lst); } SCM memq(x,lst) SCM x,lst; { for(;NIMP(lst);lst = CDR(lst)) { ASSERT(CONSP(lst),lst,ARG2,s_memq); if (CAR(lst) == x) return lst; } ASSERT(NULLP(lst),lst,ARG2,s_memq); return BOOL_F; } SCM member(x,lst) SCM x,lst; { for(;NIMP(lst);lst = CDR(lst)) { ASSERT(CONSP(lst),lst,ARG2,s_member); if (equal(CAR(lst),x) == BOOL_T) return lst; } ASSERT(NULLP(lst),lst,ARG2,s_member); return BOOL_F; } SCM assq(x,alist) SCM x,alist; { SCM tmp; for(;NIMP(alist);alist=CDR(alist)) { ASSERT(CONSP(alist),alist,ARG2,s_assq); tmp = CAR(alist); ASSERT(CONSP(tmp),alist,ARG2,s_assq); if (CAR(tmp) == x) return tmp; } ASSERT(NULLP(alist),alist,ARG2,s_assq); return BOOL_F; } SCM assoc(x,alist) SCM x,alist; { SCM tmp; for(;NIMP(alist);alist=CDR(alist)) { ASSERT(CONSP(alist),alist,ARG2,s_assoc); tmp = CAR(alist); ASSERT(CONSP(tmp),alist,ARG2,s_assoc); if (equal(CAR(tmp),x) == BOOL_T) return tmp; } ASSERT(NULLP(alist),alist,ARG2,s_assoc); return BOOL_F; } SCM symbolp(x) SCM x; { if ISYMP(x) return BOOL_T; if IMP(x) return BOOL_F; return SYMBOLP(x) ? BOOL_T : BOOL_F; } SCM symbol2string(s) SCM s; { if ISYMP(s) return makfromstr(ISYMCHARS(s), strlen(ISYMCHARS(s))); ASSERT(NIMP(s) && SYMBOLP(s),s,ARG1,s_symbol2string); return NAMESTR(s); } SCM string2symbol(s) SCM s; { ASSERT(NIMP(s) && STRINGP(s),s,ARG1,s_str2symbol); return intern(CHARS(s),(sizet)LENGTH(s)); } SCM exactp(x) SCM x; { if INUMP(x) return BOOL_T; return BOOL_F; } SCM oddp(n) SCM n; { ASSERT(INUMP(n),n,ARG1,s_oddp); return (4 & (int)n) ? BOOL_T : BOOL_F; } SCM evenp(n) SCM n; { ASSERT(INUMP(n),n,ARG1,s_evenp); return (4 & (int)n) ? BOOL_F : BOOL_T; } SCM absval(x) SCM x; { SCM res; register long z = INUM(x); ASSERT(INUMP(x),x,ARG1,s_abs); if (z<0) z = -z; res = MAKINUM(z); ASSERT(res>>2 == z,res,OVFLOW,s_abs); return res; } SCM quotient(x,y) SCM x,y; { SCM res; register long z; ASSERT(INUMP(x),x,ARG1,s_quotient); ASSERT(INUMP(y),y,ARG2,s_quotient); z = INUM(y); ASSERT(z,y,OVFLOW,s_quotient); z = INUM(x)/z; #ifdef BADIVSGNS { #if (__TURBOC__ == 1) long t = (y<0 ? -INUM(x) : INUM(x))%INUM(y); #else long t = INUM(x)%INUM(y); #endif if (t == 0) ; else if (t < 0) if (x < 0) ; else z--; else if (x < 0) z++; } #endif res = MAKINUM(z); ASSERT(INUM(res) == z,res,OVFLOW,s_quotient); return res; } SCM lremainder(x,y) SCM x,y; { register long z; ASSERT(INUMP(x),x,ARG1,s_remainder); ASSERT(INUMP(y),y,ARG2,s_remainder); z = INUM(y); ASSERT(z,y,OVFLOW,s_remainder); #if (__TURBOC__ == 1) z = (y<0 ? -INUM(x) : INUM(x))%z; #else z = INUM(x)%z; #endif #ifdef BADIVSGNS if (z == 0) ; else if (z < 0) if (x < 0) ; else z += INUM(y); else if (x < 0) z -= INUM(y); #endif return MAKINUM(z); } SCM modulo(n1,n2) SCM n1,n2; { register long y = INUM(n2),z; ASSERT(INUMP(n1),n1,ARG1,s_modulo); ASSERT(INUMP(n2),n2,ARG2,s_modulo); ASSERT(y,n2,OVFLOW,s_modulo); #if (__TURBOC__ == 1) z = INUM(n1); z = (y<0 ? -z : z)%y; #else z = INUM(n1)%y; #endif return MAKINUM(y<0 ? (z>0) ? z+y : z : (z<0) ? z+y : z); } SCM lgcd(n1,n2) SCM n1,n2; { register long u,v,k,t; if UNBNDP(n2) return UNBNDP(n1) ? INUM0 : n1; ASSERT(INUMP(n1),n1,ARG1,s_gcd); ASSERT(INUMP(n2),n2,ARG2,s_gcd); u = INUM(n1); if (u<0) u = -u; v = INUM(n2); if (v<0) v = -v; else if (0 == v) return MAKINUM(u); if (0 == u) return MAKINUM(v); for (k = 1;!(1 & ((int)u|(int)v));k <<= 1,u >>= 1,v >>= 1); if (1 & (int)u) t = -v; else { t = u; b3: t = SRS(t,1); } if (!(1 & (int)t)) goto b3; if (t>0) u = t; else v = -t; if (t = u-v) goto b3; u = u*k; v = MAKINUM(u); ASSERT((v>>2) == u,v,OVFLOW,s_gcd); return v; } SCM llcm(n1,n2) SCM n1,n2; { SCM res; register long q,z; long x = INUM(n1); if UNBNDP(n2) { n2 = MAKINUM(1L); if UNBNDP(n1) return n2; } q = INUM(lgcd(n1,n2)); if ((x == 0) || (n2 == INUM0)) return INUM0; q = INUM(n2)/q; z = x*q; ASSERT(z/q == x,n1,OVFLOW,s_lcm); if (z < 0) z = -z; res = MAKINUM(z); ASSERT((res>>2) == z,res,OVFLOW,s_lcm); return res; } SCM charp(x) SCM x; { return ICHRP(x) ? BOOL_T : BOOL_F; } SCM char_lessp(x,y) SCM x,y; { ASSERT(ICHRP(x),x,ARG1,s_ch_lessp); ASSERT(ICHRP(y),y,ARG2,s_ch_lessp); return (ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F; } SCM char_leqp(x,y) SCM x,y; { ASSERT(ICHRP(x),x,ARG1,s_ch_leqp); ASSERT(ICHRP(y),y,ARG2,s_ch_leqp); return (ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F; } SCM chci_eq(x,y) SCM x,y; { ASSERT(ICHRP(x),x,ARG1,s_ci_eq); ASSERT(ICHRP(y),y,ARG2,s_ci_eq); return (upcase[ICHR(x)] == upcase[ICHR(y)]) ? BOOL_T : BOOL_F; } SCM chci_lessp(x,y) SCM x,y; { ASSERT(ICHRP(x),x,ARG1,s_ci_lessp); ASSERT(ICHRP(y),y,ARG2,s_ci_lessp); return (upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F; } SCM chci_leqp(x,y) SCM x,y; { ASSERT(ICHRP(x),x,ARG1,s_ci_leqp); ASSERT(ICHRP(y),y,ARG2,s_ci_leqp); return (upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F; } SCM char_alphap(chr) SCM chr; { ASSERT(ICHRP(chr),chr,ARG1,s_ch_alphap); return (isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F; } SCM char_nump(chr) SCM chr; { ASSERT(ICHRP(chr),chr,ARG1,s_ch_nump); return (isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F; } SCM char_whitep(chr) SCM chr; { ASSERT(ICHRP(chr),chr,ARG1,s_ch_whitep); return (isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F; } SCM char_upperp(chr) SCM chr; { ASSERT(ICHRP(chr),chr,ARG1,s_ch_upperp); return (isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F; } SCM char_lowerp(chr) SCM chr; { ASSERT(ICHRP(chr),chr,ARG1,s_ch_lowerp); return (isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F; } SCM char2int(chr) SCM chr; { ASSERT(ICHRP(chr),chr,ARG1,s_char2int); return MAKINUM(ICHR(chr)); } extern SCM sym_char_code_limit; SCM int2char(n) SCM n; { ASSERT(INUMP(n),n,ARG1,s_int2char); ASSERT((n>=INUM0) && (n=0,chrs,ARG1,s_string); if (i == 0) return nullstr; res = makstr(i); data = CHARS(res); for(;NNULLP(chrs);chrs=CDR(chrs)) { ASSERT(ICHRP(CAR(chrs)),chrs,ARG1,s_string); *data++ = ICHR(CAR(chrs)); } return res; } SCM make_string(k,chr) SCM k,chr; { SCM res; register char *dst; register long i; ASSERT(INUMP(k) && (k >= 0),k,ARG1,s_make_string); i = INUM(k); if (i == 0) return nullstr; res = makstr(i); dst = CHARS(res); if ICHRP(chr) for(i--;i>=0;i--) dst[i] = ICHR(chr); return res; } SCM st_length(str) SCM str; { ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_st_length); return MAKINUM(LENGTH(str)); } SCM st_ref(str,k) SCM str,k; { ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_st_ref); ASSERT(INUMP(k),k,ARG2,s_st_ref); ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0,k,OUTOFRANGE,s_st_ref); return MAKICHR(CHARS(str)[INUM(k)]); } SCM st_set(str,k,chr) SCM str,k,chr; { ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_st_set); ASSERT(INUMP(k),k,ARG2,s_st_set); ASSERT(ICHRP(chr),chr,ARG3,s_st_set); ASSERT(INUM(k) < LENGTH(str),k,OUTOFRANGE,s_st_set); CHARS(str)[INUM(k)] = ICHR(chr); return UNSPECIFIED; } SCM st_equal(s1, s2) SCM s1, s2; { register sizet i; register char *c1, *c2; ASSERT(NIMP(s1) && STRINGP(s1),s1,ARG1,s_st_equal); ASSERT(NIMP(s2) && STRINGP(s2),s2,ARG2,s_st_equal); i = LENGTH(s2); if (LENGTH(s1) != i) return BOOL_F; c1 = CHARS(s1); c2 = CHARS(s2); while(i-- != 0) if(*c1++ != *c2++) return BOOL_F; return BOOL_T; } SCM stci_equal(s1, s2) SCM s1, s2; { register sizet i; register unsigned char *c1, *c2; ASSERT(NIMP(s1) && STRINGP(s1),s1,ARG1,s_stci_equal); ASSERT(NIMP(s2) && STRINGP(s2),s2,ARG2,s_stci_equal); i = LENGTH(s2); if (LENGTH(s1) != i) return BOOL_F; c1 = (unsigned char *) CHARS(s1); c2 = (unsigned char *) CHARS(s2); while(i-- != 0) if(upcase[*c1++] != upcase[*c2++]) return BOOL_F; return BOOL_T; } SCM st_lessp(s1, s2) SCM s1, s2; { register sizet i,len; register unsigned char *c1, *c2; register int c; ASSERT(NIMP(s1) && STRINGP(s1),s1,ARG1,s_st_lessp); ASSERT(NIMP(s2) && STRINGP(s2),s2,ARG2,s_st_lessp); len = LENGTH(s1); i = LENGTH(s2); if (len>i) i=len; c1 = (unsigned char *) CHARS(s1); c2 = (unsigned char *) CHARS(s2); for(i=0;i0) return BOOL_F; if (c<0) return BOOL_T; } return (len != LENGTH(s2)) ? BOOL_T : BOOL_F; } SCM st_leqp(s1, s2) SCM s1, s2; { return st_lessp(s2, s1) ^ (BOOL_F ^ BOOL_T); } SCM stci_lessp(s1, s2) SCM s1, s2; { register sizet i,len; register unsigned char *c1, *c2; register int c; ASSERT(NIMP(s1) && STRINGP(s1),s1,ARG1,s_stci_lessp); ASSERT(NIMP(s2) && STRINGP(s2),s2,ARG2,s_stci_lessp); len = LENGTH(s1); i = LENGTH(s2); if (len>i) i=len; c1 = (unsigned char *) CHARS(s1); c2 = (unsigned char *) CHARS(s2); for(i=0;i0) return BOOL_F; if (c<0) return BOOL_T; } return (len != LENGTH(s2)) ? BOOL_T : BOOL_F; } SCM stci_leqp(s1, s2) SCM s1, s2; { return stci_lessp(s2, s1) ^ (BOOL_F ^ BOOL_T); } SCM substring(str,start,end) SCM str,start,end; { long l; ASSERT(NIMP(str) && STRINGP(str),str,ARG1,s_substring); ASSERT(INUMP(start),start,ARG2,s_substring); ASSERT(INUMP(end),end,ARG3,s_substring); ASSERT(INUM(start) <= LENGTH(str),start,OUTOFRANGE,s_substring); ASSERT(INUM(end) <= LENGTH(str),end,OUTOFRANGE,s_substring); l=INUM(end)-INUM(start); ASSERT(l>=0,MAKINUM(l),OUTOFRANGE,s_substring); if (l == 0) return nullstr; return makfromstr(&CHARS(str)[INUM(start)],(sizet)l); } SCM st_append(args) SCM args; { SCM res; register long i=0; register SCM l,s; register char *data; for(l=args;NIMP(l);) { ASSERT(CONSP(l),l,ARG1,s_st_append); s = CAR(l); ASSERT(NIMP(s) && STRINGP(s),s,ARG1,s_st_append); i += LENGTH(s); l=CDR(l); } ASSERT(NULLP(l),args,ARG1,s_st_append); if (i == 0) return nullstr; res = makstr(i); data = CHARS(res); for(l=args;NIMP(l);l=CDR(l)) { s = CAR(l); for(i=0;i=0,l,ARG1,s_vector); res = make_vector(MAKINUM(i),UNSPECIFIED); data = VELTS(res); for(;NIMP(l);l=CDR(l)) *data++ = CAR(l); return res; } SCM vector_ref(v, k) SCM v,k; { ASSERT(NIMP(v) && VECTORP(v),v,ARG1,s_ve_ref); ASSERT(INUMP(k),k,ARG2,s_ve_ref); ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k,OUTOFRANGE,s_ve_ref); return VELTS(v)[((long) INUM(k))]; } SCM vector_set(v,k,obj) SCM v,k,obj; { ASSERT(NIMP(v) && VECTORP(v),v,ARG1,s_ve_set); ASSERT(INUMP(k),k,ARG2,s_ve_set); ASSERT((INUM(k) < LENGTH(v)),k,OUTOFRANGE,s_ve_set); VELTS(v)[((long) INUM(k))] = obj; return UNSPECIFIED; } extern char s_apply[], s_map[], s_for_each[]; extern char s_make_vector[],s_force[],s_resizstr[],s_resizvect[]; static iproc cxrs[] = { {"car",0}, {"cdr",0}, {"caar",0}, {"cadr",0}, {"cdar",0}, {"cddr",0}, {"caaar",0}, {"caadr",0}, {"cadar",0}, {"caddr",0}, {"cdaar",0}, {"cdadr",0}, {"cddar",0}, {"cdddr",0}, {"caaaar",0}, {"caaadr",0}, {"caadar",0}, {"caaddr",0}, {"cadaar",0}, {"cadadr",0}, {"caddar",0}, {"cadddr",0}, {"cdaaar",0}, {"cdaadr",0}, {"cdadar",0}, {"cdaddr",0}, {"cddaar",0}, {"cddadr",0}, {"cdddar",0}, {"cddddr",0}, {0,0}}; static iproc subr1s[]={ {"not",lnot}, {"boolean?",booleanp}, {"pair?",consp}, {"null?",nullp}, {"list?",listp}, {s_length,length}, {s_reverse,reverse}, {"symbol?",symbolp}, {s_symbol2string,symbol2string}, {s_str2symbol,string2symbol}, {s_exactp,exactp}, {s_oddp,oddp}, {s_evenp,evenp}, {s_abs,absval}, {"char?",charp}, {s_ch_alphap,char_alphap}, {s_ch_nump,char_nump}, {s_ch_whitep,char_whitep}, {s_ch_upperp,char_upperp}, {s_ch_lowerp,char_lowerp}, {s_char2int,char2int}, {s_int2char,int2char}, {s_ch_upcase,char_upcase}, {s_ch_downcase,char_downcase}, {"string?",stringp}, {s_st_length,st_length}, {"vector?",vectorp}, {s_ve_length,vector_length}, {"procedure?",procedurep}, {s_force,force}, {0,0}}; static iproc subr2s[]={ {"eq?",eq}, {"equal?",equal}, {"cons",cons}, #ifndef PURE_FUNCTIONAL {s_setcar,setcar}, {s_setcdr,setcdr}, #endif {s_list_ref,list_ref}, {s_memq,memq}, {s_member,member}, {s_assq,assq}, {s_assoc,assoc}, {s_quotient,quotient}, {s_remainder,lremainder}, {s_modulo,modulo}, {"char=?",eq}, {s_ch_lessp,char_lessp}, {s_ci_eq,chci_eq}, {s_ci_lessp,chci_lessp}, {s_ch_leqp,char_leqp}, {s_ci_leqp,chci_leqp}, {s_st_ref,st_ref}, {s_st_equal,st_equal}, {s_stci_equal,stci_equal}, {s_st_lessp,st_lessp}, {s_stci_lessp,stci_lessp}, {"string<=?",st_leqp}, {"string-ci<=?",stci_leqp}, {s_ve_ref,vector_ref}, {0,0}}; static iproc lsubrs[]={ {s_list,list}, {s_append,append}, {s_string,string}, {s_st_append,st_append}, {s_vector,vector}, {0,0}}; static iproc lsubr2s[]={ {s_apply,apply}, {s_map,map}, {s_for_each,for_each}, {s_resizstr,resizstr}, {s_resizvect,resizvect}, {0,0}}; static iproc subr2os[]={ {s_make_string,make_string}, {s_make_vector,make_vector}, {0,0}}; static iproc asubrs[]={ {s_gcd,lgcd}, {s_lcm,llcm}, {0,0}}; static iproc subr2xs[]={ {"char>?",char_lessp}, {"char-ci>?",chci_lessp}, {"char>=?",char_leqp}, {"char-ci>=?",chci_leqp}, {"string>?",st_lessp}, {"string-ci>?",stci_lessp}, {"string>=?",st_leqp}, {"string-ci>=?",stci_leqp}, {0,0}}; static iproc subr3s[]={ {s_substring,substring}, #ifndef PURE_FUNCTIONAL {s_st_set,st_set}, {s_ve_set,vector_set}, #endif {0,0}}; void init_iprocs(subra, type) iproc *subra; int type; { for(;subra->string; subra++) make_subr(subra->string, type, subra->cproc); } void init_subrs() { init_iprocs(cxrs, tc7_cxr); init_iprocs(subr1s, tc7_subr_1); init_iprocs(subr2s, tc7_subr_2); init_iprocs(subr2os, tc7_subr_2o); init_iprocs(subr2xs, tc7_subr_2x); init_iprocs(lsubrs, tc7_lsubr); init_iprocs(lsubr2s, tc7_lsubr_2); init_iprocs(asubrs, tc7_asubr); init_iprocs(subr3s, tc7_subr_3); } @EOF chmod 666 subr.c echo x - sc2.c cat >sc2.c <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ #include "scm.h" static char s_last_pair[] = "last-pair"; SCM last_pair(sx) SCM sx; { register SCM res=sx; register SCM x; ASSERT(NIMP(res) && CONSP(res), res, ARG1, s_last_pair); while (!0) { x = CDR(res); if (IMP(x) || NCONSP(x)) return res; res = x; x = CDR(res); if (IMP(x) || NCONSP(x)) return res; res = x; sx=CDR(sx); ASSERT(x != sx, sx, ARG1, s_last_pair); } } static char s_subml[] = "substring-move-left!"; SCM subml(str1, start1, args) SCM str1, start1, args; { SCM end1, str2, start2; long i,j,e; ASSERT(3 == ilength(args),args,WNA,s_subml); end1 = CAR(args); args = CDR(args); str2 = CAR(args); args = CDR(args); start2 = CAR(args); ASSERT(NIMP(str1) && STRINGP(str1),str1,ARG1,s_subml); ASSERT(INUMP(start1),start1,ARG2,s_subml); ASSERT(INUMP(end1),end1,ARG3,s_subml); ASSERT(NIMP(str2) && STRINGP(str2),str2,ARG4,s_subml); ASSERT(INUMP(start2),start2,ARG5,s_subml); i=INUM(start1),j=INUM(start2),e=INUM(end1); ASSERT(i <= LENGTH(str1) && i >= 0,start1,OUTOFRANGE,s_subml); ASSERT(j <= LENGTH(str2) && j >= 0,start2,OUTOFRANGE,s_subml); ASSERT(e <= LENGTH(str1) && e >= 0,end1,OUTOFRANGE,s_subml); ASSERT(e-i+j <= LENGTH(str2), start2,OUTOFRANGE,s_subml); while(i= 0,start1,OUTOFRANGE,s_submr); ASSERT(j <= LENGTH(str2) && j >= 0,start2,OUTOFRANGE,s_submr); ASSERT(e <= LENGTH(str1) && e >= 0,end1,OUTOFRANGE,s_submr); ASSERT((j=e-i+j) <= LENGTH(str2), start2,OUTOFRANGE,s_submr); while(i= 0,start,OUTOFRANGE,s_subfl); ASSERT(e <= LENGTH(str) && e >= 0,end,OUTOFRANGE,s_subfl); while(iscm.h <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. The author can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880 */ typedef long SCM; typedef struct {SCM car,cdr;} cell; typedef struct {long sname;SCM (*cproc)();} subr; typedef struct {char *string;SCM (*cproc)();} iproc; #include "config.h" #ifdef FLOATS typedef struct {char *string;double (*cproc)();} dblproc; #ifdef SINGLES typedef struct {SCM type;float num;} flo; #endif typedef struct {SCM type;double *real;} dbl; #endif #define IMP(x) (6 & (int)(x)) #define NIMP(x) (!IMP(x)) #define INUMP(x) (2 & (int)(x)) #define NINUMP(x) (!INUMP(x)) #define MAKINUM(x) (((x)<<2)+2L) #define INUM0 ((SCM) 2) #define INUM(x) SRS(x,2) #define ICHRP(x) ((0xff & (int)(x))==0xf4) #define ICHR(x) ((unsigned char)((x)>>8)) #define MAKICHR(x) (((x)<<8)+0xf4L) #define ILOCP(n) ((0xff & (int)(n))==0xfc) #define ILOC00 (0x000000fcL) #define IDINC (0x00010000L) #define ICDR (0x00008000L) #define IFRINC (0x00000100L) #define IDSTMSK (-IDINC) #define IFRAME(n) ((int)((ICDR-IFRINC)>>8) & ((int)(n)>>8)) #define IDIST(n) (((unsigned long)(n))>>16) #define ICDRP(n) (ICDR & (n)) /* ISYMP tests for ISPCSYM and ISYM */ #define ISYMP(n) ((0x187 & (int)(n))==4) /* IFLAGP tests for ISPCSYM, ISYM and IFLAG */ #define IFLAGP(n) ((0x87 & (int)(n))==4) #define ISYMNUM(n) ((int)((n)>>9)) #define ISYMCHARS(n) (isymnames[ISYMNUM(n)]) #define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) #define MAKISYM(n) (((n)<<9)+0x74L) #define MAKIFLAG(n) (((n)<<9)+0x174L) extern char *isymnames[]; #define I_AND MAKSPCSYM(0) #define I_BEGIN MAKSPCSYM(1) #define I_CASE MAKSPCSYM(2) #define I_COND MAKSPCSYM(3) #define I_DEFINE MAKSPCSYM(4) #define I_DO MAKSPCSYM(5) #define I_IF MAKSPCSYM(6) #define I_LAMBDA MAKSPCSYM(7) #define I_LET MAKSPCSYM(8) #define I_LETSTAR MAKSPCSYM(9) #define I_LETREC MAKSPCSYM(10) #define I_OR MAKSPCSYM(11) #define I_QUOTE MAKSPCSYM(12) #define I_SET MAKSPCSYM(13) /* each symbol defined here must have a unique number which */ /* corresponds to it's position in isymnames[] in sys.c */ #define I_QUASIQUOTE MAKISYM(14) #define I_DEFINEDP MAKISYM(15) #define I_DELAY MAKISYM(16) #define NUM_XSPCSYMS 17 #define I_ARROW MAKISYM(NUM_XSPCSYMS+0) #define I_ELSE MAKISYM(NUM_XSPCSYMS+1) #define I_UNQUOTE MAKISYM(NUM_XSPCSYMS+2) #define I_UQ_SPLICING MAKISYM(NUM_XSPCSYMS+3) #define I_DOT MAKISYM(NUM_XSPCSYMS+4) #define NUM_ISYMS (NUM_XSPCSYMS+5) #define BOOL_F MAKIFLAG(NUM_ISYMS+0) #define BOOL_T MAKIFLAG(NUM_ISYMS+1) #define UNDEFINED MAKIFLAG(NUM_ISYMS+2) #define EOF_VAL MAKIFLAG(NUM_ISYMS+3) #define EOL MAKIFLAG(NUM_ISYMS+4) #define UNSPECIFIED MAKIFLAG(NUM_ISYMS+5) #define FALSEP(x) ((x) == BOOL_F) #define NFALSEP(x) ((x) != BOOL_F) #define NULLP(x) ((x) == EOL) #define NNULLP(x) ((x) != EOL) #define UNBNDP(x) ((x) == UNDEFINED) #define CELLP(x) (!NCELLP(x)) #define NCELLP(x) ((sizeof(cell)-1) & (int)(x)) #define GCMARKP(x) (1 & (int)CDR(x)) #define GC8MARKP(x) (0x80 & (int)CAR(x)) #define SETGCMARK(x) CDR(x) |= 1; #define CLRGCMARK(x) CDR(x) &= ~1L; #define SETGC8MARK(x) CAR(x) |= 0x80; #define CLRGC8MARK(x) CAR(x) &= ~0x80L; #define TYP3(x) (7 & (int)CAR(x)) #define TYP7(x) (0x7f & (int)CAR(x)) #define TYP16(x) (0xffff & (int)CAR(x)) #define GCTYP16(x) (0xff7f & (int)CAR(x)) #define NCONSP(x) (1 & (int)CAR(x)) #define CONSP(x) (!NCONSP(x)) #define ECONSP(x) (CONSP(x) || (TYP3(x) == 1)) #define NECONSP(x) (NCONSP(x) && (TYP3(x) != 1)) #define CAR(x) (((cell *)(x))->car) #define CDR(x) (((cell *)(x))->cdr) #define GCCDR(x) (~1L & CDR(x)) #define SETCDR(x,v) CDR(x)=(SCM)(v) #define CLOSUREP(x) (TYP3(x) == tc3_closure) #define CODE(x) (CAR(x)-tc3_closure) #define SETCODE(x,e) CAR(x)=(e)+tc3_closure #define ENV(x) CDR(x) #define SYMBOLP(x) (TYP3(x) == tc3_symbol) #define NAMESTR(x) (CAR(x)-tc3_symbol) #define SETNAMESTR(x,v) CAR(x)=(v)+tc3_symbol #define VCELL(x) CDR(x) #define PORTP(x) ((0x8ffff & CAR(x)) == tc16_port) #define PIPEP(x) ((0x8ffff & CAR(x)) == (tc16_port | PIP)) #define OPPORTP(x) ((0x1ffff & ~PIP & CAR(x)) == (tc16_port | OPN)) #define OPINPORTP(x) ((~WRTNG & ~PIP & CAR(x)) == tc_inport) #define OPOUTPORTP(x) ((~RDNG & ~PIP & CAR(x)) == tc_outport) #define INPORTP(x) ((~WRTNG & ~OPN & ~PIP & CAR(x)) == (tc_inport & ~OPN)) #define OUTPORTP(x) ((~RDNG & ~OPN & ~PIP & CAR(x)) == (tc_outport & ~OPN)) #define OPENP(x) (OPN & CAR(x)) #define CLOSEDP(x) (!OPENP(x)) #define STREAM(x) ((FILE *)(CDR(x))) #define SETSTREAM(x,v) SETCDR(x,v) #ifdef FLOATS #define INEXP(x) (TYP16(x) == tc16_flo) #define CPLXP(x) (CAR(x) == tc_dblc) #define REAL(x) (*(((dbl *) (x))->real)) #define IMAG(x) ((&REAL(x))[1]) #ifdef SINGLES #define REALP(x) ((~REAL_PART & CAR(x))==tc_flo) #define SINGP(x) (CAR(x)==tc_flo) #define FLO(x) (((flo *) (x))->num) #define REALPART(x) (SINGP(x)?0.0+FLO(x):REAL(x)) #else /* SINGLES */ #define REALP(x) (CAR(x)==tc_dblr) #define REALPART(x) REAL(x) #endif /* SINGLES */ #endif #define SUBRP(x) ((TYP3(x)==7) && (96 & CAR(x)) && (TYP7(x)!=tc7_smob)) #define SNAME(x) (heap_org+(CAR(x)>>8)) #define SETSNAME(x,v,t) CAR(x)=((((CELLPTR)(v))-heap_org)<<8)+(t) #define SUBRF(x) (((subr *)(x))->cproc) #define STRINGP(x) (TYP7(x) == tc7_string) #define NSTRINGP(x) (!STRINGP(x)) #define VECTORP(x) (TYP7(x) == tc7_vector) #define NVECTORP(x) (!VECTORP(x)) #define LENGTH(x) (CAR(x)>>8) #define SETLENGTH(x,v,t) CAR(x) = ((v)<<8)+t #define CHARS(x) ((char *)(CDR(x))) #define VELTS(x) ((SCM *)CDR(x)) #define SETCHARS(x,v) SETCDR(x,v) #define SETVELTS(x,v) SETCDR(x,v) #define FREEP(x) (CAR(x) == tc_free_cell) #define NFREEP(x) (!FREEP(x)) #define tcs_cons_imcar 2:case 4:case 6:case 10:\ case 12:case 14:case 18:case 20:\ case 22:case 26:case 28:case 30:\ case 34:case 36:case 38:case 42:\ case 44:case 46:case 50:case 52:\ case 54:case 58:case 60:case 62:\ case 66:case 68:case 70:case 74:\ case 76:case 78:case 82:case 84:\ case 86:case 90:case 92:case 94:\ case 98:case 100:case 102:case 106:\ case 108:case 110:case 114:case 116:\ case 118:case 122:case 124:case 126 #define tcs_cons_nimcar 0:case 8:case 16:case 24:\ case 32:case 40:case 48:case 56:\ case 64:case 72:case 80:case 88:\ case 96:case 104:case 112:case 120 #define tcs_cons_gloc 1:case 9:case 17:case 25:\ case 33:case 41:case 49:case 57:\ case 65:case 73:case 81:case 89:\ case 97:case 105:case 113:case 121 #define tcs_closures 3:case 11:case 19:case 27:\ case 35:case 43:case 51:case 59:\ case 67:case 75:case 83:case 91:\ case 99:case 107:case 115:case 123 #define tcs_symbols 5:case 13:case 21:case 29:\ case 37:case 45:case 53:case 61:\ case 69:case 77:case 85:case 93:\ case 101:case 109:case 117:case 125 #define tcs_subrs tc7_subr_0:case tc7_subr_1:case tc7_cxr:case tc7_subr_3:\ case tc7_subr_2:case tc7_subr_2x:case tc7_subr_1o:\ case tc7_subr_2o:case tc7_lsubr:case tc7_lsubr_2:case tc7_asubr #define tc3_cons 0 #define tc3_cons_gloc 1 #define tc3_closure 3 #define tc3_symbol 5 #define tc7_vector 7 #define tc7_string 15 /* #define tc7_spare 23 */ #define tc7_contin 31 #define tc7_subr_0 39 #define tc7_subr_1 47 #define tc7_cxr 55 #define tc7_subr_3 63 #define tc7_subr_2 71 #define tc7_subr_2x 79 #define tc7_subr_1o 87 #define tc7_subr_2o 95 #define tc7_lsubr 103 #define tc7_lsubr_2 111 #define tc7_asubr 119 #define tc7_smob 127 #define tc_free_cell 127 #ifdef FLOATS #define tc16_flo 0x017f #ifdef SINGLES #define tc_flo 0x017fL #endif #define REAL_PART (1L<<16) #define IMAG_PART (2L<<16) #define tc_dblr (tc16_flo|REAL_PART) #define tc_dblc (tc16_flo|REAL_PART|IMAG_PART) #endif /* FLOATS */ #define tc16_bigpos 0x027f #define tc16_bigneg 0x037f #define tc16_port 0x047f #define OPN (1L<<16) #define RDNG (2L<<16) #define WRTNG (4L<<16) #define PIP (8L<<16) #define tc_inport (tc16_port|OPN|RDNG) #define tc_outport (tc16_port|OPN|WRTNG) #define tc_ioport (tc16_port|OPN|RDNG|WRTNG) #define tc_inpipe (tc16_port|OPN|RDNG|PIP) #define tc_outpipe (tc16_port|OPN|WRTNG|PIP) #define tc16_promise 0x057f #define tc16_arbiter 0x067f #define tc16_cptr 0x077f #define CPTRP(x) (TYP16(x)==tc16_cptr) #define CLEN(x) (CAR(x)>>16) #define CPTR(x) ((char*)CDR(x)) #define SETCPTR(x,v) (SETCDR(x,(long)v)) #define tc16_record 0x087f #define tc16_recons 0x097f #define tc16_recacc 0x0a7f #define tc16_recmod 0x0b7f #define tc16_recpred 0x0c7f extern SCM sys_protects[]; #define cur_inp sys_protects[0] #define cur_outp sys_protects[1] #define listofnull sys_protects[2] #define undefineds sys_protects[3] #define nullvect sys_protects[4] #define nullstr sys_protects[5] #define symhash sys_protects[6] #define progargs sys_protects[7] #define transcript sys_protects[8] #define def_inp sys_protects[9] #define def_outp sys_protects[10] #ifdef FLOATS #define flo0 sys_protects[11] #define NUM_PROTECTS 12 #else #define NUM_PROTECTS 11 #endif /* now for connects between source files */ extern unsigned char upcase[],downcase[]; extern int symhash_dim; extern long heap_size; extern SCMPTR stack_start_ptr; extern CELLPTR heap_org; extern SCM freelist; extern long gc_cells_collected, gc_malloc_collected, gc_ports_collected; extern long cells_allocated; extern long linum; extern int errjmp_ok, ints_disabled, sig_deferred, alrm_deferred; void han_sig(), han_alrm(); char *must_malloc(); long ilength(); extern char s_read[], s_write[], s_newline[]; extern char s_list[], s_vector[], s_string[]; SCM repl_driver(); void make_subr(); void repl(), gc_end(), gc_start(), growth_mon(), lthrow(); void iprin1(), intprint(), iprlist(), lputc(), lputs(); int lfwrite(); long time_in_msec(); SCM my_time(); void init_tables(), init_storage(), init_subrs(), init_features(); void init_iprocs(), init_scm(), init_scl(), init_io(), init_repl(); void init_time(), init_signals(), ignore_signals(), unignore_signals(); void init_sc2(); void warn(), wta(), everr(); SCM sysintern(), intern(), makstr(), makfromstr(), closure(); SCM makprom(), force(), makarb(), tryarb(), relarb(); SCM ceval(), prolixity(), gc(), gc_for_newcell(); SCM char_readyp(), tryload(); SCM cons2(),cons2r(),resizstr(),resizvect(); SCM lnot(), booleanp(), eq(), equal(); SCM consp(), cons(), nullp(); SCM setcar(), setcdr(); SCM listp(), list(), length(), append(), reverse(), list_ref(); SCM memq(), memv(), member(), assq(), assoc(); SCM symbolp(), symbol2string(), string2symbol(); SCM numberp(), exactp(), inexactp(); SCM eqp(), lessp(), greaterp(), lesseqp(), greatereqp(); SCM zerop(), positivep(), negativep(), oddp(), evenp(); SCM lmax(), lmin(), sum(), product(), difference(), quotient(), absval(); SCM lremainder(), modulo(), lgcd(), llcm(), number2string(), string2number(); SCM makdbl(),istr2flo(); sizet iint2str(),iflo2str(); SCM charp(), char_lessp(), chci_eq(), chci_lessp(); SCM char_alphap(), char_nump(), char_whitep(), char_upperp(), char_lowerp(); SCM char2int(), int2char(), char_upcase(), char_downcase(); SCM stringp(), make_string(), string(); SCM st_length(), st_ref(), st_set(); SCM st_equal(), stci_equal(); SCM st_lessp(), stci_lessp(), substring(), st_append(); SCM vectorp(), make_vector(), vector(), vector_length(); SCM vector_ref(), vector_set(); SCM for_each(), procedurep(), apply(), map(), call_cc(); extern SCM throwval, quit(); SCM cw_input_file(), cw_output_file(); SCM input_portp(), output_portp(), cur_input_port(), cur_output_port(); SCM open_file(), open_pipe(), close_port(), close_pipe(); SCM lread(), read_char(), peek_char(), eof_objectp(); SCM lwrite(), display(), newline(), write_char(); #ifdef IO_EXTENSIONS SCM file_position(), file_set_position(); SCM read_to_string(); #endif SCM lgetenv(), prog_args(); #define DIGITS '0':case '1':case '2':case '3':case '4':\ case '5':case '6':case '7':case '8':case '9' #ifdef RECKLESS #define ASSERT(_cond,_arg,_pos,_subr) ; #define ASRTGO(_cond,_label) ; #else #define ASSERT(_cond,_arg,_pos,_subr) if(!(_cond))wta(_arg,(char *)_pos,_subr); #define ASRTGO(_cond,_label) if(!(_cond)) goto _label; #endif #define ARG1 1 #define ARG2 2 #define ARG3 3 #define ARG4 4 #define ARG5 5 #define WNA 6 #define OVFLOW 7 #define OUTOFRANGE 8 #define NALLOC 9 #define EXIT 10 #define HUP_SIGNAL 11 #define INT_SIGNAL 12 #define FPE_SIGNAL 13 #define BUS_SIGNAL 14 #define SEGV_SIGNAL 15 #define ALRM_SIGNAL 16 #define EVAL(x,env) (IMP(x)?(x):ceval((x),(env))) #define SIDEVAL(x,env) if NIMP(x) ceval((x),(env)) @EOF chmod 666 scm.h echo x - config.h cat >config.h <<'@EOF' /* Scheme implementation intended for JACAL. Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. See the file "COPYING" for terms applying to this program */ /* SCMVERSION is a string for the version specifier. The number is the major version number and the trailing letter is the revision: "a" for alpha release, "b" for beta release, "c", "d", and so on. There is a separate PATCHLEVEL defined in "patchlvl.h" */ #ifndef SCMVERSION #define SCMVERSION "4a" #endif /* If your scheme code runs under this program without any errors you can disable almost all error checking by compiling all files with this line or better yet by changing the makefile. */ /* #define RECKLESS */ /* IMPLINIT is the full pathname (surrounded by double quotes) of Init.scm, the Scheme initialization code. This is best defined in the makefile, if possible. If available, scm uses the value of environment variable SCM_INIT_PATH instead of IMPLINIT. */ /* #define IMPLINIT "/usr/jaffer/scm/Init.scm" */ /* INITS is calls to initialization routines for any compiled libraries being linked into scm. This is best done in the makefile. */ /* #define INITS init_db() */ /* Define SYNTAX_EXTENSIONS if you want DEFINED? */ #define SYNTAX_EXTENSIONS /* Define REV2_PROCEDURES if you need substring-move-left!, substring-move-right!, substring-fill!, append!, and last-pair. You can remove the object file for sc2.c from linking if REV2_PROCEDURES is not defined. */ #define REV2_PROCEDURES /* Define IO_EXTENSIONS if you want R/W files and file-position */ #define IO_EXTENSIONS /* Only some machines have pipes */ #ifdef IO_EXTENSIONS # ifdef unix /* DJGPP (gcc for i386) defines unix! */ # ifndef GNUDOS # define HAVE_PIPE # endif # endif #endif /* Define BIGDIG to an integer type whose size is smaller than long if you want bignums. BIGNUMS ARE NOT IMPLEMENTED YET. */ /* #define BIGDIG short */ /* Define FLOATS if you want floating point numbers. This is best done in the Makefile */ /* #define FLOATS */ /* Define SINGLES if you want single precision floats and (sizeof (float) == sizeof (long)) */ #ifdef FLOATS #define SINGLES #endif /* Define SINGLESONLY if you want all inexact real numbers to be single precision. This only has an effect if SINGLES is also defined. This does not affect complex numbers */ /* #define SINGLESONLY */ /* Define ENGNOT if you want floats to display in engineering notation (exponents always multiples of 3) instead of scientific notation. */ #define ENGNOT /* FLOBUFLEN is the maximum number of characters you expect to be neccessary for the printed or string representation of an inexact number. This assumes that sizeof is in units of 8 bits. */ # ifdef FLOATS # define FLOBUFLEN (10+5*sizeof(double)) # endif /* FLOATS */ /* INTBUFLEN is the maximum number of characters you expect to be neccessary for the printed or string representation of an exact number. This assumes that sizeof is in units of 8 bits. */ #define INTBUFLEN (5+8*sizeof(long)) /* MEMOIZE_LOCALS will speed up most local variable references. You will need to remove this and recompile eval.c if you use very large or deep environments (more than 32767 bound variables in one procedure)*/ #define MEMOIZE_LOCALS /* PROT386 should be defined on the compilation command line if the program is to be run on an intel 386 in protected mode. `Huge' pointers common on MSDOS compilers do not work in protected mode. PROT386 is required if scm is to run as part of a Microsoft Windows application. Added by Stephen Adams 8 May 92 */ /* #define PROT386 */ #ifndef THINK_C # ifdef __WINDOWS__ /* there should be a better flag for this. */ # define PROT386 # endif #endif /* PTR_LT defines how to compare two CELLPTRs (which may not be in the same array). CELLPTR is a pointer to a cons cell which may be compared or differenced. SCMPTR is used for stack bounds. */ #ifdef __TURBOC__ # define MSDOS # ifdef PROT386 typedef cell *CELLPTR; typedef SCM *SCMPTR; # define PTR_LT(x,y) (((long)(x)) < ((long)(y))) # else typedef cell huge *CELLPTR; typedef SCM huge *SCMPTR; # define PTR_LT(x,y) ((x) < (y)) # endif #else /* not __TURBOC__ */ typedef cell *CELLPTR; typedef SCM *SCMPTR; # ifdef nosve # define PTR_MASK 0xffffffffffff # define PTR_LT(x,y) (((int)(x)&PTR_MASK) < ((int)(y)&PTR_MASK)) # else # define PTR_LT(x,y) ((x) < (y)) # endif #endif /* STDC_HEADERS indicates that the include file names are the same as ANSI C. For most modern systems this is the case. */ /* added by Yasuaki Honda */ #ifdef THINK_C #define __STDC__ #endif #ifdef __STDC__ #define STDC_HEADERS #endif #ifdef MSDOS #define STDC_HEADERS #endif #ifdef vms #define STDC_HEADERS #endif #ifdef nosve #define STDC_HEADERS #endif #ifdef STDC_HEADERS # include # ifdef AMIGA # include # endif # define sizet size_t #else # ifdef _SIZE_T # define sizet size_t # else # define sizet unsigned int # endif #endif #ifdef sequent #include #define strchr index #define strrchr rindex #else #include #endif /* On VMS, GNU C's errno.h contains a special hack to get link attributes for errno correct for linking to the C RTL. */ #include /* SYSCALL retries system calls that have been interrupted (EINTR) */ #ifdef EINTR # if (EINTR > 0) # define SYSCALL(line) do{errno=0;line}while(errno==EINTR) # endif #endif #ifndef SYSCALL # define SYSCALL(line) {line} #endif #ifndef MSDOS extern int errno; #endif #if (__TURBOC__==1) /* Needed for TURBOC V1.0 */ extern int errno; #endif /* #define CAREFUL_INTS for extra consistency checking. This is for debugging C code in sys.c and repl.c. */ /* #define CAREFUL_INTS */ #ifdef CAREFUL_INTS #define DEFER_INTS {if (ints_disabled) puts("ints already disabled"); \ ints_disabled = 1;} #define ALLOW_INTS {if (!ints_disabled) puts("ints already enabled"); \ ints_disabled = 0;CHECK_INTS} #else #define DEFER_INTS {ints_disabled = 1;} #define ALLOW_INTS {ints_disabled = 0;CHECK_INTS} #endif #define CHECK_INTS {if (sig_deferred) han_sig();if (alrm_deferred) han_alrm();} /* LINE_INCREMENTORS are the characters which cause the line count to be incremented for the purposes of error reporting. This feature is only used for scheme code loaded from files. WHITE_SPACES are other characters which should be treated like spaces in programs. in both cases sparate characters with ":case " */ #define LINE_INCREMENTORS '\n' #define WHITE_SPACES ' ':case '\t':case '\r':case '\f' /* The following 6 definitions are defined automatically by the C pre-processor. You will need to override these if you are cross-compiling or if the C pre-processor has different properties than the compiler. */ #if (((-1)%2 == -1) && ((-1)%(-2) == -1) && (1%2 == 1) && (1%(-2) == 1)) #else #define BADIVSGNS #endif /* SRS is signed right shift */ /*--- Turbo C++ v1.0 has a bug with right shifts of signed longs! It is believed to be fixed in Turbo C++ v1.01 ---*/ #if ((((-1L)<<2)+2)>>2 == -1L) && (__TURBOC__ != 0x295) #define SRS(x,y) ((x)>>y) #else #define SRS(x,y) (((x)<0) ? ~((~(x))>>y) : (x)>>y) #endif #if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) #define EBCDIC #endif #if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) #define ASCII #endif /* CHAR_CODE_LIMIT is the number of distinct characters represented by the unsigned char datatype. */ /* most-positive-fixnum is the INUM closest to positive infinity. */ /* MOST_NEGATIVE_FIXNUM is the INUM closest to negative infinity. */ #ifdef __STDC__ #include # ifdef UCHAR_MAX # define CHAR_CODE_LIMIT (UCHAR_MAX+1) # else # define CHAR_CODE_LIMIT 256 # endif # define MOST_POSITIVE_FIXNUM (LONG_MAX>>2) # define MOST_NEGATIVE_FIXNUM SRS(LONG_MIN,2) #else # define CHAR_CODE_LIMIT 256 # define MOST_POSITIVE_FIXNUM ((unsigned long)~0L>>3) # if (0 != ~0) # define MOST_NEGATIVE_FIXNUM (-MOST_POSITIVE_FIXNUM-1) # else # define MOST_NEGATIVE_FIXNUM (-MOST_POSITIVE_FIXNUM) # endif #endif /* the rest of "scm.h" applies only to sys.c */ #ifdef IN_SYS /* FLTRADIX is the base of the mantissa of floating point numbers (usually 2) */ /* FLTMAX is less than or equal the largest single precision float */ #ifdef FLOATS # ifdef STDC_HEADERS # ifndef GNUDOS # include # endif # endif # ifdef FLT_RADIX # define FLTRADIX FLT_RADIX # else # define FLTRADIX 2 # endif # ifdef FLT_MAX # define FLTMAX FLT_MAX # else # define FLTMAX 1e+23 /* 1e37 */ # endif #endif /* end of automatic C pre-processor definitions */ /* TEMPTEMPLATE is used only if mktemp() is being used instead of tmpnam(). */ #ifdef AMIGA # define TEMPTEMPLATE "T:SchemeaaaXXXXXX"; #else char *mktemp(); # ifdef VMS # define TEMPTEMPLATE "sys$scratch:aaaXXXXXX"; # else /* VMS */ # ifdef __MSDOS__ # ifdef GNUDOS # define TEMPTEMPLATE "\\tmp\\TMPaaaXXXXXX"; # else # define TEMPTEMPLATE "TMPaaaXXXXXX"; # endif # else /* __MSDOS__ */ # define TEMPTEMPLATE "/usr/tmp/aaaXXXXXX"; # endif /* __MSDOS__ */ # endif /* VMS */ #endif /* AMIGA */ /* If you only need straight stack continuations CHEAP_CONTINUATIONS will run faster and use less storage than not having it. Machines with unusual stacks need this. Also, if you incorporate new C code into scm which uses VMS system services or library routines (which need to unwind the stack in an ordrly manner) you may need to define CHEAP_CONTINUATIONS. */ /* #define CHEAP_CONTINUATIONS */ /* James Clark came up with this neat one instruction fix for continuations on the SPARC. It flushes the register windows so that all the state of the process is contained in the stack. */ #ifdef sparc #define FLUSH_REGISTER_WINDOWS asm("ta 3") #else #define FLUSH_REGISTER_WINDOWS /* empty */ #endif /* If stack is not longword aligned then */ /* #define SHORT_ALIGN */ #ifdef THINK_C #define SHORT_ALIGN #endif #ifdef MSDOS #define SHORT_ALIGN #endif /* If stacks grow up then */ /* #define STACK_GROWS_UP */ #ifdef hp9000s800 #define STACK_GROWS_UP #endif #ifdef pyr #define STACK_GROWS_UP #endif #ifdef nosve #define STACK_GROWS_UP #endif /* CELL_UP and CELL_DN are used by init_heap_seg to find cell aligned inner bounds for allocated storage */ #ifdef PROT386 /*in 386 protected mode we must only adjust the offset */ #define CELL_UP(p) MK_FP(FP_SEG(p),~7&(FP_OFF(p)+7)) #define CELL_DN(p) MK_FP(FP_SEG(p),~7&FP_OFF(p)) #else #define CELL_UP(p) (CELLPTR)(~(sizeof(cell)-1L) & ((long)(p)+sizeof(cell)-1L)) #define CELL_DN(p) (CELLPTR)(~(sizeof(cell)-1L) & (long)(p)) #endif /* how to get the local definition for malloc */ #ifndef STDC_HEADERS char *malloc(); char *realloc(); #endif /* NUM_HASH_BUCKETS is the number of symbol hash table buckets. */ #define NUM_HASH_BUCKETS 137 /* If fewer than MIN_GC_YIELD cells are recovered during a garbage collection (GC) more space is allocated for the heap. */ #define MIN_GC_YIELD (heap_size/5) /* These are parameters for controlling memory allocation. The heap is the area out of which cons and object headers is allocated. Each heap object is 8 bytes on a 32 bit machine and 16 bytes on a 64 bit machine. The units of the _SIZE parameters are bytes. INIT_HEAP_SIZE is the initial size of heap. If this much heap is allocated initially the heap will grow by half its current size each subsequent time more heap is needed. If INIT_HEAP_SIZE heap cannot be allocated initially, HEAP_SEG_SIZE will be used, and the heap will grow by HEAP_SEG_SIZE when more heap is needed. HEAP_SEG_SIZE must fit into type sizet. This code is in init_storage() and alloc_some_heap() in sys.c MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap is needed. */ #define INIT_HEAP_SIZE (25000L*sizeof(cell)) #define MIN_HEAP_SEG_SIZE (2000L*sizeof(cell)) #ifdef _QC #define HEAP_SEG_SIZE 32400L #else #define HEAP_SEG_SIZE (8100L*sizeof(cell)) #endif #endif /* IN_SYS */ @EOF chmod 666 config.h echo x - patchlvl.h cat >patchlvl.h <<'@EOF' #define PATCHLEVEL 5 @EOF chmod 666 patchlvl.h echo x - Init.scm cat >Init.scm <<'@EOF' ;;;; "Init.scm", Scheme initialization code for SCM. ;;; Copyright (C) 1991, 1992 Aubrey Jaffer. ;;; See the file `COPYING' for terms applying to this program. ;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper ;;; mode to open files in. MSDOS does carraige return - newline ;;; translation if not opened in `b' mode. (define OPEN_READ (if (eq? 'MSDOS (software-type)) "rb" "r")) (define OPEN_WRITE (if (eq? 'MSDOS (software-type)) "wb" "w")) (define OPEN_BOTH (if (eq? 'MSDOS (software-type)) "r+b" "r+")) (define (open-input-file str) (or (open-file str OPEN_READ) (and (procedure? could-not-open) (could-not-open) #f) (error "OPEN-INPUT-FILE couldn't find file " str))) (define (open-output-file str) (or (open-file str OPEN_WRITE) (and (procedure? could-not-open) (could-not-open) #f) (error "OPEN-OUTPUT-FILE couldn't find file " str))) (define (open-io-file str) (open-file str OPEN_BOTH)) (define close-input-port close-port) (define close-output-port close-port) (define close-io-port close-port) (define (call-with-input-file str proc) (let* ((file (open-input-file str)) (ans (proc file))) (close-input-port file) ans)) (define (call-with-output-file str proc) (let* ((file (open-output-file str)) (ans (proc file))) (close-output-port file) ans)) (define (with-input-from-file str thunk) (let* ((port (set-current-input-port (open-input-file str))) (ans (apply thunk '()))) (close-port (set-current-input-port port)) ans)) (define (with-output-to-file str thunk) (let* ((port (set-current-output-port (open-output-file str))) (ans (apply thunk '()))) (close-port (set-current-output-port port)) ans)) (define (file-exists? str) (let ((port (open-file str OPEN_READ))) (if port (begin (close-port port) #t) #f))) (if (memq 'pipe *features*) (define (open-input-pipe str) (open-pipe str "r"))) (if (memq 'pipe *features*) (define (open-output-pipe str) (open-pipe str "w"))) (set! *features* (append '(getenv tmpnam system abort integer-limits p1178 rev4-report rev4-optional-procedures rev3-procedures rev2-procedures delay) *features*)) ;;; Autoloads for SLIB procedures. (define (tracef . args) (require 'debug) (apply tracef args)) ;;; Macros. #.(define (trace proc) `(set! ,proc (tracef ,proc ',proc))) #.(define (untrace proc) `(set! ,proc (untracef ,proc))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") (case (software-type) ((UNIX) "/usr/lib/scheme/") ((VMS) "lib$scheme:") ((MSDOS) "C:\\SCM\\SLIB\\") ((MACOS THINKC) "camus Napoleon:Think C4.0:scm3.0:") ((AMIGA) "Scheme:libs/") ((ATARIST) "C:\\MISC\\SLIB\\1B6\\") (else ""))))) (lambda () library-path))) ;;; program-vicinity is here in case the Scheme Library cannot be found. (define program-vicinity (let ((*vicinity-suffix* (case (software-type) ((UNIX AMIGA) '(#\/)) ((VMS) '(#\: #\])) ((MSDOS) '(#\\)) ((MACOS THINKC) '(#\:))))) (lambda () (let loop ((i (- (string-length *load-pathname*) 1))) (cond ((negative? i) "") ((memv (string-ref *load-pathname* i) *vicinity-suffix*) (substring *load-pathname* 0 (+ i 1))) (else (loop (- i 1)))))))) (define scheme-file-suffix (case (software-type) ((NOSVE) (lambda () "_scm")) (else (lambda () ".scm")))) (define in-vicinity string-append) (cond ((try-load (in-vicinity (library-vicinity) "require" (scheme-file-suffix)))) (else (perror "WARNING") (display "WARNING: Couldn't find require.scm in (library-vicinity)") (write (library-vicinity)) (newline) (set-errno! 0))) ;;; DO NOT MOVE! This has to be done after "require.scm" is loaded. (set! load (lambda (file) (cond ((> (verbose) 0) (display ";loading ") (write file) (newline))) (force-output) (or (try-load file) ;;HERE is where the suffix gets specified (try-load (string-append file ".scm")) (and (procedure? could-not-open) (could-not-open) #f) (error "LOAD couldn't find file " file)) (set-errno! 0) (cond ((> (verbose) 0) (display ";done loading ") (write file) (newline))))) (define could-not-open #f) (define (error . args) (perror "ERROR") (set-errno! 0) (display "ERROR: ") (if (not (null? args)) (begin (display (car args)) (for-each (lambda (x) (display #\ ) (write x)) (cdr args)))) (newline) (abort)) (define (output-port-width . arg) 79) (define slib:error error) ;;; This is the vicinity where this file resides. (define implementation-vicinity (let ((vic (program-vicinity))) (lambda () vic))) (define (terms) (list-file (in-vicinity (implementation-vicinity) "COPYING"))) (define (list-file file) (call-with-input-file file (lambda (inport) (do ((c (read-char inport) (read-char inport))) ((eof-object? c)) (write-char c))))) ;;;; Here are some Revised^2 Scheme functions: (define 1+ (let ((+ +)) (lambda (n) (+ n 1)))) (define -1+ (let ((+ +)) (lambda (n) (+ n -1)))) (define 1- -1+) (define ? >) (define >=? >=) (define t #t) (define nil #f) ;; define these as appropriate for your system. (define slib:tab #\tab) (define slib:form-feed #\page) (if (= (length (program-arguments)) 1) (verbose 1)) (if (not (memq 'ed *features*)) (define (ed . args) (system (apply string-append (or (getenv "EDITOR") "ed") (map (lambda (s) (string-append " " s)) args))))) (if (not (memq 'ed *features*)) (set! *features* (cons 'ed *features*))) ;;; ABS and MAGNITUDE can be the same. (if (inexact? (string->number "0.0")) (set! abs magnitude)) ;;; This loads JCAL, the user's initialization file, or files named in ;;; program arguments. (let ((progname (car (program-arguments)))) (or (eq? (software-type) 'THINKC) (member "-no-init-file" (program-arguments)) ;; This clause is special for JACAL (let ((len (string-length progname))) (and (cond ((>= len 4) (string-ci=? "JCAL" (substring progname (- len 4) len))) ((>= len 5) (string-ci=? "JACAL" (substring progname (- len 5) len))) (else #f)) (verbose 0) (try-load (or (getenv "JCAL_INIT") (case (software-type) ((UNIX) "/usr/lib/jcal/math.scm") ((VMS) "lib$jcal:math.scm") ((MSDOS) "C:\\SCM\\JCAL\\MATH.SCM") ((MACOS THINKC) "camus Napoleon:Think C4.0:jcal:math.scm") ((AMIGA) "Jcal:libs/math.scm") (else "math.scm")))) (set! *load-pathname* #f) (math))) (and (not (string-ci=? (car (program-arguments)) "SCM")) ;this file! (let ((path (getenv (string-append (car (program-arguments)) "_INIT_PATH")))) (and path (cond ((try-load path) #t) (else (display "WARNING: Couldn't find ") (display path) (newline) #f))))) ;; If your program uses an _INIT_PATH file you need to replicate ;; the following terms if you want them executed. (try-load (in-vicinity (let ((home (getenv "HOME"))) (if home (case (software-type) ((UNIX) (if (char=? #\/ (string-ref home (+ -1 (string-length home)))) home ;V7 unix has a / on HOME (string-append home "/"))) (else home)) (user-vicinity))) "ScmInit.scm")) (begin (set-errno! 0) (for-each load (cdr (program-arguments)))))) @EOF chmod 666 Init.scm echo x - test.scm cat >test.scm <<'@EOF' ;;;; `test.scm' Test correctness of scheme implementations. ;;; Copyright (C) 1991 Aubrey Jaffer. ;;; This includes examples from ;;; William Clinger and Jonathan Rees, editors. Revised^3.99 ;;; Report on the Algorithmic Language Scheme. DRAFT August 31, 1989 ;;; and the IEEE specification. ;;; The input tests read this file expecting it to be named "test.scm". ;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running ;;; these tests. You may need to delete them in order to run ;;; "test.scm" more than once. ;;; There are three optional tests: (test-cont) tests multiple returns ;;; from a call-with-current-continuation; (test-sc4) tests ;;; procedures required by R3.99RS but not by IEEE; (test-inexact) tests ;;; inexact numbers. ;;; If you are testing a R3RS version which does not have `list?' do: ;;; (define list? #f) ;;; send corrections or additions to jaffer@ai.mit.edu or ;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA (define cur-section '())(define errs '()) (define SECTION (lambda args (display "SECTION") (write args) (newline) (set! cur-section args) #t)) (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) (define test (lambda (expect fun . args) (write (cons fun args)) (display " ==> ") ((lambda (res) (write res) (newline) (cond ((not (equal? expect res)) (record-error (list res expect (cons fun args))) (display " BUT EXPECTED ") (write expect) (newline) #f) (else #t))) (if (procedure? fun) (apply fun args) (car args))))) (define (report-errs) (newline) (if (null? errs) (display "Passed all tests") (begin (display "errors were:") (newline) (display "(SECTION (got expected (call)))") (newline) (for-each (lambda (l) (write l) (newline)) errs))) (newline)) (SECTION 3 4) (define disjoint-type-functions (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) (define type-examples (list #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) (define i 1) (for-each (lambda (x) (display (make-string i #\ )) (set! i (+ 3 i)) (write x) (newline)) disjoint-type-functions) (define type-matrix (map (lambda (x) (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) (write t) (write x) (newline) t)) type-examples)) (SECTION 4 1 2) (test '(quote a) 'quote (quote 'a)) (test '(quote a) 'quote ''a) (SECTION 4 1 3) (test 12 (if #f + *) 3 4) (SECTION 4 1 4) (test 8 (lambda (x) (+ x x)) 4) (define reverse-subtract (lambda (x y) (- y x))) (test 3 reverse-subtract 7 10) (define add4 (let ((x 4)) (lambda (y) (+ x y)))) (test 10 add4 6) (test '(3 4 5 6) (lambda x x) 3 4 5 6) (test '(5 6) (lambda (x y . z) z) 3 4 5 6) (SECTION 4 1 5) (test 'yes 'if (if (> 3 2) 'yes 'no)) (test 'no 'if (if (> 2 3) 'yes 'no)) (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) (SECTION 4 1 6) (define x 2) (test 3 'define (+ x 1)) (set! x 4) (test 5 'set! (+ x 1)) (SECTION 4 2 1) (test 'greater 'cond (cond ((> 3 2) 'greater) ((< 3 2) 'less))) (test 'equal 'cond (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) (test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) (else #f))) (test 'composite 'case (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) (test 'consonant 'case (case (car '(c d)) ((a e i o u) 'vowel) ((w y) 'semivowel) (else 'consonant))) (test #t 'and (and (= 2 2) (> 2 1))) (test #f 'and (and (= 2 2) (< 2 1))) (test '(f g) 'and (and 1 2 'c '(f g))) (test #t 'and (and)) (test #t 'or (or (= 2 2) (> 2 1))) (test #t 'or (or (= 2 2) (< 2 1))) (test #f 'or (or #f #f #f)) (test #f 'or (or)) (test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) (SECTION 4 2 2) (test 6 'let (let ((x 2) (y 3)) (* x y))) (test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) (test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) (test #t 'letrec (letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) (even? 88))) (define x 34) (test 5 'let (let ((x 3)) (define x 5) x)) (test 34 'let x) (test 5 'let (let () (define x 5) x)) (test 34 'let x) (test 5 'let* (let* ((x 3)) (define x 5) x)) (test 34 'let* x) (test 5 'let* (let* () (define x 5) x)) (test 34 'let* x) (test 5 'letrec (letrec ((x 3)) (define x 5) x)) (test 34 'letrec x) (test 5 'letrec (letrec () (define x 5) x)) (test 34 'letrec x) (SECTION 4 2 3) (define x 0) (test 6 'begin (begin (set! x 5) (+ x 1))) (SECTION 4 2 4) (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))) (test 25 'do (let ((x '(1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum)))) (test 1 'let (let foo () 1)) (test '((6 1 3) (-5 -2)) 'let (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) (cond ((null? numbers) (list nonneg neg)) ((negative? (car numbers)) (loop (cdr numbers) nonneg (cons (car numbers) neg))) (else (loop (cdr numbers) (cons (car numbers) nonneg) neg))))) (SECTION 4 2 6) (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) (test '((foo 7) . cons) 'quasiquote `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) ;;; sqt is defined here because not all implementations are required to ;;; support it. (define (sqt x) (do ((i 0 (+ i 1))) ((> (* i i) x) (- i 1)))) (test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) (test 5 'quasiquote `,(+ 2 3)) (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) (test '(a `(b ,x ,'y d) e) 'quasiquote (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) (test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) (test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) (SECTION 5 2 1) (define add3 (lambda (x) (+ x 3))) (test 6 'define (add3 3)) (define first car) (test 1 'define (first '(1 2))) (SECTION 5 2 2) (test 45 'define (let ((x 5)) (define foo (lambda (y) (bar x y))) (define bar (lambda (a b) (+ (* a b) a))) (foo (+ x 3)))) (define x 34) (define (foo) (define x 5) x) (test 5 foo) (test 34 'define x) (define foo (lambda () (define x 5) x)) (test 5 foo) (test 34 'define x) (define (foo x) ((lambda () (define x 5) x)) x) (test 88 foo 88) (test 4 foo 4) (test 34 'define x) (SECTION 6 1) (test #f not #t) (test #f not 3) (test #f not (list 3)) (test #t not #f) (test #f not '()) (test #f not (list)) (test #f not 'nil) (test #t boolean? #f) (test #f boolean? 0) (test #f boolean? '()) (SECTION 6 2) (test #t eqv? 'a 'a) (test #f eqv? 'a 'b) (test #t eqv? 2 2) (test #t eqv? '() '()) (test #t eqv? '10000 '10000) (test #f eqv? (cons 1 2)(cons 1 2)) (test #f eqv? (lambda () 1) (lambda () 2)) (test #f eqv? #f 'nil) (let ((p (lambda (x) x))) (test #t eqv? p p)) (define gen-counter (lambda () (let ((n 0)) (lambda () (set! n (+ n 1)) n)))) (let ((g (gen-counter))) (test #t eqv? g g)) (test #f eqv? (gen-counter) (gen-counter)) (letrec ((f (lambda () (if (eqv? f g) 'f 'both))) (g (lambda () (if (eqv? f g) 'g 'both)))) (test #f eqv? f g)) (test #t eq? 'a 'a) (test #f eq? (list 'a) (list 'a)) (test #t eq? '() '()) (test #t eq? car car) (let ((x '(a))) (test #t eq? x x)) (let ((x '#())) (test #t eq? x x)) (let ((x (lambda (x) x))) (test #t eq? x x)) (test #t equal? 'a 'a) (test #t equal? '(a) '(a)) (test #t equal? '(a (b) c) '(a (b) c)) (test #t equal? "abc" "abc") (test #t equal? 2 2) (test #t equal? (make-vector 5 'a) (make-vector 5 'a)) (SECTION 6 3) (test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) (define x (list 'a 'b 'c)) (define y x) (and list? (test #t list? y)) (set-cdr! x 4) (test '(a . 4) 'set-cdr! x) (test #t eqv? x y) (test '(a b c . d) 'dot '(a . (b . (c . d)))) (and list? (test #f list? y)) (and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) (test #t pair? '(a . b)) (test #t pair? '(a . 1)) (test #t pair? '(a b c)) (test #f pair? '()) (test #f pair? '#(a b)) (test '(a) cons 'a '()) (test '((a) b c d) cons '(a) '(b c d)) (test '("a" b c) cons "a" '(b c)) (test '(a . 3) cons 'a 3) (test '((a b) . c) cons '(a b) 'c) (test 'a car '(a b c)) (test '(a) car '((a) b c d)) (test 1 car '(1 . 2)) (test '(b c d) cdr '((a) b c d)) (test 2 cdr '(1 . 2)) (test '(a 7 c) list 'a (+ 3 4) 'c) (test '() list) (test 3 length '(a b c)) (test 3 length '(a (b) (c d e))) (test 0 length '()) (test '(x y) append '(x) '(y)) (test '(a b c d) append '(a) '(b c d)) (test '(a (b) (c)) append '(a (b)) '((c))) (test '() append) (test '(a b c . d) append '(a b) '(c . d)) (test 'a append '() 'a) (test '(c b a) reverse '(a b c)) (test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) (test 'c list-ref '(a b c d) 2) (test '(a b c) memq 'a '(a b c)) (test '(b c) memq 'b '(a b c)) (test '#f memq 'a '(b c d)) (test '#f memq (list 'a) '(b (a) c)) (test '((a) c) member (list 'a) '(b (a) c)) (test '(101 102) memv 101 '(100 101 102)) (define e '((a 1) (b 2) (c 3))) (test '(a 1) assq 'a e) (test '(b 2) assq 'b e) (test #f assq 'd e) (test #f assq (list 'a) '(((a)) ((b)) ((c)))) (test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) (test '(5 7) assv 5 '((2 3) (5 7) (11 13))) (SECTION 6 4) (test #t symbol? 'foo) (test #t symbol? (car '(a b))) (test #f symbol? "bar") (test #t symbol? 'nil) (test #f symbol? '()) (test #f symbol? #f) ;;; But first, what case are symbols in? Determine the standard case: (define char-standard-case char-upcase) (if (string=? (symbol->string 'A) "a") (set! char-standard-case char-downcase)) (test #t 'standard-case (string=? (symbol->string 'a) (symbol->string 'A))) (test #t 'standard-case (or (string=? (symbol->string 'a) "A") (string=? (symbol->string 'A) "a"))) (define (str-copy s) (let ((v (make-string (string-length s)))) (do ((i (- (string-length v) 1) (- i 1))) ((< i 0) v) (string-set! v i (string-ref s i))))) (define (string-standard-case s) (set! s (str-copy s)) (do ((i 0 (+ 1 i)) (sl (string-length s))) ((>= i sl) s) (string-set! s i (char-standard-case (string-ref s i))))) (test (string-standard-case "flying-fish") symbol->string 'flying-fish) (test (string-standard-case "martin") symbol->string 'Martin) (test "Malvina" symbol->string (string->symbol "Malvina")) (test #t 'standard-case (eq? 'a 'A)) (define x (string #\a #\b)) (define y (string->symbol x)) (string-set! x 0 #\c) (test "cb" 'string-set! x) (test "ab" symbol->string y) (test y string->symbol "ab") (test #t eq? 'mISSISSIppi 'mississippi) (test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) (test 'JollyWog string->symbol (symbol->string 'JollyWog)) (SECTION 6 5 5) (test #t number? 3) (test #t complex? 3) (test #t real? 3) (test #t rational? 3) (test #t integer? 3) (test #t exact? 3) (test #f inexact? 3) (test #t = 22 22 22) (test #t = 22 22) (test #f = 34 34 35) (test #f = 34 35) (test #t > 3 -6246) (test #f > 9 9 -2424) (test #t >= 3 -4 -6246) (test #t >= 9 9) (test #f >= 8 9) (test #t < -1 2 3 4 5 6 7 8) (test #f < -1 2 3 4 4 5 6 7) (test #t <= -1 2 3 4 5 6 7 8) (test #t <= -1 2 3 4 4 5 6 7) (test #t zero? 0) (test #f zero? 1) (test #f zero? -1) (test #f zero? -100) (test #t positive? 4) (test #f positive? -4) (test #f positive? 0) (test #f negative? 4) (test #t negative? -4) (test #f negative? 0) (test #t odd? 3) (test #f odd? 2) (test #f odd? -4) (test #t odd? -1) (test #f even? 3) (test #t even? 2) (test #t even? -4) (test #f even? -1) (test 38 max 34 5 7 38 6) (test -24 min 3 5 5 330 4 -24) (test 7 + 3 4) (test '3 + 3) (test 0 +) (test 4 * 4) (test 1 *) (test -1 - 3 4) (test -3 - 3) (test 7 abs -7) (test 7 abs 7) (test 0 abs 0) (test 5 quotient 35 7) (test -5 quotient -35 7) (test -5 quotient 35 -7) (test 5 quotient -35 -7) (test 1 modulo 13 4) (test 1 remainder 13 4) (test 3 modulo -13 4) (test -1 remainder -13 4) (test -3 modulo 13 -4) (test 1 remainder 13 -4) (test -1 modulo -13 -4) (test -1 remainder -13 -4) (define (divtest n1 n2) (= n1 (+ (* n2 (quotient n1 n2)) (remainder n1 n2)))) (test #t divtest 238 9) (test #t divtest -238 9) (test #t divtest 238 -9) (test #t divtest -238 -9) (test 4 gcd 0 4) (test 4 gcd -4 0) (test 4 gcd 32 -36) (test 0 gcd) (test 288 lcm 32 -36) (test 1 lcm) ;;;;From: fred@sce.carleton.ca (Fred J Kaudel) ;;; Modified by jaffer. (define (test-inexact) (define f3.9 (string->number "3.9")) (define f4.0 (string->number "4.0")) (define f-3.25 (string->number "-3.25")) (define f.25 (string->number ".25")) (newline) (display ";testing inexact numbers; ") (SECTION 6 5 5) (test #t inexact? f3.9) (test #t 'inexact? (inexact? (max f3.9 4))) (test f4.0 'max (max f3.9 4)) (test f4.0 'exact->inexact (exact->inexact 4)) (test 4 'inexact->exact (inexact->exact f3.9)) (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) (test #t call-with-output-file "tmp3" (lambda (test-file) (write-char #\; test-file) (display write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (output-port? test-file))) (check-test-file "tmp3") (report-errs)) (SECTION 6 5 6) (test "0" number->string 0) (test "100" number->string 100) (test "100" number->string 256 16) (test 100 string->number "100") (test 256 string->number "100" 16) (SECTION 6 6) (test #t eq? '#\ #\Space) (test #t eq? #\space '#\Space) (test #t char? #\a) (test #t char? #\() (test #t char? #\ ) (test #t char? '#\newline) (test #f char=? #\A #\B) (test #f char=? #\a #\b) (test #f char=? #\9 #\0) (test #t char=? #\A #\A) (test #t char? #\A #\B) (test #f char>? #\a #\b) (test #t char>? #\9 #\0) (test #f char>? #\A #\A) (test #t char<=? #\A #\B) (test #t char<=? #\a #\b) (test #f char<=? #\9 #\0) (test #t char<=? #\A #\A) (test #f char>=? #\A #\B) (test #f char>=? #\a #\b) (test #t char>=? #\9 #\0) (test #t char>=? #\A #\A) (test #f char-ci=? #\A #\B) (test #f char-ci=? #\a #\B) (test #f char-ci=? #\A #\b) (test #f char-ci=? #\a #\b) (test #f char-ci=? #\9 #\0) (test #t char-ci=? #\A #\A) (test #t char-ci=? #\A #\a) (test #t char-ci? #\A #\B) (test #f char-ci>? #\a #\B) (test #f char-ci>? #\A #\b) (test #f char-ci>? #\a #\b) (test #t char-ci>? #\9 #\0) (test #f char-ci>? #\A #\A) (test #f char-ci>? #\A #\a) (test #t char-ci<=? #\A #\B) (test #t char-ci<=? #\a #\B) (test #t char-ci<=? #\A #\b) (test #t char-ci<=? #\a #\b) (test #f char-ci<=? #\9 #\0) (test #t char-ci<=? #\A #\A) (test #t char-ci<=? #\A #\a) (test #f char-ci>=? #\A #\B) (test #f char-ci>=? #\a #\B) (test #f char-ci>=? #\A #\b) (test #f char-ci>=? #\a #\b) (test #t char-ci>=? #\9 #\0) (test #t char-ci>=? #\A #\A) (test #t char-ci>=? #\A #\a) (test #t char-alphabetic? #\a) (test #t char-alphabetic? #\A) (test #t char-alphabetic? #\z) (test #t char-alphabetic? #\Z) (test #f char-alphabetic? #\0) (test #f char-alphabetic? #\9) (test #f char-alphabetic? #\space) (test #f char-alphabetic? #\;) (test #f char-numeric? #\a) (test #f char-numeric? #\A) (test #f char-numeric? #\z) (test #f char-numeric? #\Z) (test #t char-numeric? #\0) (test #t char-numeric? #\9) (test #f char-numeric? #\space) (test #f char-numeric? #\;) (test #f char-whitespace? #\a) (test #f char-whitespace? #\A) (test #f char-whitespace? #\z) (test #f char-whitespace? #\Z) (test #f char-whitespace? #\0) (test #f char-whitespace? #\9) (test #t char-whitespace? #\space) (test #f char-whitespace? #\;) (test #f char-upper-case? #\0) (test #f char-upper-case? #\9) (test #f char-upper-case? #\space) (test #f char-upper-case? #\;) (test #f char-lower-case? #\0) (test #f char-lower-case? #\9) (test #f char-lower-case? #\space) (test #f char-lower-case? #\;) (test 9 char->integer (integer->char 9)) (test #\A char-upcase #\A) (test #\A char-upcase #\a) (test #\a char-downcase #\A) (test #\a char-downcase #\a) (SECTION 6 7) (test #t string? "The word \"recursion\\\" has many meanings.") (test #t string? "") (define f (make-string 3 #\*)) (test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) (test "abc" string #\a #\b #\c) (test "" string) (test 3 string-length "abc") (test #\a string-ref "abc" 0) (test #\c string-ref "abc" 2) (test 0 string-length "") (test "" substring "ab" 0 0) (test "" substring "ab" 1 1) (test "" substring "ab" 2 2) (test "a" substring "ab" 0 1) (test "b" substring "ab" 1 2) (test "ab" substring "ab" 0 2) (test "foobar" string-append "foo" "bar") (test "foo" string-append "foo") (test "foo" string-append "foo" "") (test "foo" string-append "" "foo") (test "" string-append) (test "" make-string 0) (test #t string=? "" "") (test #f string? "" "") (test #t string<=? "" "") (test #t string>=? "" "") (test #t string-ci=? "" "") (test #f string-ci? "" "") (test #t string-ci<=? "" "") (test #t string-ci>=? "" "") (test #f string=? "A" "B") (test #f string=? "a" "b") (test #f string=? "9" "0") (test #t string=? "A" "A") (test #t string? "A" "B") (test #f string>? "a" "b") (test #t string>? "9" "0") (test #f string>? "A" "A") (test #t string<=? "A" "B") (test #t string<=? "a" "b") (test #f string<=? "9" "0") (test #t string<=? "A" "A") (test #f string>=? "A" "B") (test #f string>=? "a" "b") (test #t string>=? "9" "0") (test #t string>=? "A" "A") (test #f string-ci=? "A" "B") (test #f string-ci=? "a" "B") (test #f string-ci=? "A" "b") (test #f string-ci=? "a" "b") (test #f string-ci=? "9" "0") (test #t string-ci=? "A" "A") (test #t string-ci=? "A" "a") (test #t string-ci? "A" "B") (test #f string-ci>? "a" "B") (test #f string-ci>? "A" "b") (test #f string-ci>? "a" "b") (test #t string-ci>? "9" "0") (test #f string-ci>? "A" "A") (test #f string-ci>? "A" "a") (test #t string-ci<=? "A" "B") (test #t string-ci<=? "a" "B") (test #t string-ci<=? "A" "b") (test #t string-ci<=? "a" "b") (test #f string-ci<=? "9" "0") (test #t string-ci<=? "A" "A") (test #t string-ci<=? "A" "a") (test #f string-ci>=? "A" "B") (test #f string-ci>=? "a" "B") (test #f string-ci>=? "A" "b") (test #f string-ci>=? "a" "b") (test #t string-ci>=? "9" "0") (test #t string-ci>=? "A" "A") (test #t string-ci>=? "A" "a") (SECTION 6 8) (test #t vector? '#(0 (2 2 2 2) "Anna")) (test '#(a b c) vector 'a 'b 'c) (test 3 vector-length '#(0 (2 2 2 2) "Anna")) (test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) (test '#(0 ("Sue" "Sue") "Anna") 'vector-set (let ((vec (vector 0 '(2 2 2 2) "Anna"))) (vector-set! vec 1 '("Sue" "Sue")) vec)) (SECTION 6 9) (test #t procedure? car) (test #f procedure? 'car) (test #t procedure? (lambda (x) (* x x))) (test #f procedure? '(lambda (x) (* x x))) (test #t call-with-current-continuation procedure?) (test 7 apply + (list 3 4)) (test 17 apply + 10 (list 3 4)) (test '() apply list '()) (define compose (lambda (f g) (lambda args (f (apply g args))))) (test 30 (compose sqt *) 12 75) (test '(b e h) map cadr '((a b) (d e) (g h))) (test '(5 7 9) map + '(1 2 3) '(4 5 6)) (test '#(0 1 4 9 16) 'for-each (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v)) (test -3 call-with-current-continuation (lambda (exit) (for-each (lambda (x) (if (negative? x) (exit x))) '(54 0 37 -3 245 19)) #t)) (define list-length (lambda (obj) (call-with-current-continuation (lambda (return) (letrec ((r (lambda (obj) (cond ((null? obj) 0) ((pair? obj) (+ (r (cdr obj)) 1)) (else (return #f)))))) (r obj)))))) (test 4 list-length '(1 2 3 4)) (test #f list-length '(a b . c)) (test '() map cadr '()) ;;; This tests full conformance of call-with-current-continuation. It ;;; is a separate test because some schemes do not support call/cc ;;; other than escape procedures. I am indebted to ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this ;;; code. The function leaf-eq? compares the leaves of 2 arbitrary ;;; trees constructed of conses. (define (next-leaf-generator obj eot) (letrec ((return #f) (cont (lambda (x) (recur obj) (set! cont (lambda (x) (return eot))) (cont #f))) (recur (lambda (obj) (if (pair? obj) (for-each recur obj) (call-with-current-continuation (lambda (c) (set! cont c) (return obj))))))) (lambda () (call-with-current-continuation (lambda (ret) (set! return ret) (cont #f)))))) (define (leaf-eq? x y) (let* ((eot (list 'eot)) (xf (next-leaf-generator x eot)) (yf (next-leaf-generator y eot))) (letrec ((loop (lambda (x y) (cond ((not (eq? x y)) #f) ((eq? eot x) #t) (else (loop (xf) (yf))))))) (loop (xf) (yf))))) (define (test-cont) (newline) (display ";testing continuations; ") (SECTION 6 9) (test #t leaf-eq? '(a (b (c))) '((a) b c)) (test #f leaf-eq? '(a (b (c))) '((a) b c d)) (report-errs)) (SECTION 6 10 1) (test #t input-port? (current-input-port)) (test #f input-port? (current-output-port)) (test #f output-port? (current-input-port)) (test #t output-port? (current-output-port)) (test #t call-with-input-file "test.scm" input-port?) (define this-file (open-input-file "test.scm")) (test #t input-port? this-file) (SECTION 6 10 2) (test #\; peek-char this-file) (test #\; read-char this-file) (test '(define cur-section '()) read this-file) (test #\( peek-char this-file) (test '(define errs '()) read this-file) (close-input-port this-file) (close-input-port this-file) (define (check-test-file name) (define test-file (open-input-file name)) (test #t 'input-port? (call-with-input-file name (lambda (test-file) (test load-test-obj read test-file) (test #t eof-object? (peek-char test-file)) (test #t eof-object? (read-char test-file)) (input-port? test-file)))) (test #\; read-char test-file) (test display-test-obj read test-file) (test load-test-obj read test-file) (close-input-port test-file)) (SECTION 6 10 3) (define write-test-obj '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) (define display-test-obj '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) (define load-test-obj (list 'define 'foo (list 'quote write-test-obj))) (test #t call-with-output-file "tmp1" (lambda (test-file) (write-char #\; test-file) (display write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (output-port? test-file))) (check-test-file "tmp1") (define test-file (open-output-file "tmp2")) (write-char #\; test-file) (display write-test-obj test-file) (newline test-file) (write load-test-obj test-file) (test #t output-port? test-file) (close-output-port test-file) (check-test-file "tmp2") (define (test-sc4) (newline) (display ";testing scheme 4 functions; ") (SECTION 6 7) (test '(#\P #\space #\l) string->list "P l") (test '() string->list "") (test "1\\\"" list->string '(#\1 #\\ #\")) (test "" list->string '()) (SECTION 6 8) (test '(dah dah didah) vector->list '#(dah dah didah)) (test '() vector->list '#()) (test '#(dididit dah) list->vector '(dididit dah)) (test '#() list->vector '()) (SECTION 6 10 4) (load "tmp1") (test write-test-obj 'load foo) (report-errs)) (report-errs) (display "To fully test continuations do `(test-cont)'; Scheme 4 `(test-sc4)'") (newline) (display "To partly test inexact numbers do `(test-inexact)'") (newline) "last item in file" @EOF chmod 644 test.scm echo x - example.scm cat >example.scm <<'@EOF' ;From Revised^4 Report on the Algorithmic Language Scheme ;William Clinger and Jonathon Rees (Editors) ; EXAMPLE ;INTEGRATE-SYSTEM integrates the system ; y_k' = f_k(y_1, y_2, ..., y_n), k = 1, ..., n ;of differential equations with the method of Runge-Kutta. ;The parameter SYSTEM-DERIVATIVE is a function that takes a system ;state (a vector of values for the state variables y_1, ..., y_n) and ;produces a system derivative (the values y_1', ..., y_n'). The ;parameter INITIAL-STATE provides an initial system state, and H is an ;initial guess for the length of the integration step. ;The value returned by INTEGRATE-SYSTEM is an infinite stream of ;system states. (define integrate-system (lambda (system-derivative initial-state h) (let ((next (runge-kutta-4 system-derivative h))) (letrec ((states (cons initial-state (delay (map-streams next states))))) states)))) ;RUNGE-KUTTA-4 takes a function, F, that produces a ;system derivative from a system state. RUNGE-KUTTA-4 ;produces a function that takes a system state and ;produces a new system state. (define runge-kutta-4 (lambda (f h) (let ((*h (scale-vector h)) (*2 (scale-vector 2)) (*1/2 (scale-vector (/ 1 2))) (*1/6 (scale-vector (/ 1 6)))) (lambda (y) ;; Y is a system state (let* ((k0 (*h (f y))) (k1 (*h (f (add-vectors y (*1/2 k0))))) (k2 (*h (f (add-vectors y (*1/2 k1))))) (k3 (*h (f (add-vectors y k2))))) (add-vectors y (*1/6 (add-vectors k0 (*2 k1) (*2 k2) k3)))))))) (define elementwise (lambda (f) (lambda vectors (generate-vector (vector-length (car vectors)) (lambda (i) (apply f (map (lambda (v) (vector-ref v i)) vectors))))))) (define generate-vector (lambda (size proc) (let ((ans (make-vector size))) (letrec ((loop (lambda (i) (cond ((= i size) ans) (else (vector-set! ans i (proc i)) (loop (+ i 1))))))) (loop 0))))) (define add-vectors (elementwise +)) (define scale-vector (lambda (s) (elementwise (lambda (x) (* x s))))) ;MAP-STREAMS is analogous to MAP: it applies its first ;argument (a procedure) to all the elements of its second argument (a ;stream). (define map-streams (lambda (f s) (cons (f (head s)) (delay (map-streams f (tail s)))))) ;Infinite streams are implemented as pairs whose car holds the first ;element of the stream and whose cdr holds a promise to deliver the rest ;of the stream. (define head car) (define tail (lambda (stream) (force (cdr stream)))) ;The following illustrates the use of INTEGRATE-SYSTEM in ;integrating the system ; ; dvC vC ; C --- = -i - -- ; dt L R ; ; diL ; L --- = v ; dt C ; ;which models a damped oscillator. (define damped-oscillator (lambda (R L C) (lambda (state) (let ((Vc (vector-ref state 0)) (Il (vector-ref state 1))) (vector (- 0 (+ (/ Vc (* R C)) (/ Il C))) (/ Vc L)))))) (define the-states (integrate-system (damped-oscillator 10000 1000 .001) '#(1 0) .01)) (do ((i 10 (- i 1)) (s the-states (tail s))) ((zero? i) (newline)) (newline) (write (head s))) ; #(1 0) ; #(0.99895054 9.994835e-6) ; #(0.99780226 1.9978681e-5) ; #(0.9965554 2.9950552e-5) ; #(0.9952102 3.990946e-5) ; #(0.99376684 4.985443e-5) ; #(0.99222565 5.9784474e-5) ; #(0.9905868 6.969862e-5) ; #(0.9888506 7.9595884e-5) ; #(0.9870173 8.94753e-5) @EOF chmod 666 example.scm echo x - pi.scm cat >pi.scm <<'@EOF' ;;;; "pi.scm", program for computing digits of numerical value of PI. ;;; Copyright (C) 1991 Aubrey Jaffer. ;;; See the file `COPYING' for terms applying to this program. ;;; (pi ) prints out digits of pi in groups of digits. ;;; 'Spigot' algorithm origionally due to Stanly Rabinowitz. ;;; This algorithm takes time proportional to the square of /. ;;; This fact can make comparisons of computational speed between systems ;;; of vastly differring performances quicker and more accurate. ;;; Try (pi 100 5) ;;; The digit size will have to be reduced for larger or an ;;; overflow error will occur. (define (pi n d) (let* ((r (do ((s 1 (* 10 s)) (i 0 (+ 1 i))) ((>= i d) s))) (n (+ (quotient n d) 1)) (m (quotient (* n d 3322) 1000)) (a (make-vector (+ 1 m) 2))) (vector-set! a m 4) (do ((j 1 (+ 1 j)) (q 0 0) (b 2 (remainder q r))) ((> j n)) (do ((k m (- k 1))) ((zero? k)) (set! q (+ q (* (vector-ref a k) r))) (let ((t (+ 1 (* 2 k)))) (vector-set! a k (remainder q t)) (set! q (* k (quotient q t))))) (let ((s (number->string (+ b (quotient q r))))) (do ((l (string-length s) (+ 1 l))) ((>= l d) (display s)) (display #\0))) (display (if (zero? (modulo j 10)) #\newline #\ ))) (newline))) @EOF chmod 666 pi.scm echo x - pi.c cat >pi.c <<'@EOF' /* "pi.c", program for computing digits of numerical value of PI. Copyright (C) 1991 Aubrey Jaffer. See the file "COPYING" for terms applying to this program. (pi ) prints out digits of pi in groups of digits. 'Spigot' algorithm origionally due to Stanly Rabinowitz. This algorithm takes time proportional to the square of /. This fact can make comparisons of computational speed between systems of vastly differring performances quicker and more accurate. Try (pi 100 5) The digit size will have to be reduced for larger or an overflow error will occur. */ short *calloc(); main(c,v) int c;char **v;{ int n=200,j=0,m,b=2,k=0,t,r=1,d=5; long q; short *a; if(c>1)n=atoi(v[1]); if(c>2)d=atoi(v[2]); while(k++makefile.unix <<'@EOF' # Makefile for SCM (Scheme implementation intended for JACAL). # Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. # See the file "COPYING" for terms applying to this program # directory where COPYING and Init.scm reside. #IMPLPATH=/usr/src/local/scm/ #this one is good while debugging IMPLPATH=`pwd`/ # Pathname where Init.scm resides. This directory must also contain COPYING. IMPLINIT=$(IMPLPATH)Init.scm # If pathname where Init.scm resides is not known in advance then # SCM_INIT_PATH is the environment variable whose value is the # pathname where Init.scm resides. # IMPLINIT= # directory where `make install' will put executable. DEST=/usr/local/ # directory where `make install' will put manual page. MANDEST=/usr/man/man1/ #CC = your compiler # -DRTL if this is a run-time library only (no interactive top level) # -Dunix is required for SCO # -DRECKLESS if you want most scm error checking disabled. # -O if you want the optimizing C compiler to be used. CFLAGS = -O # append any names of user extension files # -lm for -DFLOATS LIBS = -lm # for BSD nm format SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//' # for Sys5 nm format #SED_TO_STRIP_NM=sed -e '/.*\.o/d' -e 's/.* _//' #you should not need to change below this line. DFLAG = -DIMPLINIT=\"$(IMPLINIT)\" ffiles = time.o frepl.o fscl.o fsys.o feval.o subr.o sc2.o efiles = time.o erepl.o escl.o esys.o eeval.o subr.o sc2.o cfiles = scm.c time.c repl.c scl.c sys.c eval.c subr.c sc2.c hfiles = scm.h config.h patchlvl.h tfiles = Init.scm test.scm example.scm pi.scm pi.c dfiles = README COPYING scm.1 scm.doc MANUAL ChangeLog code.doc ANNOUNCE mfiles = makefile.unix makefile.msc makefile.bor makefile.tur\ makefile.djg makefile.qc compile.amiga link.amiga makefile.aztec\ makefile.ast vfiles = setjump.mar setjump.h VMSBUILD.COM VMSGCC.COM afiles = $(dfiles) $(cfiles) $(hfiles) $(tfiles) $(mfiles) $(vfiles) scheme: scm # -DINITS= the initialization calls for user extension files. dbscm: $(efiles) ../db/db.a scm.c scm.h config.h patchlvl.h $(CC) -o dbscm $(efiles) $(CFLAGS) -DINITS=init_db\(\) scm.c ../db/db.a scm: $(ffiles) fscm.o $(CC) -o scm $(ffiles) fscm.o $(LIBS) fscm.o: scm.c scm.h config.h patchlvl.h $(CC) $(CFLAGS) -c -DFLOATS -DINITS= scm.c mv scm.o fscm.o frepl.o: repl.c scm.h config.h $(CC) $(CFLAGS) -c -DFLOATS $(DFLAG) repl.c mv repl.o frepl.o fsys.o: sys.c scm.h config.h $(CC) $(CFLAGS) -c -DFLOATS sys.c mv sys.o fsys.o fscl.o: scl.c scm.h $(CC) $(CFLAGS) -c -DFLOATS scl.c mv scl.o fscl.o feval.o: eval.c scm.h $(CC) $(CFLAGS) -c -DFLOATS eval.c mv eval.o feval.o escm: $(efiles) escm.o $(CC) -o escm $(efiles) escm.o escm.o: scm.c scm.h config.h patchlvl.h $(CC) $(CFLAGS) -c -DINITS= scm.c mv scm.o escm.o erepl.o: repl.c scm.h config.h $(CC) $(CFLAGS) -c $(DFLAG) repl.c mv repl.o erepl.o esys.o: sys.c scm.h config.h $(CC) $(CFLAGS) -c sys.c mv sys.o esys.o escl.o: scl.c scm.h $(CC) $(CFLAGS) -c scl.c mv scl.o escl.o eeval.o: eval.c scm.h $(CC) $(CFLAGS) -c eval.c mv eval.o eeval.o time.o: time.c scm.h config.h $(CC) $(CFLAGS) -c time.c subr.o: subr.c scm.h $(CC) $(CFLAGS) -c subr.c sc2.o: sc2.c scm.h $(CC) $(CFLAGS) -c sc2.c both: scm escm libscm.a: rtlscm.o $(ffiles) rm -f libscm.a ar rc libscm.a rtlscm.o $(ffiles) ranlib libscm.a rtlscm.o: scm.c scm.h config.h patchlvl.h $(CC) $(CFLAGS) -c -DFLOATS -DRTL -DINITS=init_user_scm\(\) scm.c mv scm.o rtlscm.o scm.doc: scm.1 nroff -man scm.1 >scm.doc install: scm cp scm $(DEST) strip $(DEST)scm cp scm.1 $(MANDEST) shar: scm.shar scm.shar: $(afiles) shar $(afiles) >scm.shar tar: scm.tar scm.tar: $(afiles) tar -cf scm.tar $(afiles) tar.Z: scm.tar.Z scm.tar.Z: scm.tar compress scm.tar shar.Z: scm.shar.Z scm.shar.Z: scm.shar compress scm.shar lint: lints lints: $(cfiles) $(hfiles) lint $(CFLAGS) -DFLOATS $(cfiles) | tee lints # lint $(CFLAGS) $(cfiles) | tee lintes name8: name8s name8s: scm nm scm |\ $(SED_TO_STRIP_NM) |\ sort -u|\ awk '{ if (substr(l,1,8)==substr($$1,1,8)) {\ if (p) print l;\ print $$1;p=0;stat=1\ }else p=1;\ l=$$1\ }END{exit stat}' - tags: $(hfiles) $(cfiles) Init.scm MANUAL code.doc $(mfiles) README etags $(hfiles) $(cfiles) Init.scm MANUAL code.doc $(mfiles) README clean: -rm -f *~ \#* *\# *.orig *.rej a.out core lints tmp* realclean: -rm -f *~ \#* *.o *\# *.orig *.rej a.out core TAGS lints tmp* @EOF chmod 666 makefile.unix echo x - makefile.msc cat >makefile.msc <<'@EOF' # Makefile for SCM for Microsoft C 5.10 and 6.00A # Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. # See the file "COPYING" for terms applying to this program # SCM does run when compiled under Microsoft C 6.00 (no A) due to bugs # in the compiler. # Pathname where Init.scm resides. This directory must also contain COPYING. IMPLINIT=a:\\scm\\Init.scm # If pathname where Init.scm resides is not known in advance then # SCM_INIT_PATH is the environment variable whose value is the # pathname where Init.scm resides. #IMPLINIT= # -AL large model (almost works) # -AH huge model MEM = -AH # -c compile to .obj file # -Zi codeview symbols # -Oxp maximum optimizations (except floating point) # -Od no optimizations # -G2 for 80286 code # -qc for quick C # -DFLOATS if you want floating point numbers # -DRTL if this is a run-time library only (no interactive top level) # -DRECKLESS if you want most scm error checking disabled. # For normal compile: CFLAGS = -c -Oxp -DFLOATS LFLAGS = /noe /ST:40000 # For Debugging: #CFLAGS = -c -Zi -Od -DFLOATS #LFLAGS = /co /noe /ST:40000 /codeview # -DINITS= the initialization calls for user extension files. CC = cl scm.exe: scm.obj time.obj repl.obj scl.obj sys.obj eval.obj\ subr.obj sc2.obj link $(LFLAGS) scm+time+repl+scl+sys+eval+subr+sc2; scm.obj: scm.c scm.h config.h patchlvl.h $(CC) $(CFLAGS) $(MEM) -DINITS=$(INITS) scm.c repl.obj: repl.c scm.h config.h $(CC) $(CFLAGS) $(MEM) -DIMPLINIT=\"$(IMPLINIT)\" repl.c sys.obj: sys.c scm.h config.h $(CC) $(CFLAGS) $(MEM) sys.c eval.obj: eval.c scm.h $(CC) $(CFLAGS) $(MEM) eval.c time.obj: time.c scm.h $(CC) $(CFLAGS) $(MEM) time.c subr.obj: subr.c scm.h $(CC) $(CFLAGS) $(MEM) subr.c scl.obj: scl.c scm.h $(CC) $(CFLAGS) $(MEM) scl.c sc2.obj: sc2.c scm.h $(CC) $(CFLAGS) $(MEM) sc2.c @EOF chmod 666 makefile.msc echo x - makefile.bor sed 's/^@//' >makefile.bor <<'@EOF' # Makefile for SCM (Scheme implementation intended for JACAL) for Borland C. # Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. # See the file "COPYING" for terms applying to this program # Pathname where Init.scm resides. This directory must also contain COPYING. IMPLINIT=a:\\\scm\\\Init.scm # If pathname where Init.scm resides is not known in advance then # SCM_INIT_PATH is the environment variable whose value is the # pathname where Init.scm resides. # IMPLINIT= # Use large memory model MEM = -ml # -f- no floating point # -c compile to .obj file # -d merge duplicate strings # -O jump optimization # -Z register optimization # -G optimize for speed # -DFLOATS if you want floating point numbers # -DRTL if this is a run-time library only (no interactive top level) # -DRECKLESS if you want most scm error checking disabled. # For integer only: #CFLAGS = -c -d -f- -O -Z -G #LFLAGS = # For normal compile: CFLAGS = -c -d -O -Z -G -DFLOATS LFLAGS = # For Debugging: #CFLAGS = -c -f- -O -N -v -y #LFLAGS = -M -v # -DINITS= the initialization calls for user extension files. INITS= CC = bcc @.c.obj: $(CC) $(CFLAGS) $(MEM) {$< } # if that doesn't work try: # $(CC) $(CFLAGS) $(MEM) $< scm.exe: scm.obj time.obj repl.obj scl.obj sys.obj eval.obj \ subr.obj sc2.obj $(CC) $(LFLAGS) $(MEM) scm.obj time.obj repl.obj scl.obj \ sys.obj eval.obj subr.obj sc2.obj sys.obj: sys.c scm.h config.h eval.obj: eval.c scm.h config.h subr.obj: subr.c scm.h config.h time.obj: time.c scm.h config.h repl.obj: repl.c scm.h config.h $(CC) $(CFLAGS) $(MEM) -DIMPLINIT="$(IMPLINIT)" repl.c scm.obj: scm.c scm.h patchlvl.h config.h $(CC) $(CFLAGS) $(MEM) -DINITS=$(INITS) scm.c scl.obj: scl.c scm.h config.h sc2.obj: sc2.c scm.h config.h @EOF chmod 666 makefile.bor echo x - makefile.tur sed 's/^@//' >makefile.tur <<'@EOF' # Makefile for SCM (Scheme implementation intended for JACAL) for TURBO C. # Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. # See the file "COPYING" for terms applying to this program # Pathname where Init.scm resides. This directory must also contain COPYING. IMPLINIT=a:\\\scm\\\Init.scm # If pathname where Init.scm resides is not known in advance then # SCM_INIT_PATH is the environment variable whose value is the # pathname where Init.scm resides. # IMPLINIT= TINCLUDE=c:\turboc\include TLIB=c:\turboc\lib # Use large memory model MEM = -ml # -f- no floating point # -c compile to .obj file # -d merge duplicate strings # -O jump optimization # -Z register optimization # -G optimize for speed # -DFLOATS if you want floating point numbers # -DRTL if this is a run-time library only (no interactive top level) # -DRECKLESS if you want most scm error checking disabled. # For integer only: #CFLAGS = -c -d -f- -O -Z -G -I$(TINCLUDE) -L$(TLIB) #LFLAGS = # For normal compile: CFLAGS = -c -d -O -Z -G -I$(TINCLUDE) -L$(TLIB) -DFLOATS LFLAGS = # For Debugging: #CFLAGS = -c -f- -O -N -v -y #LFLAGS = -M -v # -DINITS= the initialization calls for user extension files. INITS= CC = tcc @.c.obj: # $(CC) $(CFLAGS) $(MEM) {$< } # if that doesn't work try: $(CC) $(CFLAGS) $(MEM) $< scm.exe: scm.obj time.obj repl.obj scl.obj sys.obj eval.obj \ subr.obj sc2.obj $(CC) $(LFLAGS) $(MEM) -L$(TLIB) scm.obj time.obj repl.obj \ scl.obj sys.obj eval.obj subr.obj sc2.obj sys.obj: sys.c scm.h config.h eval.obj: eval.c scm.h config.h time.obj: time.c scm.h config.h subr.obj: subr.c scm.h config.h repl.obj: repl.c scm.h config.h $(CC) $(CFLAGS) $(MEM) -DIMPLINIT="$(IMPLINIT)" repl.c scm.obj: scm.c scm.h patchlvl.h config.h $(CC) $(CFLAGS) $(MEM) -DINITS=$(INITS) scm.c scl.obj: scl.c scm.h config.h sc2.obj: sc2.c scm.h config.h @EOF chmod 666 makefile.tur echo x - makefile.djg cat >makefile.djg <<'@EOF' # Makefile for SCM for DJGPP (Gnu CC port to MSDOS with i386). # Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. # See the file "COPYING" for terms applying to this program # Pathname where Init.scm resides. This directory must also contain COPYING. IMPLINIT=a:\\\scm\\\Init.scm # If pathname where Init.scm resides is not known in advance then # SCM_INIT_PATH is the environment variable whose value is the # pathname where Init.scm resides. # IMPLINIT= CC = gcc # -DRTL if this is a run-time library only (no interactive top level) # -DRECKLESS if you want most scm error checking disabled. # -O if you want the optimizing C compiler to be used. CFLAGS = -O # append any names of user extension files # -lm for -DFLOATS LIBS = -lm # -DINITS= the initialization calls for user extension files. INITS= #you should not need to change below this line. DFLAG = -DIMPLINIT=\"$(IMPLINIT)\" ffiles = time.o repl.o scl.o sys.o eval.o subr.o sc2.o scm.exe: scm strip scm copy /b c:\gcc\bin\stub.exe+scm scm.exe scm: $(ffiles) scm.o $(CC) -o scm $(ffiles) scm.o $(LIBS) scm.o: scm.c scm.h config.h patchlvl.h $(CC) $(CFLAGS) -c -DFLOATS -DINITS=$(INITS) scm.c sys.o: sys.c scm.h config.h $(CC) $(CFLAGS) -c -DFLOATS sys.c # $(CFLAGS) removed because of GCC brain damage with n /= xpo; scl.o: scl.c scm.h $(CC) -c -DFLOATS scl.c eval.o: eval.c scm.h $(CC) $(CFLAGS) -c -DFLOATS eval.c repl.o: repl.c scm.h config.h $(CC) $(CFLAGS) -c -DFLOATS $(DFLAG) repl.c subr.o: subr.c scm.h $(CC) $(CFLAGS) -c subr.c time.o: time.c scm.h $(CC) $(CFLAGS) -c time.c sc2.o: sc2.c scm.h $(CC) $(CFLAGS) -c sc2.c @EOF chmod 666 makefile.djg echo x - makefile.qc cat >makefile.qc <<'@EOF' #makefile.qc from Craig Lawson. PROJ =SCM DEBUG =0 CC =qcl CFLAGS_G = /AL /W1 /Ze CFLAGS_D = /Zi /Zr /Od CFLAGS_R = /O /Ot /DNDEBUG CFLAGS =$(CFLAGS_G) $(CFLAGS_R) LFLAGS_G = /CP:0xffff /NOI /SE:0x80 /ST:0x9c40 LFLAGS_D = /CO LFLAGS_R = LFLAGS =$(LFLAGS_G) $(LFLAGS_R) RUNFLAGS =cc OBJS_EXT = LIBS_EXT = all: $(PROJ).exe sys.obj: sys.c scm.h config.h time.obj: time.c scm.h config.h eval.obj: eval.c scm.h config.h subr.obj: subr.c scm.h config.h scm.obj: scm.c scm.h config.h repl.obj: repl.c scm.h config.h scl.obj: scl.c scm.h config.h sc2.obj: sc2.c scm.h config.h $(PROJ).exe: sys.obj eval.obj subr.obj scm.obj repl.obj scl.obj \ sc2.obj $(OBJS_EXT) echo >NUL @<<$(PROJ).crf sys.obj + eval.obj + subr.obj + scm.obj + repl.obj + scl.obj + sc2.obj + $(OBJS_EXT) $(PROJ).exe $(LIBS_EXT); << link $(LFLAGS) @$(PROJ).crf run: $(PROJ).exe $(PROJ) $(RUNFLAGS) @EOF chmod 666 makefile.qc echo x - compile.amiga cat >compile.amiga <<'@EOF' lc -d3 -M -fi -O -DFLOATS -DINITS -DIMPLINIT "Scheme:Init.scm" #? blink with link.amiga NODEBUG @EOF chmod 666 compile.amiga echo x - link.amiga cat >link.amiga <<'@EOF' >FROM LIB:c.o+"scm.o"+"time.o"+"sys.o"+"scl.o"+"eval.o"+"subr.o"+"repl.o"+"sc2.o" TO "/scheme" LIB LIB:lcmieee.lib LIB:lc.lib VERBOSE SC SD @EOF chmod 666 link.amiga echo x - makefile.aztec cat >makefile.aztec <<'@EOF' CFLAGS=-dAMIGA -dFLOATS -dINITS -dIMPLINIT="Scheme:init.scm" OBJ=scm.o time.o sys.o scl.o eval.o subr.o repl.o sc2.o all: $(OBJ) ln $(OBJ) -o scheme -lma -lm -lc @EOF chmod 666 makefile.aztec echo x - makefile.ast cat >makefile.ast <<'@EOF' # Makefile for SCM for (Gnu CC port to Atari ST). # using sozc20's make program under kommando CLI 1.0u (no MiNT) # Copyright (C) 1990, 1991, 1992 Aubrey Jaffer. # See the file `scm.c' for terms applying to this program # Pathname where Init.scm resides. This directory must also contain COPYING. IMPLINIT=C:\\misc\\scm\\4a4\\init.scm # If pathname where Init.scm resides is not known in advance then # SCM_INIT_PATH is the environment variable whose value is the # pathname where Init.scm resides. # IMPLINIT= CC = gcc # -DRTL if this is a run-time library only (no interactive top level) # -DRECKLESS if you want most scm error checking disabled. # -O if you want the optimizing C compiler to be used. CFLAGS = -v -O # append any names of user extension files # -lm for -DFLOATS LIBS = -lpml # -DINITS= the initialization calls for user extension files. INITS= #you should not need to change below this line. #DFLAG = -DIMPLINIT=\"$(IMPLINIT)\" DFLAG = -DIMPLINIT="$(IMPLINIT)" ffiles = time.o repl.o scl.o sys.o eval.o subr.o sc2.o scm.ttp: $(ffiles) scm.o $(CC) -v -o scm.ttp $(ffiles) scm.o $(LIBS) scm.o: scm.c scm.h config.h patchlvl.h $(CC) $(CFLAGS) -c -DFLOATS -DINITS=$(INITS) scm.c sys.o: sys.c scm.h config.h $(CC) $(CFLAGS) -c -DFLOATS sys.c scl.o: scl.c scm.h $(CC) $(CFLAGS) -c -DFLOATS scl.c eval.o: eval.c scm.h $(CC) $(CFLAGS) -c -DFLOATS eval.c repl.o: repl.c scm.h config.h $(CC) $(CFLAGS) -c -DFLOATS $(DFLAG) repl.c time.o: time.c scm.h $(CC) $(CFLAGS) -c time.c subr.o: subr.c scm.h $(CC) $(CFLAGS) -c subr.c sc2.o: sc2.c scm.h $(CC) $(CFLAGS) -c sc2.c install: scm.ttp $(CP) scm.ttp C:\bin\scm.ttp clean: $(RM) *.o tmp* @EOF chmod 666 makefile.ast echo x - setjump.mar cat >setjump.mar <<'@EOF' .title setjump and longjump ; The VAX C runtime library uses the $unwind utility for implementing ; longjmp. That fails if your program do not follow normal ; stack decipline. This is a dirty implementation of setjmp ; and longjmp that does not have that problem. ; the names longjmp and setjmp are avoided so that the code can be linked ; with the vax c runtime library without name clashes. ; This code was contributed by an anonymous reviewer from ; comp.sources.reviewed. .entry setjump,^M movl 4(ap),r0 movq r2,(r0)+ movq r4,(r0)+ movq r6,(r0)+ movq r8,(r0)+ movq r10,(r0)+ movl fp,(r0)+ movo 4(fp),(r0)+ movq 20(fp),(r0) clrl r0 ret .entry longjump,^M movl 4(ap),r0 movq (r0)+,r2 movq (r0)+,r4 movq (r0)+,r6 movq (r0)+,r8 movq (r0)+,r10 movl (r0)+,r1 movo (r0)+,4(r1) movq (r0),20(r1) movl 8(ap),r0 movl r1,fp ret .end @EOF chmod 666 setjump.mar echo x - setjump.h cat >setjump.h <<'@EOF' /* setjump.h - Include file for VAX VMS version of setjump and longjump. This code was contributed by an anonymous reviewer from comp.sources.reviewed. */ typedef int jmp_buf[17]; extern int setjump(jmp_buf env); extern int longjump(jmp_buf env, int ret); #define setjmp setjump #define longjmp longjump @EOF chmod 666 setjump.h echo x - VMSBUILD.COM cat >VMSBUILD.COM <<'@EOF' $ ! From: T. Kurt Bond, tkb@mtnet2.wvnet.edu $ ! $ ! Build scm on VMS systems. $ ! $ ! p1: Options for cc. $ ! p2: Options for link. $ ! p3: Options for macro. $ ! $ ! The following lines define IMPLINIT as the directory in which this command $ ! procedure is followed by "Init.scm". If you want it someplace else, $ ! replace the `init = ...' line with `init = "yourfile". $ ! $ where = f$environment("PROCEDURE") !full pathname of this procedure $ where = f$parse(where,,,"DEVICE")+f$parse(where,,,"DIRECTORY") !device:[dir] $ init = where + "init.scm" !device:[dir]init.scm $ ! $ ! If you don't want floating point, delete the `"FLOATS",' on the lines $ ! below. $ cc 'p1 scm /define=("FLOATS","INITS=") $ cc 'p1 repl,time,eval,scl,subr,sys /define=("FLOATS","IMPLINIT=""''init'""") $ macro 'p3 setjump $ cc 'p1 pi $ link 'p2 scm,repl,time,eval,scl,subr,sys,setjump,sys$input/opt sys$share:vaxcrtl/share $ link 'p2 pi,sys$input/opt sys$share:vaxcrtl/share @EOF chmod 666 VMSBUILD.COM echo x - VMSGCC.COM cat >VMSGCC.COM <<'@EOF' $ ! From: T. Kurt Bond, tkb@mtnet2.wvnet.edu $ ! $ ! Build scm on VMS systems. $ ! $ ! p1: Options for cc. $ ! p2: Options for link. $ ! p3: Options for macro. $ ! $ ! The following lines define IMPLINIT as the directory in which this command $ ! procedure is followed by "Init.scm". If you want it someplace else, $ ! replace the `init = ...' line with `init = "yourfile". $ ! $ where = f$environment("PROCEDURE") !full pathname of this procedure $ where = f$parse(where,,,"DEVICE")+f$parse(where,,,"DIRECTORY") !device:[dir] $ init = where + "init.scm" !device:[dir]init.scm $ ! $ ! If you don't want floating point, delete the `"FLOATS",' on the lines $ ! below. $ gcc 'p1 scm /define=("FLOATS","INITS=") $ gcc 'p1 repl /define=("FLOATS","IMPLINIT=""''init'""") $ gcc 'p1 eval /define=("FLOATS") $ gcc 'p1 time /define=("FLOATS") $ gcc 'p1 scl /define=("FLOATS") $ gcc 'p1 subr $ gcc 'p1 sys /define=("FLOATS") $ macro 'p3 setjump $ gcc 'p1 pi $ $ link 'p2 scm,repl,time,eval,scl,subr,sys,setjump,sys$input/opt gnu_cc:[000000]gcclib/lib,- sys$share:vaxcrtl/share $ link 'p2 pi,sys$input/opt gnu_cc:[000000]gcclib/lib,- sys$share:vaxcrtl/share @EOF chmod 666 VMSGCC.COM exit 0