├── INSTALL ├── README ├── VERSION ├── boot.lisp ├── bootstrap ├── docs ├── .cvsignore ├── LICENSE ├── makefile ├── meanie-vs-doie.txt ├── tl-manual.dvi ├── tl-manual.html ├── tl-manual.info ├── tl-manual.info-1 ├── tl-manual.info-2 ├── tl-manual.info-3 ├── tl-manual.pdf ├── tl-manual.texinfo ├── tl-manual_foot.html └── tl-manual_toc.html ├── lecho ├── .cvsignore ├── c │ ├── boot.c │ ├── boot.h │ ├── boot.tlt │ ├── echo.c │ ├── echo.h │ ├── echo.tlt │ ├── lecho-files.txt │ ├── main.c │ ├── main.h │ ├── main.tlt │ ├── makefile-cygnus │ ├── makefile-freebsd │ ├── makefile-linux │ ├── makefile-macosx │ └── makefile.config └── lisp │ ├── .cvsignore │ ├── boot.lisp │ └── echo.lisp ├── makefile ├── misc ├── .cvsignore ├── flush-mem.c ├── makefile ├── mcl-loop.lisp └── mit-loop.lisp ├── pthread ├── .cvsignore └── lisp │ ├── boot.lisp │ └── threads.lisp ├── tl ├── .cvsignore ├── c │ ├── apply.c │ ├── apply.h │ ├── apply.tlt │ ├── boot.c │ ├── boot.h │ ├── boot.tlt │ ├── do.c │ ├── do.h │ ├── do.tlt │ ├── format.c │ ├── format.h │ ├── format.tlt │ ├── forward.c │ ├── forward.h │ ├── forward.tlt │ ├── generic-math.c │ ├── generic-math.h │ ├── generic-math.tlt │ ├── generic-prim.c │ ├── generic-prim.h │ ├── generic-prim.tlt │ ├── inline.c │ ├── inline.h │ ├── inline.tlt │ ├── input.c │ ├── input.h │ ├── input.tlt │ ├── loop.c │ ├── loop.h │ ├── loop.tlt │ ├── makefile-cygnus │ ├── makefile-freebsd │ ├── makefile-linux │ ├── makefile-macosx │ ├── makefile.config │ ├── packages.c │ ├── packages.h │ ├── packages.tlt │ ├── stubs.c │ ├── stubs.h │ ├── stubs.tlt │ ├── tl-basics.c │ ├── tl-basics.h │ ├── tl-basics.tlt │ ├── tl-extension.c │ ├── tl-extension.h │ ├── tl-extension.tlt │ ├── tl-files.txt │ ├── tl-prim.c │ ├── tl-prim.h │ ├── tl-prim.tlt │ ├── tl-time.c │ ├── tl-time.h │ ├── tl-time.tlt │ ├── tl-types.c │ ├── tl-types.h │ ├── tl-types.tlt │ ├── tl-util.c │ ├── tl-util.h │ ├── tl-util.tlt │ ├── tl.c │ ├── tl.h │ ├── versions.c │ ├── versions.h │ └── versions.tlt └── lisp │ ├── apply.lisp │ ├── boot.lisp │ ├── do.lisp │ ├── format.lisp │ ├── forward.lisp │ ├── generic-math.lisp │ ├── generic-prim.lisp │ ├── inline.lisp │ ├── input.lisp │ ├── loop.lisp │ ├── packages.lisp │ ├── stubs.lisp │ ├── tl-basics.lisp │ ├── tl-extension.lisp │ ├── tl-prim.lisp │ ├── tl-time.lisp │ ├── tl-types.lisp │ ├── tl-util.lisp │ └── versions.lisp └── tlt ├── .cvsignore └── lisp ├── backquote.lisp ├── bit-pack.lisp ├── boot.lisp ├── c-coerce.lisp ├── c-decls.lisp ├── c-expr.lisp ├── c-files.lisp ├── c-func.lisp ├── c-names.lisp ├── c-state.lisp ├── c-type-util.lisp ├── c-types.lisp ├── clos.lisp ├── decls.lisp ├── defstruct.lisp ├── defun.lisp ├── defvar.lisp ├── destruct.lisp ├── env.lisp ├── exports.lisp ├── l-const.lisp ├── l-expr.lisp ├── l-stack.lisp ├── l-top.lisp ├── l-trans.lisp ├── macros.lisp ├── makefiles.lisp ├── regions.lisp ├── setf.lisp ├── special.lisp ├── struct-type.lisp ├── symbols.lisp ├── symbols.txt ├── system.lisp ├── tests.lisp ├── tli-util.lisp ├── tlt-foreign.lisp ├── tlt-math.lisp ├── tlt-mem.txt ├── tlt-out.lisp ├── tlt-prim.lisp ├── tlt-trans.txt ├── trandata.lisp ├── trans.lisp ├── types.lisp └── wish-list.txt /INSTALL: -------------------------------------------------------------------------------- 1 | ThinLisp is shipped as a gzipped tarball and as a zip file. 2 | 3 | 1. Unpack the distribution into a directory of your choice. To unpack the 4 | tarball on UNIX or Windows where Cygwin has been installed, use the following 5 | commands. 6 | 7 | cd 8 | tar xzvf thinlisp-1.0.tgz 9 | 10 | To unpack the zip file, use Winzip or some equivalent on Windows, or use the 11 | following command. 12 | 13 | cd 14 | unzip thinlisp-1.0.tgz 15 | 16 | 2. Start your Lisp environment such that the default directory is the src 17 | directory within the Thinlisp distribution, such that the following line would 18 | work appropriately. (Note that tlt stands for ThinLisp Translator.) 19 | 20 | (truename "tlt/") 21 | => "/home/jallard/work/tlt/" 22 | 23 | 3. Bootstrap the translator by loading its boot file. 24 | 25 | (load "tlt/lisp/boot") 26 | 27 | 4. Compile the translator. 28 | 29 | (compile-tlt) 30 | 31 | 5. A small test system has been included, called "lecho" for Lisp 32 | Echo. It implements an executable that mimics the behavior of the 33 | "echo" command in the SH, CSH, or BASH shells. You can compile, load 34 | and translate Lecho, and its underlying TL system, with the following 35 | form. 36 | 37 | (tl:translate-system 'lecho) 38 | 39 | 6. The translator also emits makefiles. On a Linux system you could produce 40 | the Lecho executable with the following commands from a shell. Look in the bin 41 | directories for other makefiles for BSD, Cygnus, and Mac. 42 | 43 | cd tl/bin 44 | make -f makefile-linux 45 | cd ../../lecho/bin 46 | make -f makefile-linux 47 | 48 | 7. This should have produced an executable "lecho" in the lecho/bin 49 | directory. You can make your own sytems by copying the boot file in 50 | lecho/lisp into /lisp/boot.lisp, adding your own 51 | functionality, and running similar commands. 52 | 53 | Note that there are top level makefiles and boot.lisp files that 54 | perform many of the tasks described here. Add lines for your own 55 | subsystems to these in order to get a fully automated build of your 56 | Lisp-based libraries and executables. 57 | 58 | Enjoy. 59 | 60 | -------- 61 | $Id: INSTALL,v 1.4 2001/07/01 11:15:24 jallard Exp $ 62 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | ThinLisp 2 | 1.0 3 | 4 | What is it? 5 | ----------- 6 | 7 | ThinLisp is an open source Lisp to C translator for delivering commercial 8 | quality, Lisp-based applications. It implements a subset of Common Lisp with 9 | extensions. ThinLisp itself is written in Common Lisp, and so must run on top 10 | of an underlying Common Lisp implementation such as Allegro, MCL, or CMU Lisp. 11 | The C code resulting from a translation can then be independently compiled to 12 | produce a small, efficient executable image. 13 | 14 | ThinLisp is not a typical Lisp implementation in that it does not implement a 15 | garbage collector or many of the other run-time development features of other 16 | Lisps. ThinLisp is designed for producing high quality deliverable C libraries 17 | and executables from Lisp sources. Originally designed for real-time control 18 | applications, ThinLisp stresses run-time performance at the expense of some 19 | development time conveniences. This is exactly the opposite design philosophy 20 | from many Lisps, but that's what makes this one thin! 21 | 22 | ThinLisp is the current generation (4th) of a series of Lisp to C 23 | translators used to deploy a large Lisp system (1 million lines) built 24 | starting around 1990. 25 | 26 | The emitted C code has been tested in the past on 19 different platforms 27 | including Windows 95/98 and Windows NT for Intel and Alpha under both Cygnus and 28 | Visual C; UNIXes from Linux, FreeBSD, Sun, HP, IBM, SGI, Aviion, DEC UNIX, OSF, 29 | NEC, and Motorola; and VMS for VAX and Alpha. Though it has been some time 30 | since those platforms have been checked, we believe that there has been little 31 | change to the underlying C structures used, and so the generated C code should 32 | remain extremely portable. 33 | 34 | ThinLisp produces compile time warnings for uses of inherently slow 35 | Lisp operations, for consing operations, and for code that cannot be optimized 36 | due to a lack of sufficient type declarations. These warnings can be suppressed 37 | by improving the code, or through use of lexical declarations acknowledging that 38 | the code is only of prototype quality. Code meeting the stringent requirements 39 | imposed by ThinLisp generally cannot by sped up by rewriting it by hand in C. 40 | 41 | The development environment for a project using ThinLisp is provided by 42 | your favorite Common Lisp implementation. You author, debug, and test 43 | your program in that environment and when you wish to deploy the program 44 | you translate it to C and compile and link it in on your the platform of 45 | choice. During it's history programs in the ThinLisp dialect have been 46 | deployed on over a dozen different platforms. 47 | 48 | The copyrights to the ThinLisp sources are held by the ThinLisp Group. 49 | 50 | Contacts 51 | -------- 52 | 53 | Web Site: http://www.thinlisp.org/ 54 | 55 | See there for all mailing list details, distributions, bug reporting etc. 56 | 57 | Documentation 58 | ------------- 59 | 60 | The documentation is maintained as a set of info files. The 61 | file src/docs/tl-manual.info is the good starting point. 62 | 63 | [[ The doc is not currently deployed on the project website ]] 64 | 65 | Installation 66 | ------------ 67 | 68 | See the INSTALL file in this directory, i.e. the thinlisp-1.0 module. 69 | 70 | 71 | Licensing 72 | --------- 73 | 74 | See the LICENSE file in this directory. 75 | 76 | 77 | Acknowledgments 78 | ---------------- 79 | 80 | [[tbd]] 81 | 82 | -------------------------------------------------------------------------------- /VERSION: -------------------------------------------------------------------------------- 1 | 1.0.1 2 | 3 | The first line of this file should contain the version number for ThinLisp. 4 | This is used when creating the names for distribution tarballs and zip files. 5 | This version number must also be updated by hand within docs/tl-manual.texinfo 6 | and within the function LISP-IMPLEMENTATION-VERSION in tl/lisp/tl-basics.lisp 7 | before you make the release. 8 | 9 | To issue a new release, update the version numbers as described above, tag the 10 | sources with the new version using a tag of the following form. 11 | 12 | TL--BASE 13 | 14 | To tag the sources, check out the appropriate versions of all of the files that 15 | you want included in the release (usually this means the head versions of all 16 | files), and then run the following command. 17 | 18 | cvs tag TL--BASE 19 | 20 | The base tag is made so that a branch can be made off of this tag later if there 21 | is a need to issue a patch to this release. From within the src directory of a 22 | checked out source repository, run the following command to create a new 23 | exported src directory. 24 | 25 | cvs export -r TL--BASE -d src thinlisp-1.0/src 26 | 27 | Then run a "make distribution" to make a new directory called "dist" within the 28 | sandbox src directory. The dist directory will contain the files for a new 29 | distribution of a ThinLisp release. Once done copying those files to your 30 | release site, you'll need to delete the dist and thinlisp-* directories created 31 | by this process. 32 | -------------------------------------------------------------------------------- /boot.lisp: -------------------------------------------------------------------------------- 1 | (in-package "CL-USER") 2 | 3 | ;;;; Module BOOT 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; All rights reserved. 7 | 8 | ;;; This file is part of ThinLisp. 9 | 10 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 11 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 12 | ;;; Group; either version 1 or (at your option) any later version. 13 | 14 | ;;; ThinLisp is distributed in the hope that it will be useful, but 15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | 18 | ;;; For additional information see 19 | 20 | ;;; Author: Jim Allard 21 | 22 | 23 | 24 | 25 | ;;; Bootstrapping TL 26 | 27 | 28 | 29 | ;;; To bootstrap a ThinLisp translation environment, load this file into your 30 | ;;; favorite Lisp environment. Uncomment and specialize the 31 | ;;; DEF-CONVENIENCE-FORMS code below, and then add any needed calls to 32 | ;;; translate-system that are needed to even the odds. 33 | 34 | ;;; ThinLisp consists of an extensible set of systems, each rooted in the src 35 | ;;; directory and organized into a directory tree similar to the following. 36 | 37 | ;;; src/tlt/lisp/ 38 | ;;; dev/ 39 | ;;; tl/lisp/ 40 | ;;; dev/ 41 | ;;; macro/ 42 | ;;; c/ 43 | ;;; bin/ 44 | ;;; lecho/lisp/ 45 | ;;; dev/ 46 | ;;; macro/ 47 | ;;; c/ 48 | ;;; bin/ 49 | 50 | ;;; The "tlt" system is the ThinLisp Translator, which is the base module of the 51 | ;;; entire system. This contains a lisp directory and the directories for the 52 | ;;; Lisp binaries. The "tl" system is the first translated system, and it 53 | ;;; contains Lisp implementations of Common Lisp facilities in its Lisp 54 | ;;; directory. These are compiled into the dev or macro directories, and 55 | ;;; translations of these Lisp files are placed into the C directory. Note that 56 | ;;; the c directory also contains the only handwritten C files in this sytem, 57 | ;;; tl.c and tl.h. The compiled binaries for this handwritten and translated C 58 | ;;; files go into the bin directory. This system is an example of a TL library 59 | ;;; system -- it translates into a C library. The "lecho" system is shipped as 60 | ;;; a small example of a system that is translated and compiled into an 61 | ;;; executable. This system will read all of its command line arguments, and 62 | ;;; echo them back to standard-output, much lish the Bourne shell "echo" 63 | ;;; command. 64 | 65 | ;;; Every system should have a "boot.lisp" file in its lisp directory. Loading 66 | ;;; this file will define all characteristics required to run tl:compile-system 67 | ;;; and tl:translate-system. The macro `def-system-convenience-forms' will 68 | ;;; define `load-xxx', `compile-xxx', and `translate-xxx' forms for any system 69 | ;;; name "xxx", which expand into calls to the basic needed operations. In the 70 | ;;; forms below, add your system names to the list to generated all needed 71 | ;;; shortcuts. Once you have bootstrapped ThinLisp into your Lisp development 72 | ;;; environment, then calling load-system, compile-system, or translate-system 73 | ;;; will attempt to find and load the /lisp/boot.lisp file to bootstrap 74 | ;;; information about the system to be loaded. This recurses through any needed 75 | ;;; systems of your system. 76 | 77 | ;;; The code below will load up the ThinLisp translator, then compile the TL 78 | ;;; system. Feel free to add further def-convenience-forms calls or to add 79 | ;;; further code to compile/load/translate your system. 80 | 81 | ;;; Load the translator's boot file. 82 | 83 | (load 84 | (merge-pathnames (make-pathname :directory '(:relative "tlt" "lisp") :name "boot") 85 | (or *load-pathname* *default-pathname-defaults*))) 86 | 87 | ;; a less diverse world this would have read (load "tlt/lisp/boot")) 88 | 89 | 90 | 91 | ;;; Compile (and load) the translator. 92 | 93 | (compile-tlt) 94 | 95 | 96 | 97 | ;;; Define convenience forms for all systems (add your own to this list). 98 | 99 | (def-system-convenience-forms lecho) 100 | 101 | ;;; Translate your system (modify to compile or translate your system). 102 | 103 | (translate-lecho) 104 | -------------------------------------------------------------------------------- /bootstrap: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ### A script to compile those parts of the system 4 | ### that have changed since last time. 5 | 6 | if [ -x /usr/local/bin/clisp ] ; then 7 | clisp -x "(load \"boot.lisp\")" 8 | else 9 | 10 | # Invoke our lisp in batch mode (tested in: CMU Lisp) 11 | lisp -batch <) 53 | for research purposes. We gratefully acknowledge their donation to 54 | the ThinLisp group. For more information on ThinLisp and the ThinLisp 55 | Group please see . 56 | 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /docs/makefile: -------------------------------------------------------------------------------- 1 | all : tl-manual.info tl-manual.dvi tl-manual_toc.html tl-manual.pdf 2 | 3 | clean : 4 | rm -f tl-manual.aux tl-manual.cp tl-manual.cps tl-manual.dvi tl-manual.fn \ 5 | tl-manual.ky tl-manual.log tl-manual.pdf tl-manual.pg tl-manual.toc \ 6 | tl-manual.tp tl-manual.vr tl-manual.info tl-manual_toc.html tl-manual.html \ 7 | tl-manual_foot.html 8 | 9 | tl-manual.info : tl-manual.texinfo makefile 10 | makeinfo tl-manual.texinfo 11 | 12 | tl-manual.dvi : tl-manual.texinfo makefile 13 | texi2dvi tl-manual.texinfo 14 | 15 | tl-manual_toc.html : tl-manual.texinfo makefile 16 | texi2html tl-manual.texinfo 17 | 18 | tl-manual.pdf : tl-manual.texinfo makefile 19 | texi2pdf tl-manual.texinfo 20 | -------------------------------------------------------------------------------- /docs/meanie-vs-doie.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Jim Allard writes: 5 | 6 | 7 | > I think you can use your reaction to this example as a personality 8 | > test. 9 | 10 | 11 | Yeah, Myers-Briggs. :) :) :) Five bucks sez that over a statistically 12 | valid sample (>500 programmers) "do"ies map to INTJs and "mean"ies map 13 | to INTP in a statistically interesting way. 14 | 15 | 16 | Just my observation on anecdotal data. INTPs (or for you sceptics, 17 | those people who report "INTP" on the MBTI and related questionaires) 18 | seem to be much more comfortable with LISP (well, Scheme -- I took 19 | 6.001). I, an INTJ, felt when dealing with Scheme as if (by 20 | description) I were on a very, very, very bad acid trip. 21 | 22 | 23 | (Of course, other Types code, but I haven't decided how they would 24 | work out. My guess is it's a simple J/P thing.) 25 | 26 | 27 | (Note, however, I don't do C, either. I understand that I would love 28 | Java, and should go learn it, but haven't yet.) 29 | 30 | 31 | > If you love the clean simplicity of the C answer, then you're a 32 | > "do"ie. If you can't stomach an environment without the guarantees in the 33 | > Common Lisp answer, then you're a "mean"ie. 34 | 35 | 36 | That would make me a "do"ie, I guess. It looks from here like your 37 | dichotomy is between 38 | 39 | 40 | (1, meanie) Programmers who want a language that does the right thing, 41 | thereby that they may trust that clearly, properly articulated 42 | expressions in that language will function as they desire, 43 | 44 | 45 | and 46 | 47 | 48 | (2, doie) Programmers who want the language to let them do the right 49 | thing, and not get in their way as they go about it their own 50 | idiocyncratic way. 51 | 52 | 53 | Alexander Pope once wrote of the craft of poetry, "Tis not enough no 54 | harshness give offense// the sound must seem an echo to the sense." 55 | IIRC, e.e.cummings replied "Take care of the sounds and the sense will 56 | follow." 57 | 58 | 59 | The meanies sound like they are in cummings camp, taking care of the 60 | sounds, so the sense will follow; I'm a follower of Pope, bending the 61 | sounds to the purpose of my sense. 62 | 63 | 64 | Or another way: I see meanies as gardeners or arborists: they tend 65 | their language, and it bears fruit. I see myself as a doie as a 66 | mechanic: I see programs as machines to be built and tuned, and to be 67 | pushed to their limits. 68 | 69 | 70 | (And I am learning Tcl *why*? >sigh<) 71 | 72 | 73 | -- Vanessa Layne 74 | goliard@weasel.terc.edu -------------------------------------------------------------------------------- /docs/tl-manual.dvi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ska80/thinlisp/173573a723256d901887f1cbc26d5403025879ca/docs/tl-manual.dvi -------------------------------------------------------------------------------- /docs/tl-manual.html: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ska80/thinlisp/173573a723256d901887f1cbc26d5403025879ca/docs/tl-manual.html -------------------------------------------------------------------------------- /docs/tl-manual.info: -------------------------------------------------------------------------------- 1 | This is tl-manual.info, produced by makeinfo version 4.0 from 2 | tl-manual.texinfo. 3 | 4 | The rationale and associated descriptions of ThinLisp, a Lisp-to-C 5 | translator for real time applications and anything that shouldn't be 6 | fat and slow. 7 | 8 | Copyright (c) 1999-2001 The ThinLisp Group 9 | 10 |  11 | Indirect: 12 | tl-manual.info-1: 283 13 | tl-manual.info-2: 30276 14 | tl-manual.info-3: 77228 15 |  16 | Tag Table: 17 | (Indirect) 18 | Node: Top283 19 | Node: Acknowledgements737 20 | Node: Preface2429 21 | Node: Rant3760 22 | Ref: Rant-Footnote-124715 23 | Ref: Rant-Footnote-224836 24 | Ref: Rant-Footnote-324976 25 | Ref: Rant-Footnote-425155 26 | Node: ThinLisp-Compromise25376 27 | Ref: ThinLisp-Compromise-Footnote-130124 28 | Node: Original-Notes30276 29 | Node: Memory77228 30 | Ref: Memory-Footnote-194777 31 | Ref: Memory-Footnote-295538 32 | Ref: Memory-Footnote-396066 33 | Ref: Memory-Footnote-496121 34 | Ref: Memory-Footnote-596395 35 | Ref: Memory-Footnote-696504 36 | Node: Original-Introduction96605 37 | Ref: Original-Introduction-Footnote-199561 38 | Node: Required-Symbols99626 39 | Node: Index104110 40 |  41 | End Tag Table 42 | -------------------------------------------------------------------------------- /docs/tl-manual.info-2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ska80/thinlisp/173573a723256d901887f1cbc26d5403025879ca/docs/tl-manual.info-2 -------------------------------------------------------------------------------- /docs/tl-manual.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ska80/thinlisp/173573a723256d901887f1cbc26d5403025879ca/docs/tl-manual.pdf -------------------------------------------------------------------------------- /docs/tl-manual.texinfo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ska80/thinlisp/173573a723256d901887f1cbc26d5403025879ca/docs/tl-manual.texinfo -------------------------------------------------------------------------------- /docs/tl-manual_foot.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | ThinLisp Rant and Notes - Footnotes 6 | 7 | 8 |

ThinLisp Manual

9 |

Version 1.0.1

10 |

12 October 2001

11 |
The ThinLisp Group:
12 |
Jim Allard
13 |
Ben Hyde
14 |

15 |

16 |

(1)

17 |

Of course this is ignoring 18 | other, more broadly applicable developments, such as multi-tasking operating 19 | systems. 20 |

(2)

21 |

All apologies in advance 22 | to my father-in-law Ed (a scientist) and my brother-in-law Holger (a 23 | mathematician) from me (an engineer). 24 |

(3)

25 |

In the rest of this discussion, the scientist has gone for coffee, 26 | uninterested because there is nothing pre-existing to study, only new things 27 | being spun out of the air. 28 |

(4)

29 |

The C Programming 30 | Language, Second Edition, by Kernigan, Brian W. and Ritchie, Dennis M., 31 | Copyright 1988, 1978 by Bell Telephone Laboratories, Incorporated Prentice Hall 32 | P T R, Englewood Cliffs, NewJersey 07632 33 |

(5)

34 |

For consing operations that can be called from either context, you can 35 | declare a consing area of either, but in practice that is fairly rare. 36 |

(6)

37 |

There is an argument that they should be aligned on 8 byte 38 | addresses. There are two advantages to 8 byte alignment. One is that it would 39 | enable us to reliably store immediate double floats and pointers into the same 40 | array. The second is that it would can give us an immediate type tag for conses 41 | that is itself the offset to the cdr of a cons. The argument for 4 byte 42 | alignment is that all current C compilers we use align structures on 4 byte 43 | addresses, but some won't align them on 8 byte addresses, even if they contain 44 | doubles. The other argument for 4 byte alignment is that we would not need to 45 | occasionally skip forward 4 bytes when allocating from heap in order to find the 46 | next 8 byte aligned address. For now, the 4 byte alignment wins. 47 |

(7)

48 |

Kim Barrett recently made a convincing argument for an immediate type 49 | tag of zero for fixnums. With this approach there is no bit fiddling needed for 50 | fixnum numeric operations. I had originally dismissed this approach since it 51 | would require pointer arithmatic to be done to fetch the type tag of an object. 52 | However, since most processors have a single instruction that can fetch from an 53 | address plus offset, this becomes a moot point. For now, the existing scheme 54 | carries the day due to inertia. -jallard, 10/31/99 55 |

(8)

56 |

The Alpha OSF has since been renamed DEC UNIX. 57 |

(9)

58 |

The following comment applies only to 8 byte alignment: For 59 | example, we could put immediate floats into odd-indexed simple vector locations, 60 | and those floats would consume 2 elements. For structures and frames, this 61 | could provide significant savings. -jra 8/30/95 62 |

(10)

63 |

This note about classes is being written in anticipation of their 64 | implementation. -jallard 10/29/99 65 |

(11)

66 |

This latter idea of having a 67 | "reclaimed flag" has never been implemented. -jallard 10/12/99 68 |

(12)

69 |

Rest 70 | arguments have since been added. -jallard 10/9/99. 71 |

72 | This document was generated on 12 October 2001 using 73 | texi2html 1.56k. 74 | 75 | 76 | -------------------------------------------------------------------------------- /docs/tl-manual_toc.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | ThinLisp Rant and Notes - Table of Contents 6 | 7 | 8 |

ThinLisp Manual

9 |

Version 1.0.1

10 |

12 October 2001

11 |
The ThinLisp Group:
12 |
Jim Allard
13 |
Ben Hyde
14 |

15 |

16 |

78 |

79 | This document was generated on 12 October 2001 using 80 | texi2html 1.56k. 81 | 82 | 83 | -------------------------------------------------------------------------------- /lecho/.cvsignore: -------------------------------------------------------------------------------- 1 | bin 2 | opt 3 | dev 4 | macro 5 | -------------------------------------------------------------------------------- /lecho/c/boot.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: lecho/c/boot.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of lecho/lisp/boot.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "boot.h" 14 | 15 | 16 | static const Str_9 str_const 17 | = { 7, 7, 7, "TL-USER" }; 18 | 19 | static const Str_9 str_const_1 20 | = { 7, 5, 5, "LECHO" }; 21 | 22 | static const Str_5 str_const_2 23 | = { 7, 2, 2, "TL" }; 24 | 25 | static Obj cons_const[2] 26 | = 27 | #if defined(NO_ADDRESS_CONSTANTS) 28 | {(Obj)NULL, (Obj)NULL} 29 | #else 30 | {(Obj)(&str_const_2), (Obj)NULL} /* "TL" */ 31 | #endif 32 | ; 33 | 34 | static Obj cons_const_1[2] 35 | = 36 | #if defined(NO_ADDRESS_CONSTANTS) 37 | {(Obj)NULL, (Obj)NULL} 38 | #else 39 | {(Obj)(tl_boot_symbols+0), (Obj)NULL} /* TL */ 40 | #endif 41 | ; 42 | 43 | static Obj cons_const_2[4] 44 | = 45 | #if defined(NO_ADDRESS_CONSTANTS) 46 | {(Obj)NULL, (Obj)NULL, (Obj)NULL, (Obj)NULL} 47 | #else 48 | {(Obj)(tl_boot_symbols+4), (Obj)(((uint32)(&(cons_const_2[2]))) /* BOOT */ 49 | +2), (Obj)(lecho_boot_symbols+1), (Obj)NULL} /* ECHO */ 50 | #endif 51 | ; 52 | 53 | static const Str_5 str_const_3 54 | = { 7, 4, 4, "ECHO" }; 55 | 56 | Sym lecho_boot_symbols[2]; 57 | 58 | /* Translated from SYMS-LECHO-BOOT() = VOID */ 59 | 60 | void syms_lecho_boot (void) 61 | { 62 | Obj cached_tl_user_package; 63 | 64 | cached_tl_user_package = find_package_1((Obj)(&str_const)); /* "TL-USER" */ 65 | init_symbol_into_package((Obj)(&(lecho_boot_symbols[0])),(Obj)(&str_const_1), /* "LECHO" */ 66 | 1851,cached_tl_user_package); 67 | init_symbol_into_package((Obj)(&(lecho_boot_symbols[1])),(Obj)(&str_const_3), /* "ECHO" */ 68 | 1019,cached_tl_user_package); 69 | return; 70 | } 71 | 72 | 73 | /* Translated from INIT-LECHO-BOOT() = VOID */ 74 | 75 | void init_lecho_boot (void) 76 | { 77 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL-USER" */ 78 | #if defined(NO_ADDRESS_CONSTANTS) 79 | (cons_const[0]) = (Obj)(&str_const_2); /* "TL" */ 80 | #endif 81 | if (find_package_1((Obj)(&str_const_1))==NULL) /* "LECHO" */ 82 | make_package_1(((Str *)(&str_const_1))->body,(Obj)(( /* "LECHO" */ 83 | (uint32)(&(cons_const[0])))+2)); 84 | SET_GLOBAL(current_system_being_loaded,(Obj)(lecho_boot_symbols+0)); /* LECHO */ 85 | SET_GLOBAL(all_systems,alloc_cons((Obj)(lecho_boot_symbols+0), /* LECHO */ 86 | GET_GLOBAL(all_systems),0)); 87 | set_get((Obj)(lecho_boot_symbols+0),(Obj)(tl_boot_symbols /* LECHO */ 88 | +1),(Obj)NULL); /* SYSTEM-NICKNAMES */ 89 | #if defined(NO_ADDRESS_CONSTANTS) 90 | (cons_const_1[0]) = (Obj)(tl_boot_symbols+0); /* TL */ 91 | #endif 92 | set_get((Obj)(lecho_boot_symbols+0),(Obj)(tl_boot_symbols /* LECHO */ 93 | +2),(Obj)(((uint32)(&(cons_const_1[0]))) /* SYSTEM-USED-SYSTEMS */ 94 | +2)); 95 | #if defined(NO_ADDRESS_CONSTANTS) 96 | { 97 | (cons_const_2[0]) = (Obj)(tl_boot_symbols+4); /* BOOT */ 98 | (cons_const_2[1]) = (Obj)(((uint32)(&(cons_const_2[2])))+2); 99 | (cons_const_2[2]) = (Obj)(lecho_boot_symbols+1); /* ECHO */ 100 | } 101 | #endif 102 | set_get((Obj)(lecho_boot_symbols+0),(Obj)(tl_boot_symbols /* LECHO */ 103 | +3),(Obj)(((uint32)(&(cons_const_2[0])))+2)); /* SYSTEM-MODULES */ 104 | return; 105 | } 106 | 107 | -------------------------------------------------------------------------------- /lecho/c/boot.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: lecho/c/boot.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of lecho/lisp/boot.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[9]; 18 | } Str_9; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[5]; 25 | } Str_5; 26 | 27 | extern Sym lecho_boot_symbols[2]; 28 | 29 | extern Obj SpackageS; 30 | 31 | extern Obj all_systems; 32 | 33 | extern Obj current_system_being_loaded; 34 | 35 | extern Sym tl_boot_symbols[]; 36 | 37 | extern Obj find_package_1(Obj); 38 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 39 | extern Obj make_package_1(unsigned char *, Obj); 40 | extern Obj set_get(Obj, Obj, Obj); 41 | -------------------------------------------------------------------------------- /lecho/c/boot.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module lecho/c/boot.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for lecho/lisp/boot.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | '((TL-USER::BOOT "tl_boot_symbols" . 4) 12 | (:SYSTEM-MODULES "tl_boot_symbols" . 3) 13 | (:SYSTEM-NICKNAMES "tl_boot_symbols" . 1) 14 | (:SYSTEM-USED-SYSTEMS "tl_boot_symbols" . 2) 15 | (TL-USER::TL "tl_boot_symbols" . 0)) 16 | ;; Name for this file's array of quoted symbols. 17 | "lecho_boot_symbols" 18 | ;; Quoted symbols defined in this file. 19 | `(TL-USER::LECHO 20 | TL-USER::ECHO) 21 | ;; Used compiled-functions = (name func-array . index). 22 | NIL 23 | ;; Name for this file's array of compiled-functions. 24 | NIL 25 | ;; Compiled-function objects defined in this file. 26 | NIL 27 | ;; Used function type signatures. 28 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 29 | (TL::MAKE-PACKAGE-1 "make_package_1" FUNCTION (STRING T) T) 30 | (TL::SET-GET "set_get" FUNCTION (T T T) T)) 31 | ;; Defined functions. 32 | NIL 33 | ;; Used variables = (symbol c-name . type). 34 | '((*PACKAGE* "SpackageS" . OBJ) 35 | (TL:ALL-SYSTEMS "all_systems" . OBJ) 36 | (TL:CURRENT-SYSTEM-BEING-LOADED "current_system_being_loaded" . OBJ)) 37 | ;; Defined variables 38 | NIL 39 | ;; Used class typedefs. 40 | NIL 41 | ) 42 | -------------------------------------------------------------------------------- /lecho/c/echo.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: lecho/c/echo.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of lecho/lisp/echo.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "echo.h" 14 | 15 | 16 | static const Str_9 str_const 17 | = { 7, 5, 5, "LECHO" }; 18 | 19 | static const Str_9 str_const_1 20 | = { 7, 6, 6, "--help" }; 21 | 22 | static const Str_69 str_const_2 23 | = { 7, 66, 66, "Usage: lecho [arg] ...~% all arguments will be echoed to stdout~%" }; 24 | 25 | static const Str_5 str_const_3 26 | = { 7, 2, 2, "-n" }; 27 | 28 | /* Translated from MAIN(T) = FIXNUM */ 29 | 30 | sint32 main_1 (Obj args) 31 | { 32 | Obj g; 33 | unsigned char *g_1; 34 | unsigned char *g_2; 35 | int temp; 36 | Obj terpriP; 37 | unsigned char *g_3; 38 | unsigned char *g_4; 39 | Obj firstP, arg, tl_loop_list_; 40 | 41 | g = ((args!=NULL) ? CAR(args) : (Obj)NULL); 42 | args = ((args!=NULL) ? CDR(args) : (Obj)NULL); 43 | (void)g; 44 | if (args!=NULL) { 45 | g_1 = coerce_to_string((args!=NULL) ? CAR(args) : (Obj)NULL); 46 | g_2 = (((Str *)(&str_const_1))->body); /* "--help" */ 47 | temp = (strcmp((char *)g_1,(char *)g_2)==0); 48 | } 49 | else 50 | temp = 0; 51 | if (temp) { 52 | format_function((Obj)(&T),((Str *)(&str_const_2))->body, /* "Usage: lecho [arg] ...~% all arguments will be ec..." */ 53 | (Obj)NULL); 54 | return -1; 55 | } 56 | else { 57 | g_3 = coerce_to_string((args!=NULL) ? CAR(args) : (Obj)NULL); 58 | g_4 = (((Str *)(&str_const_3))->body); /* "-n" */ 59 | if (strcmp((char *)g_3,(char *)g_4)==0) { 60 | g = ((args!=NULL) ? CAR(args) : (Obj)NULL); 61 | args = ((args!=NULL) ? CDR(args) : (Obj)NULL); 62 | (void)g; 63 | terpriP = (Obj)NULL; 64 | } 65 | else 66 | terpriP = (Obj)(&T); 67 | firstP = (Obj)(&T); 68 | arg = (Obj)NULL; 69 | tl_loop_list_ = args; 70 | for (;tl_loop_list_!=NULL;firstP = (Obj)NULL) { 71 | arg = CAR(tl_loop_list_); 72 | tl_loop_list_ = CDR(tl_loop_list_); 73 | if (firstP==NULL) 74 | write_char(' ',(Obj)NULL); 75 | write_string_function(((Str *)arg)->body,(Obj)NULL,0,(Obj)NULL); 76 | } 77 | if (terpriP!=NULL) 78 | terpri((Obj)NULL); 79 | return 0; 80 | } 81 | } 82 | 83 | /* Translated from SYMS-LECHO-ECHO() = VOID */ 84 | 85 | void syms_lecho_echo (void) 86 | { 87 | return; 88 | } 89 | 90 | 91 | /* Translated from INIT-LECHO-ECHO() = VOID */ 92 | 93 | void init_lecho_echo (void) 94 | { 95 | SpackageS = find_package_1((Obj)(&str_const)); /* "LECHO" */ 96 | return; 97 | } 98 | 99 | -------------------------------------------------------------------------------- /lecho/c/echo.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: lecho/c/echo.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of lecho/lisp/echo.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[9]; 18 | } Str_9; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[69]; 25 | } Str_69; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[5]; 32 | } Str_5; 33 | 34 | extern Obj SpackageS; 35 | 36 | extern unsigned char * coerce_to_string(Obj); 37 | extern Obj find_package_1(Obj); 38 | extern Obj format_function(Obj, unsigned char *, Obj); 39 | extern Obj terpri(Obj); 40 | extern unsigned char write_char(unsigned char, Obj); 41 | extern unsigned char * write_string_function(unsigned char *, Obj, sint32, 42 | Obj); 43 | -------------------------------------------------------------------------------- /lecho/c/echo.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module lecho/c/echo.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for lecho/lisp/echo.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::COERCE-TO-STRING "coerce_to_string" FUNCTION (T) STRING) 24 | (TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 25 | (TL::FORMAT-FUNCTION "format_function" FUNCTION (T STRING T) T) 26 | (TL:TERPRI "terpri" FUNCTION (&OPTIONAL T) NULL) 27 | (TL:WRITE-CHAR "write_char" FUNCTION (CHARACTER &OPTIONAL T) CHARACTER) 28 | (TL::WRITE-STRING-FUNCTION "write_string_function" FUNCTION (STRING T FIXNUM T) STRING)) 29 | ;; Defined functions. 30 | '((TL-USER::MAIN . "main_1")) 31 | ;; Used variables = (symbol c-name . type). 32 | '((*PACKAGE* "SpackageS" . OBJ)) 33 | ;; Defined variables 34 | NIL 35 | ;; Used class typedefs. 36 | NIL 37 | ) 38 | -------------------------------------------------------------------------------- /lecho/c/lecho-files.txt: -------------------------------------------------------------------------------- 1 | main 2 | boot 3 | echo 4 | -------------------------------------------------------------------------------- /lecho/c/main.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: lecho/c/main.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of lecho/lisp/main.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "main.h" 14 | 15 | 16 | static const Str_9 str_const 17 | = { 7, 7, 7, "KEYWORD" }; 18 | 19 | static const Str_5 str_const_1 20 | = { 7, 1, 1, "T" }; 21 | 22 | static const Str_5 str_const_2 23 | = { 7, 2, 2, "TL" }; 24 | 25 | static const Str_9 str_const_3 26 | = { 7, 7, 7, "TL-USER" }; 27 | 28 | static const Str_13 str_const_4 29 | = { 7, 11, 11, "COMMON-LISP" }; 30 | 31 | int main (int argc, char **argv) 32 | { 33 | Obj lisp_argv, string_temp; 34 | sint32 index; 35 | 36 | malloc_block_into_region(0,65536,1); 37 | malloc_block_into_region(1,65536,1); 38 | malloc_block_into_region(2,65536,1); 39 | all_packages = (Obj)NULL; 40 | make_package_1(((Str *)(&str_const))->body,(Obj)NULL); /* "KEYWORD" */ 41 | init_symbol_into_package((Obj)(&T),(Obj)(&str_const_1),84, /* "T" */ 42 | make_package_1(((Str *)(&str_const_2))->body,(Obj)NULL)); /* "TL" */ 43 | T.symbol_value = (&T); 44 | T.external = 1; 45 | make_package_1(((Str *)(&str_const_3))->body,alloc_cons( /* "TL-USER" */ 46 | (Obj)(&str_const_2),(Obj)NULL,0)); /* "TL" */ 47 | make_package_1(((Str *)(&str_const_4))->body,(Obj)NULL); /* "COMMON-LISP" */ 48 | syms_tl_boot(); 49 | syms_tl_stubs(); 50 | syms_tl_tl_types(); 51 | syms_tl_inline(); 52 | syms_tl_tl_prim(); 53 | syms_tl_do(); 54 | syms_tl_format(); 55 | syms_tl_input(); 56 | syms_tl_tl_basics(); 57 | syms_tl_loop(); 58 | syms_tl_apply(); 59 | syms_tl_generic_math(); 60 | syms_tl_generic_prim(); 61 | syms_tl_packages(); 62 | syms_tl_tl_util(); 63 | syms_tl_versions(); 64 | syms_tl_forward(); 65 | syms_tl_tl_extension(); 66 | syms_tl_tl_time(); 67 | syms_lecho_boot(); 68 | syms_lecho_echo(); 69 | init_tl_boot(); 70 | init_tl_stubs(); 71 | init_tl_tl_types(); 72 | init_tl_inline(); 73 | init_tl_tl_prim(); 74 | init_tl_do(); 75 | init_tl_format(); 76 | init_tl_input(); 77 | init_tl_tl_basics(); 78 | init_tl_loop(); 79 | init_tl_apply(); 80 | init_tl_generic_math(); 81 | init_tl_generic_prim(); 82 | init_tl_packages(); 83 | init_tl_tl_util(); 84 | init_tl_versions(); 85 | init_tl_forward(); 86 | init_tl_tl_extension(); 87 | init_tl_tl_time(); 88 | init_lecho_boot(); 89 | init_lecho_echo(); 90 | lisp_argv = (Obj)NULL; 91 | for (index = (argc-1);index>=0;index--) { 92 | string_temp = alloc_string(strlen(argv[index]),0,7); 93 | strcpy((char *)(((Str *)string_temp)->body),argv[index]); 94 | lisp_argv = alloc_cons(string_temp,lisp_argv,0); 95 | } 96 | main_1(lisp_argv); 97 | return 0; 98 | } 99 | 100 | /* Translated from SYMS-LECHO-MAIN() = VOID */ 101 | 102 | void syms_lecho_main (void) 103 | { 104 | return; 105 | } 106 | 107 | 108 | /* Translated from INIT-LECHO-MAIN() = VOID */ 109 | 110 | void init_lecho_main (void) 111 | { 112 | return; 113 | } 114 | 115 | -------------------------------------------------------------------------------- /lecho/c/main.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: lecho/c/main.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of lecho/lisp/main.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[9]; 18 | } Str_9; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[5]; 25 | } Str_5; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[13]; 32 | } Str_13; 33 | 34 | extern Obj all_packages; 35 | 36 | extern void init_lecho_boot(void); 37 | extern void init_lecho_echo(void); 38 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 39 | extern void init_tl_apply(void); 40 | extern void init_tl_boot(void); 41 | extern void init_tl_do(void); 42 | extern void init_tl_format(void); 43 | extern void init_tl_forward(void); 44 | extern void init_tl_generic_math(void); 45 | extern void init_tl_generic_prim(void); 46 | extern void init_tl_inline(void); 47 | extern void init_tl_input(void); 48 | extern void init_tl_loop(void); 49 | extern void init_tl_packages(void); 50 | extern void init_tl_stubs(void); 51 | extern void init_tl_tl_basics(void); 52 | extern void init_tl_tl_extension(void); 53 | extern void init_tl_tl_prim(void); 54 | extern void init_tl_tl_time(void); 55 | extern void init_tl_tl_types(void); 56 | extern void init_tl_tl_util(void); 57 | extern void init_tl_versions(void); 58 | extern void main_1(Obj); 59 | extern Obj make_package_1(unsigned char *, Obj); 60 | extern void syms_lecho_boot(void); 61 | extern void syms_lecho_echo(void); 62 | extern void syms_tl_apply(void); 63 | extern void syms_tl_boot(void); 64 | extern void syms_tl_do(void); 65 | extern void syms_tl_format(void); 66 | extern void syms_tl_forward(void); 67 | extern void syms_tl_generic_math(void); 68 | extern void syms_tl_generic_prim(void); 69 | extern void syms_tl_inline(void); 70 | extern void syms_tl_input(void); 71 | extern void syms_tl_loop(void); 72 | extern void syms_tl_packages(void); 73 | extern void syms_tl_stubs(void); 74 | extern void syms_tl_tl_basics(void); 75 | extern void syms_tl_tl_extension(void); 76 | extern void syms_tl_tl_prim(void); 77 | extern void syms_tl_tl_time(void); 78 | extern void syms_tl_tl_types(void); 79 | extern void syms_tl_tl_util(void); 80 | extern void syms_tl_versions(void); 81 | -------------------------------------------------------------------------------- /lecho/c/main.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module lecho/c/main.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for lecho/lisp/main.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | NIL 24 | ;; Defined functions. 25 | NIL 26 | ;; Used variables = (symbol c-name . type). 27 | NIL 28 | ;; Defined variables 29 | NIL 30 | ;; Used class typedefs. 31 | NIL 32 | ) 33 | -------------------------------------------------------------------------------- /lecho/c/makefile-cygnus: -------------------------------------------------------------------------------- 1 | # 2 | # LECHO Cygnus Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = gcc -o 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += -pipe -ansi -pedantic -W -Wall -c 21 | 22 | LINK = gcc -o 23 | 24 | ifdef OPT 25 | LINKFLAGS = -O2 26 | LIBS = ../../tl/opt/libtl.a 27 | else 28 | LINKFLAGS = -g 29 | LIBS = ../../tl/bin/libtl.a 30 | endif 31 | 32 | SYSLIBS = 33 | OBJECTS = main.o boot.o echo.o 34 | 35 | all : lecho.exe 36 | 37 | clean : 38 | -rm *.o 39 | -( if [ -f lecho.exe ] ; then rm lecho.exe ; fi ) 40 | 41 | lecho.exe : makefile-cygnus $(OBJECTS) $(LIBS) 42 | -( if [ -f lecho.exe ] ; then rm lecho.exe ; fi ) 43 | $(LINK) lecho.exe $(LINKFLAGS) $(OBJECTS) $(LIBS) $(SYSLIBS) 44 | 45 | %.o : ../c/%.c ../c/%.h makefile-cygnus 46 | $(CC) $@ $(CFLAGS) -I ../c -I../../tl/c/ $< 47 | -------------------------------------------------------------------------------- /lecho/c/makefile-freebsd: -------------------------------------------------------------------------------- 1 | # 2 | # LECHO Freebsd Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = gcc -o 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += -pipe -ansi -pedantic -W -Wall -c 21 | 22 | LINK = gcc -o 23 | 24 | ifdef OPT 25 | LINKFLAGS = -O2 26 | LIBS = ../../tl/opt/libtl.a 27 | else 28 | LINKFLAGS = -g 29 | LIBS = ../../tl/bin/libtl.a 30 | endif 31 | 32 | SYSLIBS = -lm 33 | OBJECTS = main.o boot.o echo.o 34 | 35 | all : lecho 36 | 37 | clean : 38 | -rm *.o 39 | -( if [ -f lecho ] ; then rm lecho ; fi ) 40 | 41 | lecho : makefile-freebsd $(OBJECTS) $(LIBS) 42 | -( if [ -f lecho ] ; then rm lecho ; fi ) 43 | $(LINK) lecho $(LINKFLAGS) $(OBJECTS) $(LIBS) $(SYSLIBS) 44 | 45 | %.o : ../c/%.c ../c/%.h makefile-freebsd 46 | $(CC) $@ $(CFLAGS) -I ../c -I../../tl/c/ $< 47 | -------------------------------------------------------------------------------- /lecho/c/makefile-linux: -------------------------------------------------------------------------------- 1 | # 2 | # LECHO Linux Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = gcc -o 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += -pipe -ansi -pedantic -W -Wall -c 21 | 22 | LINK = gcc -o 23 | 24 | ifdef OPT 25 | LINKFLAGS = -O2 26 | LIBS = ../../tl/opt/libtl.a 27 | else 28 | LINKFLAGS = -g 29 | LIBS = ../../tl/bin/libtl.a 30 | endif 31 | 32 | SYSLIBS = -lm 33 | OBJECTS = main.o boot.o echo.o 34 | 35 | all : lecho 36 | 37 | clean : 38 | -rm *.o 39 | -( if [ -f lecho ] ; then rm lecho ; fi ) 40 | 41 | lecho : makefile-linux $(OBJECTS) $(LIBS) 42 | -( if [ -f lecho ] ; then rm lecho ; fi ) 43 | $(LINK) lecho $(LINKFLAGS) $(OBJECTS) $(LIBS) $(SYSLIBS) 44 | 45 | %.o : ../c/%.c ../c/%.h makefile-linux 46 | $(CC) $@ $(CFLAGS) -I ../c -I../../tl/c/ $< 47 | -------------------------------------------------------------------------------- /lecho/c/makefile-macosx: -------------------------------------------------------------------------------- 1 | # 2 | # LECHO Macosx Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = cc -o 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += -pipe -ansi -pedantic -W -Wall -c 21 | 22 | LINK = $(CC) 23 | 24 | ifdef OPT 25 | LINKFLAGS = -O2 26 | LIBS = ../../tl/opt/libtl.a 27 | else 28 | LINKFLAGS = -g 29 | LIBS = ../../tl/bin/libtl.a 30 | endif 31 | 32 | SYSLIBS = 33 | OBJECTS = main.o boot.o echo.o 34 | 35 | all : lecho 36 | 37 | clean : 38 | -rm *.o 39 | -( if [ -f lecho ] ; then rm lecho ; fi ) 40 | 41 | lecho : makefile-macosx $(OBJECTS) $(LIBS) 42 | -( if [ -f lecho ] ; then rm lecho ; fi ) 43 | $(LINK) lecho $(LINKFLAGS) $(OBJECTS) $(LIBS) $(SYSLIBS) 44 | 45 | %.o : ../c/%.c ../c/%.h makefile-macosx 46 | $(CC) $@ $(CFLAGS) -I ../c -I../../tl/c/ $< 47 | -------------------------------------------------------------------------------- /lecho/c/makefile.config: -------------------------------------------------------------------------------- 1 | # 2 | # LECHO Config Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = @CC@ 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += @CFLAGS@ -pipe -ansi -pedantic -W -Wall -c 21 | 22 | LINK = gcc -o 23 | 24 | ifdef OPT 25 | LINKFLAGS = -O2 26 | LIBS = ../../tl/opt/libtl.a 27 | else 28 | LINKFLAGS = -g 29 | LIBS = ../../tl/bin/libtl.a 30 | endif 31 | 32 | SYSLIBS = 33 | OBJECTS = main.o boot.o echo.o 34 | 35 | all : lecho.exe 36 | 37 | clean : 38 | -rm *.o 39 | -( if [ -f lecho.exe ] ; then rm lecho.exe ; fi ) 40 | 41 | lecho.exe : makefile.config $(OBJECTS) $(LIBS) 42 | -( if [ -f lecho.exe ] ; then rm lecho.exe ; fi ) 43 | $(LINK) lecho.exe $(LINKFLAGS) $(OBJECTS) $(LIBS) $(SYSLIBS) 44 | 45 | %.o : ../c/%.c ../c/%.h makefile.config 46 | $(CC) $@ $(CFLAGS) -I ../c -I../../tl/c/ $< 47 | -------------------------------------------------------------------------------- /lecho/lisp/.cvsignore: -------------------------------------------------------------------------------- 1 | dev 2 | macro 3 | -------------------------------------------------------------------------------- /lecho/lisp/boot.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TL-USER") 2 | 3 | ;;;; Module BOOT 4 | 5 | ;;; Copyright (c) 1999 The ThinLisp Group 6 | ;;; Copyright (c) 1999 Jim Allard 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Bootstrapping Lecho 29 | 30 | 31 | 32 | 33 | ;;; The `lecho' system is a simple, Lisp-based echo program that is primarily 34 | ;;; here to demonstrate the typical use of declare-system, package creation, and 35 | ;;; main functions with the TL translator. 36 | 37 | ;;; Typically, your systems should have a boot.lisp file in this position. If 38 | ;;; TL is attempting to find information about a system and currently has no 39 | ;;; information about it, it will load a filename of the form 40 | ;;; /lisp/boot.lisp. If that doesn't exist or doesn't contain the 41 | ;;; desired declare-system, then it will attempt to load 42 | ;;; lisp/-boot.lisp. 43 | 44 | ;;; Typically this file should be in the TL-USER package, and you can create any 45 | ;;; further packages you might want here. For example's sake, I'm going to make 46 | ;;; a LECHO package that will be used for the remaining file(s) in this system. 47 | 48 | (unless (find-package "LECHO") 49 | (make-package "LECHO")) 50 | 51 | (declare-system (lecho :main-function tl-user::main) 52 | boot 53 | echo) 54 | -------------------------------------------------------------------------------- /lecho/lisp/echo.lisp: -------------------------------------------------------------------------------- 1 | (in-package "LECHO") 2 | 3 | ;;;; Module ECHO 4 | 5 | ;;; Copyright (c) 1999 The ThinLisp Group 6 | ;;; Copyright (c) 1999 Jim Allard 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Echoing Arguments 29 | 30 | 31 | 32 | 33 | ;;; The `lecho' system is a simple, Lisp-based echo program that is primarily 34 | ;;; here to demonstrate the typical use of declare-system, package creation, and 35 | ;;; main functions with the TL translator. 36 | 37 | ;;; Typically, your systems should have a main function that is in the 38 | ;;; TL-USER package so that there are no problems mentioning it in the 39 | ;;; BOOT module, which must both create packages and name the main 40 | ;;; function. 41 | 42 | ;;; The main function that is declared in your declare-system form 43 | ;;; will be called with one argument, which is a list of strings which 44 | ;;; are the arguments to this execution of the program. This 45 | ;;; corresponds to the argv argument of a C main function. Main 46 | ;;; should return an integer: zero to indicate normal execution and 47 | ;;; completion, and other values to indicate failure modes. If the 48 | ;;; operation is at all non-trivial, you should look for an argument 49 | ;;; of "--help" or "?" and print out a usage banner, then exit. 50 | 51 | (defun tl-user::main (args) 52 | (pop args) ;; discard program name. 53 | (cond 54 | ((and args (string= (car args) "--help")) 55 | (format t "Usage: lecho [arg] ...~% all arguments will be echoed to stdout~%") 56 | -1) 57 | (t 58 | 59 | (loop 60 | with terpri? = (cond 61 | ((string= (car args) "-n") 62 | (pop args) 63 | nil) 64 | (t t)) 65 | finally (when terpri? (terpri)) 66 | for first? = t then nil 67 | for arg in args 68 | unless first? do (write-char #\space) 69 | do (write-string arg)) 70 | 0))) 71 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | # Makefile for ThinLisp, requires the GNU varient of make. 2 | 3 | MF = makefile-`uname -s | tr 'A-Z' 'a-z'` 4 | 5 | ifdef THREAD 6 | THREADARG = THREAD=1 7 | else 8 | THREADARG = 9 | endif 10 | 11 | all : TAGS docs/tl-manual.pdf lisp bin 12 | 13 | TAGS : tlt/lisp/*.lisp tl/lisp/*.lisp tl/c/*.c lecho/lisp/*.lisp lecho/c/*.c makefile 14 | find tl tlt lecho \( -name '*.[ch]' -o -name '*.lisp' \) -print | etags - 15 | 16 | docs/tl-manual.pdf : docs/tl-manual.texinfo 17 | cd docs && $(MAKE) -k 18 | 19 | lisp : 20 | ./bootstrap 21 | 22 | bin : 23 | cd tl/bin && $(MAKE) -kf $(MF) 24 | cd lecho/bin && $(MAKE) -kf $(MF) 25 | 26 | opt : 27 | cd tl/opt && $(MAKE) -kf $(MF) OPT=1 28 | cd lecho/opt && $(MAKE) -kf $(MF) OPT=1 29 | 30 | clean : 31 | csh -f -c 'rm -rf {tlt,tl,lecho}/{dev,macro,bin,opt} dist src TAGS' 32 | rm -rf lecho/c/*.tlt tl/c/*.tlt 33 | cd docs && $(MAKE) clean 34 | 35 | lisp-clean : 36 | csh -f -c 'rm -rf {tlt,tl,lecho}/{dev,macro,bin,opt} dist src' 37 | rm -rf lecho/c/*.tlt tl/c/*.tlt 38 | 39 | # To make a distribution, edit the VERSIONS file in this directory to set the 40 | # version number for the release, check it in, then follow the directions in the 41 | # VERSIONS file. Those instructions will eventually require you to run make on 42 | # the distributions target below. 43 | 44 | distribution : 45 | if [ -d dist ] ; then rm -rf dist ; fi 46 | if [ ! -d src ] ; then echo You must export an SRC before making distribution ; exit 1 ; fi 47 | cp ../README src 48 | mkdir dist 49 | cp src/VERSION dist/VERSION 50 | mkdir thinlisp-`head -1 dist/VERSION` 51 | cp src/INSTALL dist/thinlisp-`head -1 dist/VERSION`-install.txt 52 | mv src thinlisp-`head -1 dist/VERSION`/src 53 | tar czvf dist/thinlisp-`head -1 thinlisp-*/src/VERSION`.tgz thinlisp-`head -1 dist/VERSION` 54 | zip -r dist/thinlisp-`head -1 VERSION`.zip thinlisp-`head -1 dist/VERSION` 55 | bzip2 -cz `find thinlisp-* -type f -print` > dist/thinlisp-`head -1 dist/VERSION`.bz2 56 | rm dist/VERSION 57 | -------------------------------------------------------------------------------- /misc/.cvsignore: -------------------------------------------------------------------------------- 1 | flush-mem 2 | -------------------------------------------------------------------------------- /misc/flush-mem.c: -------------------------------------------------------------------------------- 1 | /** 2 | * 3 | * Module: flush-mem.c 4 | * 5 | * Copyright (c) 1999 The Thinlisp Group 6 | * All Rights Reserved. 7 | * 8 | * This file is part of ThinLisp. 9 | * 10 | * ThinLisp is open source; you can redistribute it and/or modify it 11 | * under the terms of the ThinLisp License as published by the ThinLisp 12 | * Group; either version 1 or (at your option) any later version. 13 | * 14 | * ThinLisp is distributed in the hope that it will be useful, but 15 | * WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | * 18 | * For additional information see 19 | * 20 | * Author Jim Allard 21 | * 22 | * This file contains an experiment in mallocing big chunks of memory 23 | * then exiting to see if this can flush cache before it's really 24 | * needed. 25 | */ 26 | 27 | #include 28 | #include 29 | #include 30 | #include 31 | 32 | void usage(void) { 33 | printf("Usage: flush-mem \n"); 34 | exit(-1); 35 | } 36 | 37 | #define MEG 1048576 38 | #define MEGS_PER_MALLOC 10 39 | 40 | 41 | int main(int argc, char **argv) { 42 | int megs, megs_done, i; 43 | int stuff[MEG/sizeof(int)]; 44 | char *new_mem; 45 | 46 | if (argc != 2) 47 | usage(); 48 | errno = 0; 49 | megs = strtol(argv[1], NULL, 10); 50 | if (errno != 0) { 51 | perror("Error reading megs argument"); 52 | usage(); 53 | } 54 | 55 | for (i=0; i < (MEG/sizeof(int)); ++i) { 56 | stuff[i] = i + ((i & 0xef) << 16); 57 | } 58 | 59 | printf("Mallocing in %d Meg increments: ", MEGS_PER_MALLOC); 60 | fflush(stdout); 61 | for (megs_done = 0; megs_done 19 | 20 | ;;; Author: Jim Allard 21 | 22 | 23 | 24 | 25 | 26 | 27 | ;;;; Pthread Support 28 | 29 | 30 | 31 | (unless (find-package "PTHREAD") 32 | (make-package "PTHREAD")) 33 | 34 | (declare-system (pthread :library t :used-systems (tl)) 35 | boot 36 | threads) 37 | -------------------------------------------------------------------------------- /pthread/lisp/threads.lisp: -------------------------------------------------------------------------------- 1 | (in-package "PTHREAD") 2 | 3 | ;;;; Module THREADS 4 | 5 | ;;; Copyright (c) 2000-2001 The ThinLisp Group 6 | ;;; All rights reserved. 7 | 8 | ;;; This file is part of ThinLisp. 9 | 10 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 11 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 12 | ;;; Group; either version 1 or (at your option) any later version. 13 | 14 | ;;; ThinLisp is distributed in the hope that it will be useful, but 15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | 18 | ;;; For additional information see 19 | 20 | ;;; Author: Jim Allard 21 | 22 | 23 | 24 | 25 | 26 | 27 | ;;;; Thread Library Implementation 28 | 29 | 30 | 31 | ;;; This file implements all of the functions used to interface with the Posic 32 | ;;; PTHREADs library. Access is provided to all of the standard tools, and also 33 | ;;; to two additional forms, progn-parallel and progn-parallel-race. 34 | 35 | ;;; In ThinLisp, threads are represented as a structure that you created with make-pthread 36 | 37 | (defstruct (pthread (:reclaimer reclaim-pthread)) 38 | (thread-id 0 :type uint32)) 39 | 40 | -------------------------------------------------------------------------------- /tl/.cvsignore: -------------------------------------------------------------------------------- 1 | bin 2 | opt 3 | dev 4 | macro 5 | -------------------------------------------------------------------------------- /tl/c/apply.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/apply.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/apply.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[45]; 25 | } Str_45; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[49]; 32 | } Str_49; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[57]; 39 | } Str_57; 40 | 41 | extern Obj SpackageS; 42 | 43 | extern Obj error_one_arg(Obj, Obj); 44 | extern Obj error_three_args(Obj, Obj, Obj, Obj); 45 | extern Obj error_two_args(Obj, Obj, Obj); 46 | extern Obj find_package_1(Obj); 47 | extern sint32 length(Obj); 48 | extern Obj nthcdr(sint32, Obj); 49 | -------------------------------------------------------------------------------- /tl/c/apply.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/apply.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/apply.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::ERROR-ONE-ARG "error_one_arg" FUNCTION (T T) NULL) 24 | (TL::ERROR-THREE-ARGS "error_three_args" FUNCTION (T T T T) NULL) 25 | (TL::ERROR-TWO-ARGS "error_two_args" FUNCTION (T T T) NULL) 26 | (TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 27 | (TL:NTHCDR "nthcdr" FUNCTION (FIXNUM LIST) T)) 28 | ;; Defined functions. 29 | '((TL::APPLY-1 . "apply_1")) 30 | ;; Used variables = (symbol c-name . type). 31 | '((*PACKAGE* "SpackageS" . OBJ)) 32 | ;; Defined variables 33 | NIL 34 | ;; Used class typedefs. 35 | NIL 36 | ) 37 | -------------------------------------------------------------------------------- /tl/c/boot.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/boot.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/boot.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[9]; 25 | } Str_9; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[17]; 32 | } Str_17; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[21]; 39 | } Str_21; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[13]; 46 | } Str_13; 47 | 48 | extern Sym tl_boot_symbols[23]; 49 | 50 | extern Obj SpackageS; 51 | 52 | extern Obj all_systems; 53 | 54 | extern Obj current_system_being_loaded; 55 | 56 | extern Obj find_package_1(Obj); 57 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 58 | extern Obj set_get(Obj, Obj, Obj); 59 | -------------------------------------------------------------------------------- /tl/c/boot.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/boot.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/boot.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | "tl_boot_symbols" 14 | ;; Quoted symbols defined in this file. 15 | `(TL-USER::TL 16 | :SYSTEM-NICKNAMES 17 | :SYSTEM-USED-SYSTEMS 18 | :SYSTEM-MODULES 19 | TL-USER::BOOT 20 | TL-USER::STUBS 21 | TL-USER::TL-TYPES 22 | INLINE 23 | TL-USER::TL-PRIM 24 | TL:DO 25 | TL:FORMAT 26 | TL-USER::INPUT 27 | TL-USER::TL-BASICS 28 | TL:LOOP 29 | TL:APPLY 30 | TL-USER::GENERIC-MATH 31 | TL-USER::GENERIC-PRIM 32 | TL-USER::PACKAGES 33 | TL-USER::TL-UTIL 34 | TL-USER::VERSIONS 35 | TL-USER::FORWARD 36 | TL-USER::TL-EXTENSION 37 | TL-USER::TL-TIME) 38 | ;; Used compiled-functions = (name func-array . index). 39 | NIL 40 | ;; Name for this file's array of compiled-functions. 41 | NIL 42 | ;; Compiled-function objects defined in this file. 43 | NIL 44 | ;; Used function type signatures. 45 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 46 | (TL::SET-GET "set_get" FUNCTION (T T T) T)) 47 | ;; Defined functions. 48 | NIL 49 | ;; Used variables = (symbol c-name . type). 50 | '((*PACKAGE* "SpackageS" . OBJ) 51 | (TL:ALL-SYSTEMS "all_systems" . OBJ) 52 | (TL:CURRENT-SYSTEM-BEING-LOADED "current_system_being_loaded" . OBJ)) 53 | ;; Defined variables 54 | NIL 55 | ;; Used class typedefs. 56 | NIL 57 | ) 58 | -------------------------------------------------------------------------------- /tl/c/do.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/do.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/do.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "do.h" 14 | 15 | 16 | static const Str_5 str_const 17 | = { 7, 2, 2, "TL" }; 18 | 19 | /* Translated from SYMS-TL-DO() = VOID */ 20 | 21 | void syms_tl_do (void) 22 | { 23 | return; 24 | } 25 | 26 | 27 | /* Translated from INIT-TL-DO() = VOID */ 28 | 29 | void init_tl_do (void) 30 | { 31 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL" */ 32 | return; 33 | } 34 | 35 | -------------------------------------------------------------------------------- /tl/c/do.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/do.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/do.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | extern Obj SpackageS; 21 | 22 | extern Obj find_package_1(Obj); 23 | -------------------------------------------------------------------------------- /tl/c/do.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/do.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/do.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 24 | ;; Defined functions. 25 | NIL 26 | ;; Used variables = (symbol c-name . type). 27 | '((*PACKAGE* "SpackageS" . OBJ)) 28 | ;; Defined variables 29 | NIL 30 | ;; Used class typedefs. 31 | NIL 32 | ) 33 | -------------------------------------------------------------------------------- /tl/c/format.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/format.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/format.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[9]; 25 | } Str_9; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[13]; 32 | } Str_13; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[17]; 39 | } Str_17; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[25]; 46 | } Str_25; 47 | 48 | typedef struct { 49 | unsigned int type : 8; 50 | unsigned int length : 24; 51 | unsigned int fill_length: 24; 52 | unsigned char body[21]; 53 | } Str_21; 54 | 55 | typedef struct { 56 | unsigned int type : 8; 57 | unsigned int length : 24; 58 | unsigned int fill_length: 24; 59 | unsigned char body[49]; 60 | } Str_49; 61 | 62 | typedef struct { 63 | unsigned int type : 8; 64 | unsigned int length : 24; 65 | unsigned int fill_length: 24; 66 | unsigned char body[45]; 67 | } Str_45; 68 | 69 | typedef struct { 70 | unsigned int type : 8; 71 | unsigned int length : 24; 72 | unsigned int fill_length: 24; 73 | unsigned char body[29]; 74 | } Str_29; 75 | 76 | typedef struct { 77 | unsigned int type : 8; 78 | unsigned int length : 24; 79 | unsigned int fill_length: 24; 80 | unsigned char body[65]; 81 | } Str_65; 82 | 83 | typedef struct { 84 | unsigned int type : 8; 85 | unsigned int length : 24; 86 | unsigned int fill_length: 24; 87 | unsigned char body[33]; 88 | } Str_33; 89 | 90 | typedef struct { 91 | unsigned int type : 8; 92 | unsigned int length : 24; 93 | unsigned int fill_length: 24; 94 | unsigned char body[77]; 95 | } Str_77; 96 | 97 | typedef struct { 98 | unsigned int type : 8; 99 | unsigned int length : 24; 100 | unsigned int fill_length: 24; 101 | unsigned char body[57]; 102 | } Str_57; 103 | 104 | extern Sym tl_format_symbols[4]; 105 | 106 | extern Func tl_format_funcs[1]; 107 | 108 | extern Obj SpackageS; 109 | 110 | extern Obj current_region; 111 | 112 | extern Func tl_format_funcs[]; 113 | 114 | extern void bad_control_directive_error(Obj); 115 | extern void bad_stream_error(Obj); 116 | extern sint32 discard_format_arglist(unsigned char *, sint32, sint32); 117 | extern sint32 find_end_of_conditional(unsigned char *, sint32, sint32); 118 | extern Obj find_package_1(Obj); 119 | extern sint32 fixnum_floor_first(sint32, sint32); 120 | extern Obj format_error(Obj, Obj); 121 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 122 | extern Obj last(Obj); 123 | extern sint32 length(Obj); 124 | extern sint32 mod_fixnums(sint32, sint32); 125 | extern Obj princ(Obj, Obj); 126 | extern void unsupported_control_char_error(Obj); 127 | extern Obj write_list(Obj, Obj); 128 | extern void write_symbol(Obj, Obj, Obj); 129 | -------------------------------------------------------------------------------- /tl/c/format.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/format.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/format.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | "tl_format_symbols" 14 | ;; Quoted symbols defined in this file. 15 | `(:UPCASE 16 | :DOWNCASE 17 | :CAPITALIZE 18 | :CAP-FIRST-LOWER-REST) 19 | ;; Used compiled-functions = (name func-array . index). 20 | '((TL::WRITE-SYMBOL "tl_format_funcs" . 0)) 21 | ;; Name for this file's array of compiled-functions. 22 | "tl_format_funcs" 23 | ;; Compiled-function objects defined in this file. 24 | `(TL::WRITE-SYMBOL) 25 | ;; Used function type signatures. 26 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 27 | (TL:LAST "last" FUNCTION (LIST) LIST) 28 | (TL::WRITE-SYMBOL "write_symbol" FUNCTION (SYMBOL T T) VOID)) 29 | ;; Defined functions. 30 | '((TL::ALLOC-FIELD-WIDTH-STRING . "alloc_field_width_string") 31 | (TL::BAD-CONTROL-DIRECTIVE-ERROR . "bad_control_directive_error") 32 | (TL::BAD-STREAM-ERROR . "bad_stream_error") 33 | (TL:CHAR-NAME . "char_name") 34 | (TL::CHECK-MAKE-ARRAY-DIMENSIONS . "check_make_array_dimensions") 35 | (TL::COPY-STRING . "copy_string") 36 | (TL::DISCARD-FORMAT-ARGLIST . "discard_format_arglist") 37 | (TL::ERROR-ONE-ARG . "error_one_arg") 38 | (TL::ERROR-THREE-ARGS . "error_three_args") 39 | (TL::ERROR-TWO-ARGS . "error_two_args") 40 | (TL::FIND-END-OF-CONDITIONAL . "find_end_of_conditional") 41 | (TL:FORCE-OUTPUT . "force_output") 42 | (TL::FORMAT-ERROR . "format_error") 43 | (TL::FORMAT-FUNCTION . "format_function") 44 | (TL::GET-LAST-STRING-STREAM-CHARACTER . "get_last_string_stream_character") 45 | (TL:GET-OUTPUT-STREAM-STRING . "get_output_stream_string") 46 | (TL::GET-STRING-OR-FILE-STREAM-FOR-OUTPUT . "get_string_or_file_stream_for_output") 47 | (TL::LAST-STREAM-CHAR? . "last_stream_charP") 48 | (TL::LAST-STRING-CHAR? . "last_string_charP") 49 | (TL::NOT-NULL-DESTRUCTURING-ERROR-1 . "not_null_destructuring_error_1") 50 | (TL::NSTRING-CAPITALIZE-FUNCTION . "nstring_capitalize_function") 51 | (TL::NSTRING-DOWNCASE-FUNCTION . "nstring_downcase_function") 52 | (TL::NSTRING-UPCASE-FUNCTION . "nstring_upcase_function") 53 | (TL::PM-PRINT . "pm_print") 54 | (TL:PRIN1 . "prin1") 55 | (TL:PRINC . "princ") 56 | (TL:PRINT . "print") 57 | (TL::PRINT-RANDOM-OBJECT-WITH-TYPE-NAME . "print_random_object_with_type_name") 58 | (TL::STRING-DOWNCASE-FUNCTION . "string_downcase_function") 59 | (TL::STRING-UPCASE-FUNCTION . "string_upcase_function") 60 | (TL:TERPRI . "terpri") 61 | (TL::UNSUPPORTED-CONTROL-CHAR-ERROR . "unsupported_control_char_error") 62 | (TL:WRITE-CHAR . "write_char") 63 | (TL::WRITE-FIXNUM . "write_fixnum") 64 | (TL::WRITE-FIXNUM-IN-ARBITRARY-BASE . "write_fixnum_in_arbitrary_base") 65 | (TL::WRITE-FIXNUM-IN-HEX . "write_fixnum_in_hex") 66 | (TL::WRITE-FIXNUM-WITH-ARGLIST . "write_fixnum_with_arglist") 67 | (TL::WRITE-FIXNUM-WITH-COMMAS . "write_fixnum_with_commas") 68 | (TL::WRITE-FUNCTION . "write_function") 69 | (TL::WRITE-LINE-FUNCTION . "write_line_function") 70 | (TL::WRITE-LIST . "write_list") 71 | (TL::WRITE-STRING-FUNCTION . "write_string_function") 72 | (TL::WRITE-WITH-ARGLIST . "write_with_arglist")) 73 | ;; Used variables = (symbol c-name . type). 74 | '((*PACKAGE* "SpackageS" . OBJ) 75 | (CURRENT-REGION "current_region" . OBJ)) 76 | ;; Defined variables 77 | '((*DEBUG-IO* . "Sdebug_ioS") 78 | (*ERROR-OUTPUT* . "Serror_outputS") 79 | (*PRINT-BASE* . "Sprint_baseS") 80 | (*PRINT-CASE* . "Sprint_caseS") 81 | (*PRINT-CIRCLE* . "Sprint_circleS") 82 | (*PRINT-ESCAPE* . "Sprint_escapeS") 83 | (*PRINT-LENGTH* . "Sprint_lengthS") 84 | (*PRINT-LEVEL* . "Sprint_levelS") 85 | (*PRINT-PRETTY* . "Sprint_prettyS") 86 | (*QUERY-IO* . "Squery_ioS") 87 | (*STANDARD-INPUT* . "Sstandard_inputS") 88 | (*STANDARD-OUTPUT* . "Sstandard_outputS") 89 | (*TERMINAL-IO* . "Sterminal_ioS") 90 | (*TRACE-OUTPUT* . "Strace_outputS") 91 | (TL::DEFAULT-STRING-STREAM-SIZE . "default_string_stream_size") 92 | (TL::FIELD-WIDTH-STRING-LENGTH . "field_width_string_length") 93 | (TL::FIELD-WIDTH-STRING-LIST . "field_width_string_list") 94 | (TL::REVERSED-FIXNUM-WITH-COMMAS-STRING . "reversed_fixnum_with_commas_string")) 95 | ;; Used class typedefs. 96 | NIL 97 | ) 98 | -------------------------------------------------------------------------------- /tl/c/forward.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/forward.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/forward.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "forward.h" 14 | 15 | 16 | static const Str_5 str_const 17 | = { 7, 2, 2, "TL" }; 18 | 19 | /* Translated from SYMS-TL-FORWARD() = VOID */ 20 | 21 | void syms_tl_forward (void) 22 | { 23 | return; 24 | } 25 | 26 | 27 | /* Translated from INIT-TL-FORWARD() = VOID */ 28 | 29 | void init_tl_forward (void) 30 | { 31 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL" */ 32 | return; 33 | } 34 | 35 | -------------------------------------------------------------------------------- /tl/c/forward.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/forward.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/forward.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | extern Obj SpackageS; 21 | 22 | extern Obj find_package_1(Obj); 23 | -------------------------------------------------------------------------------- /tl/c/forward.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/forward.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/forward.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 24 | ;; Defined functions. 25 | NIL 26 | ;; Used variables = (symbol c-name . type). 27 | '((*PACKAGE* "SpackageS" . OBJ)) 28 | ;; Defined variables 29 | NIL 30 | ;; Used class typedefs. 31 | NIL 32 | ) 33 | -------------------------------------------------------------------------------- /tl/c/generic-math.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/generic-math.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/generic-math.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[49]; 25 | } Str_49; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[33]; 32 | } Str_33; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[61]; 39 | } Str_61; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[77]; 46 | } Str_77; 47 | 48 | typedef struct { 49 | unsigned int type : 8; 50 | unsigned int length : 24; 51 | unsigned int fill_length: 24; 52 | unsigned char body[9]; 53 | } Str_9; 54 | 55 | extern Obj SpackageS; 56 | 57 | extern Obj error_three_args(Obj, Obj, Obj, Obj); 58 | extern Obj error_two_args(Obj, Obj, Obj); 59 | extern Obj find_package_1(Obj); 60 | extern sint32 fixnum_floor_first(sint32, sint32); 61 | extern double fmod(double, double); 62 | extern void integer_divide_error(Obj, Obj); 63 | extern sint32 mod_fixnums(sint32, sint32); 64 | extern double mod_float(double, double); 65 | -------------------------------------------------------------------------------- /tl/c/generic-math.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/generic-math.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/generic-math.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::ERROR-THREE-ARGS "error_three_args" FUNCTION (T T T T) NULL) 24 | (TL::ERROR-TWO-ARGS "error_two_args" FUNCTION (T T T) NULL) 25 | (TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 26 | ;; Defined functions. 27 | '((TL::EXPT-FIXNUM . "expt_fixnum") 28 | (TL::FIXNUM-FLOOR . "fixnum_floor") 29 | (TL::FIXNUM-FLOOR-FIRST . "fixnum_floor_first") 30 | (TL::FIXNUM-OVERFLOW-ERROR . "fixnum_overflow_error") 31 | (TL::FTRUNCATE-ONE-ARG-MULT-VALUE . "ftruncate_one_arg_mult_value") 32 | (TL::FTRUNCATE-TWO-ARG-MULT-VALUE . "ftruncate_two_arg_mult_value") 33 | (TL::GENERIC-ABS . "generic_abs") 34 | (TL::GENERIC-CEILING . "generic_ceiling") 35 | (TL::GENERIC-CEILING-ONE . "generic_ceiling_one") 36 | (TL::GENERIC-DIVIDE . "generic_divide") 37 | (TL::GENERIC-EXPT . "generic_expt") 38 | (TL::GENERIC-FCEILING . "generic_fceiling") 39 | (TL::GENERIC-FCEILING-ONE . "generic_fceiling_one") 40 | (TL::GENERIC-FFLOOR . "generic_ffloor") 41 | (TL::GENERIC-FFLOOR-ONE . "generic_ffloor_one") 42 | (TL::GENERIC-FLOOR . "generic_floor") 43 | (TL::GENERIC-FLOOR-ONE . "generic_floor_one") 44 | (GENERIC-GREATER-THAN . "generic_greater_than") 45 | (GENERIC-GREATER-THAN-OR-EQUAL . "generic_greater_than_or_equal") 46 | (GENERIC-LESS-THAN . "generic_less_than") 47 | (GENERIC-LESS-THAN-OR-EQUAL . "generic_less_than_or_equal") 48 | (GENERIC-MINUS . "generic_minus") 49 | (TL::GENERIC-MOD . "generic_mod") 50 | (GENERIC-MULTIPLY . "generic_multiply") 51 | (TL::GENERIC-NEGATE . "generic_negate") 52 | (GENERIC-NUMERIC-EQUAL . "generic_numeric_equal") 53 | (GENERIC-NUMERIC-NOT-EQUAL . "generic_numeric_not_equal") 54 | (GENERIC-PLUS . "generic_plus") 55 | (TL::GENERIC-REM . "generic_rem") 56 | (TL::GENERIC-ROUND-ONE . "generic_round_one") 57 | (TL::GENERIC-ROUND-ONE-FIRST . "generic_round_one_first") 58 | (TL::GENERIC-ROUND-TWO . "generic_round_two") 59 | (TL::GENERIC-ROUND-TWO-FIRST . "generic_round_two_first") 60 | (TL::GENERIC-TRUNCATE-ONE . "generic_truncate_one") 61 | (TL::GENERIC-TRUNCATE-ONE-FIRST . "generic_truncate_one_first") 62 | (TL::GENERIC-TRUNCATE-TWO . "generic_truncate_two") 63 | (TL::GENERIC-TRUNCATE-TWO-FIRST . "generic_truncate_two_first") 64 | (TL::INTEGER-DIVIDE-ERROR . "integer_divide_error") 65 | (TL:INTEGER-LENGTH . "integer_length") 66 | (TL:ISQRT . "isqrt") 67 | (TL:LOGCOUNT . "logcount") 68 | (TL::MATH-ONE-ARG-TYPE-ERROR . "math_one_arg_type_error") 69 | (TL::MATH-TYPE-ERROR . "math_type_error") 70 | (TL:MOD-FIXNUMS . "mod_fixnums") 71 | (TL:MOD-FLOAT . "mod_float")) 72 | ;; Used variables = (symbol c-name . type). 73 | '((*PACKAGE* "SpackageS" . OBJ)) 74 | ;; Defined variables 75 | NIL 76 | ;; Used class typedefs. 77 | NIL 78 | ) 79 | -------------------------------------------------------------------------------- /tl/c/generic-prim.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/generic-prim.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/generic-prim.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "generic-prim.h" 14 | 15 | 16 | static const Str_5 str_const 17 | = { 7, 2, 2, "TL" }; 18 | 19 | static const Str_41 str_const_1 20 | = { 7, 39, 39, "Unrecognized array-type of ~s for AREF." }; 21 | 22 | /* Translated from GENERIC-AREF(T FIXNUM) = T */ 23 | 24 | Obj generic_aref (Obj array, sint32 index) 25 | { 26 | sint32 temp; 27 | 28 | switch (TYPE_TAG(array,temp)) { 29 | case 6: 30 | return ((Sv *)array)->body[index]; 31 | case 7: 32 | return BOXCHAR(((Str *)array)->body[index]); 33 | case 8: 34 | return BOXFIX(((Sa_uint8 *)array)->body[index]); 35 | case 9: 36 | return BOXFIX(((Sa_uint16 *)array)->body[index]); 37 | case 18: 38 | return BOXFIX(((Sa_sint16 *)array)->body[index]); 39 | case 10: 40 | return alloc_ldouble(((Sa_double *)array)->body[index],-1,5); 41 | default: 42 | return error_one_arg((Obj)(&str_const_1), /* "Unrecognized array-type of ~s for AREF." */ 43 | array); 44 | } 45 | } 46 | 47 | static const Str_45 str_const_2 48 | = { 7, 43, 43, "Unrecognized array-type of ~s for SET-AREF." }; 49 | 50 | /* Translated from GENERIC-SET-AREF(T FIXNUM T) = T */ 51 | 52 | Obj generic_set_aref (Obj array, sint32 index, Obj value) 53 | { 54 | sint32 temp; 55 | 56 | switch (TYPE_TAG(array,temp)) { 57 | case 6: 58 | (((Sv *)array)->body[index]) = value; 59 | break; 60 | case 7: 61 | (((Str *)array)->body[index]) = UNBOXCHAR(value); 62 | break; 63 | case 8: 64 | (((Sa_uint8 *)array)->body[index]) = (uint8)UNBOXFIX(value); 65 | break; 66 | case 9: 67 | (((Sa_uint16 *)array)->body[index]) = (uint16)UNBOXFIX(value); 68 | break; 69 | case 18: 70 | (((Sa_sint16 *)array)->body[index]) = (sint16)UNBOXFIX(value); 71 | break; 72 | case 10: 73 | (((Sa_double *)array)->body[index]) = (((Ldouble *)value)->body); 74 | break; 75 | default: 76 | error_one_arg((Obj)(&str_const_2), /* "Unrecognized array-type of ~s for SET-AREF." */ 77 | array); 78 | break; 79 | } 80 | return value; 81 | } 82 | 83 | static const Str_45 str_const_3 84 | = { 7, 41, 41, "Unrecognized sequence type of ~s for ELT." }; 85 | 86 | /* Translated from GENERIC-ELT(T FIXNUM) = T */ 87 | 88 | Obj generic_elt (Obj sequence, sint32 index) 89 | { 90 | sint32 temp; 91 | 92 | switch (TYPE_TAG(sequence,temp)) { 93 | case 0: 94 | case 2: 95 | return nth(index,sequence); 96 | case 6: 97 | return ((Sv *)sequence)->body[index]; 98 | case 7: 99 | return BOXCHAR(((Str *)sequence)->body[index]); 100 | case 8: 101 | return BOXFIX(((Sa_uint8 *)sequence)->body[index]); 102 | case 9: 103 | return BOXFIX(((Sa_uint16 *)sequence)->body[index]); 104 | case 18: 105 | return BOXFIX(((Sa_sint16 *)sequence)->body[index]); 106 | case 10: 107 | return alloc_ldouble(((Sa_double *)sequence)->body[index],-1,5); 108 | default: 109 | return error_one_arg((Obj)(&str_const_3), /* "Unrecognized sequence type of ~s for ELT." */ 110 | sequence); 111 | } 112 | } 113 | 114 | static const Str_49 str_const_4 115 | = { 7, 45, 45, "Unrecognized sequence type of ~s for SET-ELT." }; 116 | 117 | /* Translated from GENERIC-SET-ELT(T FIXNUM T) = T */ 118 | 119 | Obj generic_set_elt (Obj sequence, sint32 index, Obj value) 120 | { 121 | sint32 temp; 122 | 123 | switch (TYPE_TAG(sequence,temp)) { 124 | case 0: 125 | case 2: 126 | CAR(nthcdr(index,sequence)) = value; 127 | break; 128 | case 6: 129 | (((Sv *)sequence)->body[index]) = value; 130 | break; 131 | case 7: 132 | (((Str *)sequence)->body[index]) = UNBOXCHAR(value); 133 | break; 134 | case 8: 135 | (((Sa_uint8 *)sequence)->body[index]) = (uint8)UNBOXFIX(value); 136 | break; 137 | case 9: 138 | (((Sa_uint16 *)sequence)->body[index]) = (uint16)UNBOXFIX(value); 139 | break; 140 | case 18: 141 | (((Sa_sint16 *)sequence)->body[index]) = (sint16)UNBOXFIX(value); 142 | break; 143 | case 10: 144 | (((Sa_double *)sequence)->body[index]) = (((Ldouble *)value)->body); 145 | break; 146 | default: 147 | error_one_arg((Obj)(&str_const_4), /* "Unrecognized sequence type of ~s for SET-ELT." */ 148 | sequence); 149 | break; 150 | } 151 | return value; 152 | } 153 | 154 | /* Translated from SYMS-TL-GENERIC-PRIM() = VOID */ 155 | 156 | void syms_tl_generic_prim (void) 157 | { 158 | return; 159 | } 160 | 161 | 162 | /* Translated from INIT-TL-GENERIC-PRIM() = VOID */ 163 | 164 | void init_tl_generic_prim (void) 165 | { 166 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL" */ 167 | return; 168 | } 169 | 170 | -------------------------------------------------------------------------------- /tl/c/generic-prim.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/generic-prim.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/generic-prim.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[41]; 25 | } Str_41; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[45]; 32 | } Str_45; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[49]; 39 | } Str_49; 40 | 41 | extern Obj SpackageS; 42 | 43 | extern Obj error_one_arg(Obj, Obj); 44 | extern Obj find_package_1(Obj); 45 | extern Obj nth(sint32, Obj); 46 | extern Obj nthcdr(sint32, Obj); 47 | -------------------------------------------------------------------------------- /tl/c/generic-prim.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/generic-prim.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/generic-prim.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::ERROR-ONE-ARG "error_one_arg" FUNCTION (T T) NULL) 24 | (TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 25 | (TL:NTH "nth" FUNCTION (FIXNUM LIST) T) 26 | (TL:NTHCDR "nthcdr" FUNCTION (FIXNUM LIST) T)) 27 | ;; Defined functions. 28 | '((TL::GENERIC-AREF . "generic_aref") 29 | (TL::GENERIC-ELT . "generic_elt") 30 | (TL::GENERIC-SET-AREF . "generic_set_aref") 31 | (TL::GENERIC-SET-ELT . "generic_set_elt")) 32 | ;; Used variables = (symbol c-name . type). 33 | '((*PACKAGE* "SpackageS" . OBJ)) 34 | ;; Defined variables 35 | NIL 36 | ;; Used class typedefs. 37 | NIL 38 | ) 39 | -------------------------------------------------------------------------------- /tl/c/inline.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/inline.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/inline.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "inline.h" 14 | 15 | 16 | static const Str_5 str_const 17 | = { 7, 2, 2, "TL" }; 18 | 19 | /* Translated from EQL(T T) = T */ 20 | 21 | Obj eql (Obj a, Obj b) 22 | { 23 | if ((a==b) || ((((a!=NULL) && ((IMMED_TAG(a)==0) && (STD_TAG(a)==5))) /* DOUBLE-FLOAT-P */ 24 | && ((b!=NULL) && ((IMMED_TAG(b)==0) && (STD_TAG(b)==5)))) /* DOUBLE-FLOAT-P */ 25 | && (((Ldouble *)a)->body==(((Ldouble *)b)->body)))) 26 | return (Obj)(&T); 27 | else 28 | return (Obj)NULL; 29 | } 30 | 31 | Obj symbol_plist_of_nil = (Obj)(&Unbound); 32 | 33 | /* Translated from SYMS-TL-INLINE() = VOID */ 34 | 35 | void syms_tl_inline (void) 36 | { 37 | return; 38 | } 39 | 40 | 41 | /* Translated from INIT-TL-INLINE() = VOID */ 42 | 43 | void init_tl_inline (void) 44 | { 45 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL" */ 46 | if (symbol_plist_of_nil==(Obj)(&Unbound)) 47 | symbol_plist_of_nil = (Obj)NULL; 48 | return; 49 | } 50 | 51 | -------------------------------------------------------------------------------- /tl/c/inline.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/inline.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/inline.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | extern Obj SpackageS; 21 | 22 | extern Obj find_package_1(Obj); 23 | -------------------------------------------------------------------------------- /tl/c/inline.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/inline.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/inline.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 24 | ;; Defined functions. 25 | '((TL:EQL . "eql")) 26 | ;; Used variables = (symbol c-name . type). 27 | '((*PACKAGE* "SpackageS" . OBJ)) 28 | ;; Defined variables 29 | '((SYMBOL-PLIST-OF-NIL . "symbol_plist_of_nil")) 30 | ;; Used class typedefs. 31 | NIL 32 | ) 33 | -------------------------------------------------------------------------------- /tl/c/input.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/input.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/input.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[45]; 25 | } Str_45; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[49]; 32 | } Str_49; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[109]; 39 | } Str_109; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[41]; 46 | } Str_41; 47 | 48 | typedef struct { 49 | unsigned int type : 8; 50 | unsigned int length : 24; 51 | unsigned int fill_length: 24; 52 | unsigned char body[69]; 53 | } Str_69; 54 | 55 | typedef struct { 56 | unsigned int type : 8; 57 | unsigned int length : 24; 58 | unsigned int fill_length: 24; 59 | unsigned char body[53]; 60 | } Str_53; 61 | 62 | typedef struct { 63 | unsigned int type : 8; 64 | unsigned int length : 24; 65 | unsigned int fill_length: 24; 66 | unsigned char body[25]; 67 | } Str_25; 68 | 69 | typedef struct { 70 | unsigned int type : 8; 71 | unsigned int length : 24; 72 | unsigned int fill_length: 24; 73 | unsigned char body[125]; 74 | } Str_125; 75 | 76 | typedef struct { 77 | unsigned int type : 8; 78 | unsigned int length : 24; 79 | unsigned int fill_length: 24; 80 | unsigned char body[105]; 81 | } Str_105; 82 | 83 | typedef struct { 84 | unsigned int type : 8; 85 | unsigned int length : 24; 86 | unsigned int fill_length: 24; 87 | unsigned char body[9]; 88 | } Str_9; 89 | 90 | typedef struct { 91 | unsigned int type : 8; 92 | unsigned int length : 24; 93 | unsigned int fill_length: 24; 94 | unsigned char body[13]; 95 | } Str_13; 96 | 97 | extern Sym tl_input_symbols[5]; 98 | 99 | extern Obj SpackageS; 100 | 101 | extern Obj Sterminal_ioS; 102 | 103 | extern sint32 delete_named_file(char *); 104 | extern Obj error_one_arg(Obj, Obj); 105 | extern Obj error_or_value(Obj, Obj, Obj); 106 | extern Obj error_two_args(Obj, Obj, Obj); 107 | extern Obj find_package_1(Obj); 108 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 109 | -------------------------------------------------------------------------------- /tl/c/input.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/input.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/input.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | "tl_input_symbols" 14 | ;; Quoted symbols defined in this file. 15 | `(:ERROR 16 | :CREATE 17 | :OVERWRITE 18 | :SUPERSEDE 19 | :APPEND) 20 | ;; Used compiled-functions = (name func-array . index). 21 | NIL 22 | ;; Name for this file's array of compiled-functions. 23 | NIL 24 | ;; Compiled-function objects defined in this file. 25 | NIL 26 | ;; Used function type signatures. 27 | '((TL::ERROR-ONE-ARG "error_one_arg" FUNCTION (T T) NULL) 28 | (TL::ERROR-TWO-ARGS "error_two_args" FUNCTION (T T T) NULL) 29 | (TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 30 | ;; Defined functions. 31 | '((TL::ANALYZE-FILE-STREAM-ERROR . "analyze_file_stream_error") 32 | (TL::CREATE-FILE . "create_file") 33 | (TL::ERROR-OR-VALUE . "error_or_value") 34 | (TL::GENERIC-CLOSE . "generic_close") 35 | (TL::GENERIC-READ-CHAR . "generic_read_char") 36 | (TL::GENERIC-READ-LINE . "generic_read_line") 37 | (TL::OPEN-FOR-BINARY-INPUT . "open_for_binary_input") 38 | (TL::OPEN-FOR-BINARY-OUTPUT . "open_for_binary_output") 39 | (TL::OPEN-FOR-TEXT-INPUT . "open_for_text_input") 40 | (TL::OPEN-FOR-TEXT-OUTPUT . "open_for_text_output") 41 | (TL::READ-FROM-STRING-1 . "read_from_string_1") 42 | (TL:READ-LINE-FROM-FILE-STREAM . "read_line_from_file_stream") 43 | (TL:READ-LINE-FROM-STRING-STREAM . "read_line_from_string_stream")) 44 | ;; Used variables = (symbol c-name . type). 45 | '((*PACKAGE* "SpackageS" . OBJ) 46 | (*TERMINAL-IO* "Sterminal_ioS" . OBJ)) 47 | ;; Defined variables 48 | '((TL::*INPUT-STRING-BUFFER* . "Sinput_string_bufferS") 49 | (TL::*INPUT-STRING-BUFFER-SIZE* . "Sinput_string_buffer_sizeS")) 50 | ;; Used class typedefs. 51 | NIL 52 | ) 53 | -------------------------------------------------------------------------------- /tl/c/loop.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/loop.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/loop.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "loop.h" 14 | 15 | 16 | static const Str_5 str_const 17 | = { 7, 2, 2, "TL" }; 18 | 19 | /* Translated from SYMS-TL-LOOP() = VOID */ 20 | 21 | void syms_tl_loop (void) 22 | { 23 | return; 24 | } 25 | 26 | 27 | /* Translated from INIT-TL-LOOP() = VOID */ 28 | 29 | void init_tl_loop (void) 30 | { 31 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL" */ 32 | return; 33 | } 34 | 35 | -------------------------------------------------------------------------------- /tl/c/loop.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/loop.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/loop.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | extern Obj SpackageS; 21 | 22 | extern Obj find_package_1(Obj); 23 | -------------------------------------------------------------------------------- /tl/c/loop.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/loop.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/loop.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 24 | ;; Defined functions. 25 | NIL 26 | ;; Used variables = (symbol c-name . type). 27 | '((*PACKAGE* "SpackageS" . OBJ)) 28 | ;; Defined variables 29 | NIL 30 | ;; Used class typedefs. 31 | NIL 32 | ) 33 | -------------------------------------------------------------------------------- /tl/c/makefile-cygnus: -------------------------------------------------------------------------------- 1 | # 2 | # TL Cygnus Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = gcc -o 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += -pipe -ansi -pedantic -W -Wall -c 21 | 22 | ARCHIVE = ar rsc 23 | OBJECTS = tl.o boot.o stubs.o tl-types.o \ 24 | inline.o tl-prim.o do.o format.o input.o \ 25 | tl-basics.o loop.o apply.o generic-math.o generic-prim.o \ 26 | packages.o tl-util.o versions.o forward.o tl-extension.o \ 27 | tl-time.o 28 | 29 | all : libtl.a 30 | 31 | clean : 32 | -rm *.o 33 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 34 | 35 | libtl.a : makefile-cygnus $(OBJECTS) $(LIBS) 36 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 37 | $(ARCHIVE) libtl.a $(OBJECTS) 38 | 39 | %.o : ../c/%.c ../c/%.h makefile-cygnus ../c/tl.h 40 | $(CC) $@ $(CFLAGS) -I ../c $< 41 | -------------------------------------------------------------------------------- /tl/c/makefile-freebsd: -------------------------------------------------------------------------------- 1 | # 2 | # TL Freebsd Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = gcc -o 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += -pipe -ansi -pedantic -W -Wall -c 21 | 22 | ARCHIVE = ar rsc 23 | OBJECTS = tl.o boot.o stubs.o tl-types.o \ 24 | inline.o tl-prim.o do.o format.o input.o \ 25 | tl-basics.o loop.o apply.o generic-math.o generic-prim.o \ 26 | packages.o tl-util.o versions.o forward.o tl-extension.o \ 27 | tl-time.o 28 | 29 | all : libtl.a 30 | 31 | clean : 32 | -rm *.o 33 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 34 | 35 | libtl.a : makefile-freebsd $(OBJECTS) $(LIBS) 36 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 37 | $(ARCHIVE) libtl.a $(OBJECTS) 38 | 39 | %.o : ../c/%.c ../c/%.h makefile-freebsd ../c/tl.h 40 | $(CC) $@ $(CFLAGS) -I ../c $< 41 | -------------------------------------------------------------------------------- /tl/c/makefile-linux: -------------------------------------------------------------------------------- 1 | # 2 | # TL Linux Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = gcc -o 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += -pipe -ansi -pedantic -W -Wall -c 21 | 22 | ARCHIVE = ar rsc 23 | OBJECTS = tl.o boot.o stubs.o tl-types.o \ 24 | inline.o tl-prim.o do.o format.o input.o \ 25 | tl-basics.o loop.o apply.o generic-math.o generic-prim.o \ 26 | packages.o tl-util.o versions.o forward.o tl-extension.o \ 27 | tl-time.o 28 | 29 | all : libtl.a 30 | 31 | clean : 32 | -rm *.o 33 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 34 | 35 | libtl.a : makefile-linux $(OBJECTS) $(LIBS) 36 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 37 | $(ARCHIVE) libtl.a $(OBJECTS) 38 | 39 | %.o : ../c/%.c ../c/%.h makefile-linux ../c/tl.h 40 | $(CC) $@ $(CFLAGS) -I ../c $< 41 | -------------------------------------------------------------------------------- /tl/c/makefile-macosx: -------------------------------------------------------------------------------- 1 | # 2 | # TL Macosx Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = cc -o 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += -pipe -ansi -pedantic -W -Wall -c 21 | 22 | ARCHIVE = ar -r -c -u 23 | OBJECTS = tl.o boot.o stubs.o tl-types.o \ 24 | inline.o tl-prim.o do.o format.o input.o \ 25 | tl-basics.o loop.o apply.o generic-math.o generic-prim.o \ 26 | packages.o tl-util.o versions.o forward.o tl-extension.o \ 27 | tl-time.o 28 | 29 | all : libtl.a 30 | 31 | clean : 32 | -rm *.o 33 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 34 | 35 | libtl.a : makefile-macosx $(OBJECTS) $(LIBS) 36 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 37 | $(ARCHIVE) libtl.a $(OBJECTS) 38 | ranlib libtl.a 39 | 40 | %.o : ../c/%.c ../c/%.h makefile-macosx ../c/tl.h 41 | $(CC) $@ $(CFLAGS) -I ../c $< 42 | -------------------------------------------------------------------------------- /tl/c/makefile.config: -------------------------------------------------------------------------------- 1 | # 2 | # TL Config Makefile 3 | # 4 | # Copyright (c) 2001 The ThinLisp Group 5 | 6 | CC = @CC@ 7 | 8 | CFLAGS = 9 | 10 | ifdef THREAD 11 | CFLAGS += -DPTHREAD 12 | endif 13 | 14 | ifdef OPT 15 | CFLAGS += -O2 -fomit-frame-pointer 16 | else 17 | CFLAGS += -ggdb3 18 | endif 19 | 20 | CFLAGS += @CFLAGS@ -pipe -ansi -pedantic -W -Wall -c 21 | 22 | ARCHIVE = ar rsc 23 | OBJECTS = tl.o boot.o stubs.o tl-types.o \ 24 | inline.o tl-prim.o do.o format.o input.o \ 25 | tl-basics.o loop.o apply.o generic-math.o generic-prim.o \ 26 | packages.o tl-util.o versions.o forward.o tl-extension.o \ 27 | tl-time.o 28 | 29 | all : libtl.a 30 | 31 | clean : 32 | -rm *.o 33 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 34 | 35 | libtl.a : makefile.config $(OBJECTS) $(LIBS) 36 | -( if [ -f libtl.a ] ; then rm libtl.a ; fi ) 37 | $(ARCHIVE) libtl.a $(OBJECTS) 38 | 39 | %.o : ../c/%.c ../c/%.h makefile.config ../c/tl.h 40 | $(CC) $@ $(CFLAGS) -I ../c $< 41 | -------------------------------------------------------------------------------- /tl/c/packages.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/packages.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/packages.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[65]; 25 | } Str_65; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[37]; 32 | } Str_37; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[41]; 39 | } Str_41; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[101]; 46 | } Str_101; 47 | 48 | typedef struct { 49 | unsigned int type : 8; 50 | unsigned int length : 24; 51 | unsigned int fill_length: 24; 52 | unsigned char body[113]; 53 | } Str_113; 54 | 55 | typedef struct { 56 | unsigned int type : 8; 57 | unsigned int length : 24; 58 | unsigned int fill_length: 24; 59 | unsigned char body[105]; 60 | } Str_105; 61 | 62 | typedef struct { 63 | unsigned int type : 8; 64 | unsigned int length : 24; 65 | unsigned int fill_length: 24; 66 | unsigned char body[57]; 67 | } Str_57; 68 | 69 | typedef struct { 70 | unsigned int type : 8; 71 | unsigned int length : 24; 72 | unsigned int fill_length: 24; 73 | unsigned char body[9]; 74 | } Str_9; 75 | 76 | typedef struct { 77 | unsigned int type : 8; 78 | unsigned int length : 24; 79 | unsigned int fill_length: 24; 80 | unsigned char body[13]; 81 | } Str_13; 82 | 83 | extern Sym tl_packages_symbols[3]; 84 | 85 | extern Obj SpackageS; 86 | 87 | extern Obj Sprint_escapeS; 88 | 89 | extern Obj Sstandard_outputS; 90 | 91 | extern Obj Sterminal_ioS; 92 | 93 | extern Obj current_region; 94 | 95 | extern Sym tl_format_symbols[]; 96 | 97 | extern Obj error_one_arg(Obj, Obj); 98 | extern Obj error_three_args(Obj, Obj, Obj, Obj); 99 | extern Obj error_two_args(Obj, Obj, Obj); 100 | extern Obj find_package_1(Obj); 101 | extern Obj format_function(Obj, unsigned char *, Obj); 102 | extern sint32 generic_set_fill_pointer(Obj, sint32); 103 | extern Obj get_string_or_file_stream_for_output(Obj, sint32); 104 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 105 | extern void insert_symbol_into_package(Obj, Obj); 106 | extern unsigned char * string_upcase_function(unsigned char *, sint32, 107 | Obj); 108 | extern unsigned char * write_string_function(unsigned char *, Obj, sint32, 109 | Obj); 110 | -------------------------------------------------------------------------------- /tl/c/packages.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/packages.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/packages.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | '((:DOWNCASE "tl_format_symbols" . 1) 12 | (:UPCASE "tl_format_symbols" . 0)) 13 | ;; Name for this file's array of quoted symbols. 14 | "tl_packages_symbols" 15 | ;; Quoted symbols defined in this file. 16 | `(:INHERITED 17 | :EXTERNAL 18 | :INTERNAL) 19 | ;; Used compiled-functions = (name func-array . index). 20 | NIL 21 | ;; Name for this file's array of compiled-functions. 22 | NIL 23 | ;; Compiled-function objects defined in this file. 24 | NIL 25 | ;; Used function type signatures. 26 | '((TL::ERROR-ONE-ARG "error_one_arg" FUNCTION (T T) NULL) 27 | (TL::ERROR-THREE-ARGS "error_three_args" FUNCTION (T T T T) NULL) 28 | (TL::ERROR-TWO-ARGS "error_two_args" FUNCTION (T T T) NULL) 29 | (TL::FORMAT-FUNCTION "format_function" FUNCTION (T STRING T) T) 30 | (TL::GET-STRING-OR-FILE-STREAM-FOR-OUTPUT "get_string_or_file_stream_for_output" FUNCTION (T FIXNUM) T) 31 | (TL::STRING-UPCASE-FUNCTION "string_upcase_function" FUNCTION (STRING FIXNUM T) STRING) 32 | (TL::WRITE-STRING-FUNCTION "write_string_function" FUNCTION (STRING T FIXNUM T) STRING)) 33 | ;; Defined functions. 34 | '((TL::EXPORT . "export") 35 | (TL::FIND-PACKAGE-1 . "find_package_1") 36 | (TL::FIND-PACKAGE-OR-ERROR-1 . "find_package_or_error_1") 37 | (TL::FIND-SYMBOL-IN-PACKAGE . "find_symbol_in_package") 38 | (TL::FIND-SYMBOL-IN-SINGLE-PACKAGE . "find_symbol_in_single_package") 39 | (TL::IMPORT . "import") 40 | (INIT-SYMBOL . "init_symbol") 41 | (INIT-SYMBOL-INTO-PACKAGE . "init_symbol_into_package") 42 | (TL::INSERT-SYMBOL-INTO-PACKAGE . "insert_symbol_into_package") 43 | (TL::INTERN-STRING-IN-PACKAGE . "intern_string_in_package") 44 | (TL:LIST-ALL-PACKAGES . "list_all_packages") 45 | (TL::MAKE-GENSYMED-SYMBOL . "make_gensymed_symbol") 46 | (TL::MAKE-PACKAGE-1 . "make_package_1") 47 | (TL:SXHASH-STRING . "sxhash_string") 48 | (TL::WRITE-SYMBOL . "write_symbol")) 49 | ;; Used variables = (symbol c-name . type). 50 | '((*PRINT-ESCAPE* "Sprint_escapeS" . OBJ) 51 | (*STANDARD-OUTPUT* "Sstandard_outputS" . OBJ) 52 | (*TERMINAL-IO* "Sterminal_ioS" . OBJ) 53 | (CURRENT-REGION "current_region" . OBJ)) 54 | ;; Defined variables 55 | '((TL:*GENSYM-COUNTER* . "Sgensym_counterS") 56 | (TL::*KEYWORD-PACKAGE* . "Skeyword_packageS") 57 | (*PACKAGE* . "SpackageS") 58 | (TL::ALL-PACKAGES . "all_packages")) 59 | ;; Used class typedefs. 60 | NIL 61 | ) 62 | -------------------------------------------------------------------------------- /tl/c/stubs.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/stubs.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/stubs.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "stubs.h" 14 | 15 | 16 | static const Str_5 str_const 17 | = { 7, 2, 2, "TL" }; 18 | 19 | /* Translated from EQ(T T) = T */ 20 | 21 | Obj eq (Obj x, Obj y) 22 | { 23 | return (x==y) ? ((Obj)(&T)) : (Obj)NULL; 24 | } 25 | 26 | /* Translated from CAR(LIST) = T */ 27 | 28 | Obj car (Obj x) 29 | { 30 | return (x!=NULL) ? CAR(x) : (Obj)NULL; 31 | } 32 | 33 | /* Translated from CDR(LIST) = T */ 34 | 35 | Obj cdr (Obj x) 36 | { 37 | return (x!=NULL) ? CDR(x) : (Obj)NULL; 38 | } 39 | 40 | Obj c_native_clock_ticks_per_second = (Obj)(&Unbound); 41 | 42 | Obj maximum_backtrace_depth = (Obj)(&Unbound); 43 | 44 | Obj def_foreign_function = (Obj)(&Unbound); 45 | 46 | /* Translated from SYMS-TL-STUBS() = VOID */ 47 | 48 | void syms_tl_stubs (void) 49 | { 50 | return; 51 | } 52 | 53 | 54 | /* Translated from INIT-TL-STUBS() = VOID */ 55 | 56 | void init_tl_stubs (void) 57 | { 58 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL" */ 59 | if (c_native_clock_ticks_per_second==(Obj)(&Unbound)) 60 | c_native_clock_ticks_per_second = BOXFIX(60); 61 | if (maximum_backtrace_depth==(Obj)(&Unbound)) 62 | maximum_backtrace_depth = BOXFIX(50); 63 | if (def_foreign_function==(Obj)(&Unbound)) 64 | def_foreign_function = BOXFIX(0); 65 | return; 66 | } 67 | 68 | -------------------------------------------------------------------------------- /tl/c/stubs.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/stubs.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/stubs.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | extern Obj SpackageS; 21 | 22 | extern Obj find_package_1(Obj); 23 | -------------------------------------------------------------------------------- /tl/c/stubs.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/stubs.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/stubs.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 24 | ;; Defined functions. 25 | '((TL:CAR . "car") 26 | (TL:CDR . "cdr") 27 | (TL:EQ . "eq")) 28 | ;; Used variables = (symbol c-name . type). 29 | '((*PACKAGE* "SpackageS" . OBJ)) 30 | ;; Defined variables 31 | '((TL::C-NATIVE-CLOCK-TICKS-PER-SECOND . "c_native_clock_ticks_per_second") 32 | (TL::DEF-FOREIGN-FUNCTION . "def_foreign_function") 33 | (TL::MAXIMUM-BACKTRACE-DEPTH . "maximum_backtrace_depth")) 34 | ;; Used class typedefs. 35 | NIL 36 | ) 37 | -------------------------------------------------------------------------------- /tl/c/tl-basics.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/tl-basics.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/tl-basics.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[41]; 25 | } Str_41; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[45]; 32 | } Str_45; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[49]; 39 | } Str_49; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[33]; 46 | } Str_33; 47 | 48 | typedef struct { 49 | unsigned int type : 8; 50 | unsigned int length : 24; 51 | unsigned int fill_length: 24; 52 | unsigned char body[53]; 53 | } Str_53; 54 | 55 | typedef struct { 56 | unsigned int type : 8; 57 | unsigned int length : 24; 58 | unsigned int fill_length: 24; 59 | unsigned char body[57]; 60 | } Str_57; 61 | 62 | typedef struct { 63 | unsigned int type : 8; 64 | unsigned int length : 24; 65 | unsigned int fill_length: 24; 66 | unsigned char body[9]; 67 | } Str_9; 68 | 69 | extern Obj SpackageS; 70 | 71 | extern Obj eql(Obj, Obj); 72 | extern Obj equal(Obj, Obj); 73 | extern Obj error_one_arg(Obj, Obj); 74 | extern Obj find_package_1(Obj); 75 | extern Obj last(Obj); 76 | extern sint32 length(Obj); 77 | -------------------------------------------------------------------------------- /tl/c/tl-basics.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/tl-basics.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/tl-basics.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::ERROR-ONE-ARG "error_one_arg" FUNCTION (T T) NULL) 24 | (TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 25 | (TL:LAST "last" FUNCTION (LIST) LIST)) 26 | ;; Defined functions. 27 | '((TL::APPEND-FUNCTION . "append_function") 28 | (TL:ARRAY-HAS-FILL-POINTER-P . "array_has_fill_pointer_p") 29 | (TL:ASSOC-EQL . "assoc_eql") 30 | (TL:ASSOC-EQUAL . "assoc_equal") 31 | (TL:ASSQ . "assq") 32 | (TL::BOUNDED-STRING-COMPARE . "bounded_string_compare") 33 | (TL::COERCE-TO-STRING . "coerce_to_string") 34 | (TL:COPY-LIST . "copy_list") 35 | (TL::DELETE-EQL . "delete_eql") 36 | (TL::DELETE-EQUAL . "delete_equal") 37 | (TL:DELQ . "delq") 38 | (TL::ENDP-ERROR-FUNCTION . "endp_error_function") 39 | (TL:EQUAL . "equal") 40 | (GENERIC-ARRAY-DIMENSION . "generic_array_dimension") 41 | (GENERIC-FILL-POINTER . "generic_fill_pointer") 42 | (GENERIC-SET-FILL-POINTER . "generic_set_fill_pointer") 43 | (TL:IDENTITY . "identity") 44 | (TL:LENGTH . "length") 45 | (TL:LISP-IMPLEMENTATION-TYPE . "lisp_implementation_type") 46 | (TL:LISP-IMPLEMENTATION-VERSION . "lisp_implementation_version") 47 | (TL::MEMBER-EQL . "member_eql") 48 | (TL:MEMBER-EQUAL . "member_equal") 49 | (TL:MEMQ . "memq") 50 | (TL::NCONC-1 . "nconc_1") 51 | (TL:NRECONC . "nreconc") 52 | (TL:NTH . "nth") 53 | (TL:NTHCDR . "nthcdr") 54 | (TL::STRING-ARG-INVALID . "string_arg_invalid") 55 | (TL:STRING-EQUAL . "string_equal") 56 | (TL:STRING-GREATERP . "string_greaterp") 57 | (TL::STRING-LESSP . "string_lessp") 58 | (TL::WRITE-CHAR-INTO-STRING . "write_char_into_string") 59 | (TL::WRITE-STRING-INTO-STRING . "write_string_into_string")) 60 | ;; Used variables = (symbol c-name . type). 61 | '((*PACKAGE* "SpackageS" . OBJ)) 62 | ;; Defined variables 63 | NIL 64 | ;; Used class typedefs. 65 | NIL 66 | ) 67 | -------------------------------------------------------------------------------- /tl/c/tl-extension.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/tl-extension.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/tl-extension.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[9]; 25 | } Str_9; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[125]; 32 | } Str_125; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[77]; 39 | } Str_77; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[113]; 46 | } Str_113; 47 | 48 | typedef struct { 49 | unsigned int type : 8; 50 | unsigned int length : 24; 51 | unsigned int fill_length: 24; 52 | unsigned char body[121]; 53 | } Str_121; 54 | 55 | extern Obj SpackageS; 56 | 57 | extern Obj find_package_1(Obj); 58 | extern Obj generic_fceiling_one(Obj); 59 | extern Obj generic_ffloor_one(Obj); 60 | extern Obj memq(Obj, Obj); 61 | extern sint32 two_arg_gcdf(sint32, sint32); 62 | extern unsigned char write_char(unsigned char, Obj); 63 | extern sint32 write_fixnum(sint32, sint32, sint32, Obj); 64 | extern unsigned char * write_string_function(unsigned char *, Obj, sint32, 65 | Obj); 66 | -------------------------------------------------------------------------------- /tl/c/tl-extension.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/tl-extension.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/tl-extension.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 24 | (TL:MEMQ "memq" FUNCTION (T LIST) T) 25 | (TL:WRITE-CHAR "write_char" FUNCTION (CHARACTER &OPTIONAL T) CHARACTER) 26 | (TL::WRITE-FIXNUM "write_fixnum" FUNCTION (FIXNUM FIXNUM FIXNUM T) FIXNUM) 27 | (TL::WRITE-STRING-FUNCTION "write_string_function" FUNCTION (STRING T FIXNUM T) STRING)) 28 | ;; Defined functions. 29 | '((TL::COERCE-TO-DOUBLE-FLOAT-FUNCTION . "coerce_to_double_float_function") 30 | (TL::EQ-OR-MEMQ . "eq_or_memq") 31 | (TL:FTRUNCATEE-UP . "ftruncatee_up") 32 | (TL::GETFQ-FUNCTION . "getfq_function") 33 | (TL::GETFQ-FUNCTION-NO-DEFAULT . "getfq_function_no_default") 34 | (TL::PRINT-RANDOM-OBJECT-PREFIX . "print_random_object_prefix") 35 | (TL::PRINT-RANDOM-OBJECT-SUFFIX . "print_random_object_suffix") 36 | (TL:REM-FIXNUMS . "rem_fixnums") 37 | (TL:TRUNCATEF-FIRST . "truncatef_first") 38 | (TL::TWO-ARG-GCDF . "two_arg_gcdf") 39 | (TL::TWO-ARG-LCMF . "two_arg_lcmf") 40 | (TL::VALIDATE-FIXNUM-ASSUMPTIONS . "validate_fixnum_assumptions")) 41 | ;; Used variables = (symbol c-name . type). 42 | '((*PACKAGE* "SpackageS" . OBJ)) 43 | ;; Defined variables 44 | '((TL::COMPILE-TIME-MOST-POSITIVE-FIXNUM . "compile_time_most_positive_fixnum") 45 | (TL::DEBUG-1 . "debug_1") 46 | (TL::DEBUG-10 . "debug_10") 47 | (TL::DEBUG-11 . "debug_11") 48 | (TL::DEBUG-12 . "debug_12") 49 | (TL::DEBUG-2 . "debug_2") 50 | (TL::DEBUG-3 . "debug_3") 51 | (TL::DEBUG-4 . "debug_4") 52 | (TL::DEBUG-5 . "debug_5") 53 | (TL::DEBUG-6 . "debug_6") 54 | (TL::DEBUG-7 . "debug_7") 55 | (TL::DEBUG-8 . "debug_8") 56 | (TL::DEBUG-9 . "debug_9") 57 | (TL::DESTINATION-FOR-SYMBOL-WITH-PRESERVED-CELLS . "destination_for_symbol_with_preserved_cells") 58 | (TL::FIXNUM-TEST-VALUE . "fixnum_test_value") 59 | (TL::FLOAT-TEST-VALUE . "float_test_value") 60 | (TL:KEYWORD-PACKAGE-1 . "keyword_package_1") 61 | (TL:LISP-PACKAGE-1 . "lisp_package_1") 62 | (TL::NEGATIVE-FIFTY-MILLION . "negative_fifty_million") 63 | (TL::SPECIAL-VARIABLE-FOR-USE-VALUE-MACRO . "special_variable_for_use_value_macro") 64 | (TL:WITHIN-MANAGED-OBJECT-SCOPE . "within_managed_object_scope")) 65 | ;; Used class typedefs. 66 | NIL 67 | ) 68 | -------------------------------------------------------------------------------- /tl/c/tl-files.txt: -------------------------------------------------------------------------------- 1 | tl 2 | boot 3 | stubs 4 | tl-types 5 | inline 6 | tl-prim 7 | do 8 | format 9 | input 10 | tl-basics 11 | loop 12 | apply 13 | generic-math 14 | generic-prim 15 | packages 16 | tl-util 17 | versions 18 | forward 19 | tl-extension 20 | tl-time 21 | -------------------------------------------------------------------------------- /tl/c/tl-prim.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/tl-prim.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/tl-prim.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[45]; 25 | } Str_45; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[9]; 32 | } Str_9; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[13]; 39 | } Str_13; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[21]; 46 | } Str_21; 47 | 48 | extern Sym tl_tl_prim_symbols[12]; 49 | 50 | extern Obj SpackageS; 51 | 52 | extern Obj symbol_plist_of_nil; 53 | 54 | extern Obj find_package_1(Obj); 55 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 56 | extern Obj reverse_list(Obj); 57 | extern unsigned char * reverse_string(unsigned char *); 58 | -------------------------------------------------------------------------------- /tl/c/tl-prim.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/tl-prim.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/tl-prim.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | "tl_tl_prim_symbols" 14 | ;; Quoted symbols defined in this file. 15 | `(:TL 16 | TL:AND 17 | TL:OR 18 | TL:NOT 19 | &OPTIONAL 20 | &REST 21 | &KEY 22 | &AUX 23 | &BODY 24 | &WHOLE 25 | &ALLOW-OTHER-KEYS 26 | &ENVIRONMENT) 27 | ;; Used compiled-functions = (name func-array . index). 28 | NIL 29 | ;; Name for this file's array of compiled-functions. 30 | NIL 31 | ;; Compiled-function objects defined in this file. 32 | NIL 33 | ;; Used function type signatures. 34 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 35 | ;; Defined functions. 36 | '((TL:CAAAAR . "caaaar") 37 | (TL:CAAADR . "caaadr") 38 | (TL:CAAAR . "caaar") 39 | (TL:CAADAR . "caadar") 40 | (TL:CAADDR . "caaddr") 41 | (TL:CAADR . "caadr") 42 | (TL:CAAR . "caar") 43 | (TL:CADAAR . "cadaar") 44 | (TL:CADADR . "cadadr") 45 | (TL:CADAR . "cadar") 46 | (TL:CADDAR . "caddar") 47 | (TL:CADDDR . "cadddr") 48 | (TL:CADDR . "caddr") 49 | (TL:CADR . "cadr") 50 | (TL:CDAAAR . "cdaaar") 51 | (TL:CDAADR . "cdaadr") 52 | (TL:CDAAR . "cdaar") 53 | (TL:CDADAR . "cdadar") 54 | (TL:CDADDR . "cdaddr") 55 | (TL:CDADR . "cdadr") 56 | (TL:CDAR . "cdar") 57 | (TL:CDDAAR . "cddaar") 58 | (TL:CDDADR . "cddadr") 59 | (TL:CDDAR . "cddar") 60 | (TL:CDDDAR . "cdddar") 61 | (TL:CDDDDR . "cddddr") 62 | (TL:CDDDR . "cdddr") 63 | (TL:CDDR . "cddr") 64 | (TL:EIGHTH . "eighth") 65 | (TL:EVAL-FEATURE . "eval_feature") 66 | (TL:FIFTH . "fifth") 67 | (TL:FIRST . "first") 68 | (TL:FOURTH . "fourth") 69 | (TL:GET . "get") 70 | (TL:GETF . "getf") 71 | (TL:LAST . "last") 72 | (TL:NINTH . "ninth") 73 | (TL:NREVERSE . "nreverse") 74 | (TL:REST . "rest") 75 | (TL:REVERSE . "reverse") 76 | (TL::REVERSE-LIST . "reverse_list") 77 | (TL::REVERSE-STRING . "reverse_string") 78 | (TL:SECOND . "second") 79 | (TL::SET-GET . "set_get") 80 | (TL:SEVENTH . "seventh") 81 | (TL:SIXTH . "sixth") 82 | (TL:TENTH . "tenth") 83 | (TL:THIRD . "third")) 84 | ;; Used variables = (symbol c-name . type). 85 | '((*PACKAGE* "SpackageS" . OBJ) 86 | (SYMBOL-PLIST-OF-NIL "symbol_plist_of_nil" . OBJ)) 87 | ;; Defined variables 88 | '((* . "S") 89 | (*FEATURES* . "SfeaturesS") 90 | (TL:ALL-SYSTEMS . "all_systems") 91 | (TL:CURRENT-SYSTEM-BEING-LOADED . "current_system_being_loaded") 92 | (TL:LAMBDA-LIST-KEYWORDS . "lambda_list_keywords")) 93 | ;; Used class typedefs. 94 | NIL 95 | ) 96 | -------------------------------------------------------------------------------- /tl/c/tl-time.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/tl-time.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/tl-time.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "tl-time.h" 14 | 15 | 16 | static const Str_5 str_const 17 | = { 7, 2, 2, "TL" }; 18 | 19 | /* Translated from GET-INTERNAL-REAL-TIME() = FIXNUM */ 20 | 21 | sint32 get_internal_real_time (void) 22 | { 23 | return (sint32)cronometer(); 24 | } 25 | 26 | /* Translated from GET-INTERNAL-RUN-TIME() = FIXNUM */ 27 | 28 | sint32 get_internal_run_time (void) 29 | { 30 | return (sint32)cpu_run_time(); 31 | } 32 | 33 | Obj internal_time_units_per_second = (Obj)(&Unbound); 34 | 35 | /* Translated from SLEEP(DOUBLE-FLOAT) = T */ 36 | 37 | Obj sleep_1 (double seconds) 38 | { 39 | sleep_ticks((long)(sint32)floor(seconds*(double)UNBOXFIX(GET_GLOBAL(internal_time_units_per_second)))); 40 | return (Obj)NULL; 41 | } 42 | 43 | /* Translated from SYMS-TL-TL-TIME() = VOID */ 44 | 45 | void syms_tl_tl_time (void) 46 | { 47 | return; 48 | } 49 | 50 | 51 | /* Translated from INIT-TL-TL-TIME() = VOID */ 52 | 53 | void init_tl_tl_time (void) 54 | { 55 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL" */ 56 | init_cronometer(); 57 | internal_time_units_per_second = BOXFIX(ticks_per_second()); 58 | return; 59 | } 60 | 61 | -------------------------------------------------------------------------------- /tl/c/tl-time.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/tl-time.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/tl-time.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | extern Obj SpackageS; 21 | 22 | extern Obj find_package_1(Obj); 23 | -------------------------------------------------------------------------------- /tl/c/tl-time.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/tl-time.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/tl-time.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 24 | ;; Defined functions. 25 | '((TL:GET-INTERNAL-REAL-TIME . "get_internal_real_time") 26 | (TL:GET-INTERNAL-RUN-TIME . "get_internal_run_time") 27 | (TL:SLEEP . "sleep_1")) 28 | ;; Used variables = (symbol c-name . type). 29 | '((*PACKAGE* "SpackageS" . OBJ)) 30 | ;; Defined variables 31 | '((TL:INTERNAL-TIME-UNITS-PER-SECOND . "internal_time_units_per_second")) 32 | ;; Used class typedefs. 33 | NIL 34 | ) 35 | -------------------------------------------------------------------------------- /tl/c/tl-types.c: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/tl-types.c 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/tl-types.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | #include "tl.h" 13 | #include "tl-types.h" 14 | 15 | 16 | static const Str_5 str_const 17 | = { 7, 2, 2, "TL" }; 18 | 19 | Obj current_region = (Obj)(&Unbound); 20 | 21 | Obj temporary_area_top = (Obj)(&Unbound); 22 | 23 | Obj fixnum_signed_byte_width = BOXFIX(30); 24 | 25 | Obj most_positive_fixnum = BOXFIX(536870911); 26 | 27 | Obj most_negative_fixnum = BOXFIX(-536870912); 28 | 29 | /* Translated from SYMS-TL-TL-TYPES() = VOID */ 30 | 31 | void syms_tl_tl_types (void) 32 | { 33 | return; 34 | } 35 | 36 | 37 | /* Translated from INIT-TL-TL-TYPES() = VOID */ 38 | 39 | void init_tl_tl_types (void) 40 | { 41 | SpackageS = find_package_1((Obj)(&str_const)); /* "TL" */ 42 | if (current_region==(Obj)(&Unbound)) 43 | current_region = BOXFIX(0); 44 | if (temporary_area_top==(Obj)(&Unbound)) 45 | temporary_area_top = (Obj)NULL; 46 | return; 47 | } 48 | 49 | -------------------------------------------------------------------------------- /tl/c/tl-types.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/tl-types.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/tl-types.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | extern Obj SpackageS; 21 | 22 | extern Obj find_package_1(Obj); 23 | -------------------------------------------------------------------------------- /tl/c/tl-types.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/tl-types.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/tl-types.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | NIL 14 | ;; Quoted symbols defined in this file. 15 | NIL 16 | ;; Used compiled-functions = (name func-array . index). 17 | NIL 18 | ;; Name for this file's array of compiled-functions. 19 | NIL 20 | ;; Compiled-function objects defined in this file. 21 | NIL 22 | ;; Used function type signatures. 23 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T)) 24 | ;; Defined functions. 25 | NIL 26 | ;; Used variables = (symbol c-name . type). 27 | '((*PACKAGE* "SpackageS" . OBJ)) 28 | ;; Defined variables 29 | '((CURRENT-REGION . "current_region") 30 | (TL::FIXNUM-SIGNED-BYTE-WIDTH . "fixnum_signed_byte_width") 31 | (TL:MOST-NEGATIVE-FIXNUM . "most_negative_fixnum") 32 | (TL:MOST-POSITIVE-FIXNUM . "most_positive_fixnum") 33 | (TEMPORARY-AREA-TOP . "temporary_area_top")) 34 | ;; Used class typedefs. 35 | NIL 36 | ) 37 | -------------------------------------------------------------------------------- /tl/c/tl-util.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/tl-util.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/tl-util.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[45]; 25 | } Str_45; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[41]; 32 | } Str_41; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[49]; 39 | } Str_49; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[89]; 46 | } Str_89; 47 | 48 | typedef struct { 49 | unsigned int type : 8; 50 | unsigned int length : 24; 51 | unsigned int fill_length: 24; 52 | unsigned char body[9]; 53 | } Str_9; 54 | 55 | typedef struct { 56 | unsigned int type : 8; 57 | unsigned int length : 24; 58 | unsigned int fill_length: 24; 59 | unsigned char body[13]; 60 | } Str_13; 61 | 62 | extern Sym tl_tl_util_symbols[3]; 63 | 64 | extern Func tl_tl_util_funcs[1]; 65 | 66 | extern Obj SpackageS; 67 | 68 | extern Obj current_region; 69 | 70 | extern Func tl_tl_util_funcs[]; 71 | 72 | extern Obj copy_list(Obj); 73 | extern Obj eql(Obj, Obj); 74 | extern Obj error_one_arg(Obj, Obj); 75 | extern Obj find_package_1(Obj); 76 | extern Obj generic_aref(Obj, sint32); 77 | extern Obj generic_set_aref(Obj, sint32, Obj); 78 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 79 | extern sint32 length(Obj); 80 | extern Obj nsubst_eql_ident_aux(Obj, Obj, Obj); 81 | extern Obj nthcdr(sint32, Obj); 82 | extern Obj string_equal(Obj, Obj); 83 | extern sint32 sxhash_array_16(uint16 *); 84 | extern sint32 sxhash_cons_tree(Obj); 85 | extern sint32 sxhash_double_float(double); 86 | extern sint32 sxhash_string(unsigned char *); 87 | -------------------------------------------------------------------------------- /tl/c/tl-util.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/tl-util.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/tl-util.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | NIL 12 | ;; Name for this file's array of quoted symbols. 13 | "tl_tl_util_symbols" 14 | ;; Quoted symbols defined in this file. 15 | `(:DYNAMIC 16 | :STATIC 17 | :TEMPORARY) 18 | ;; Used compiled-functions = (name func-array . index). 19 | '((TL::FLET-SEARCH-PREDICATE-IN-SEARCH-TEST-0 "tl_tl_util_funcs" . 0)) 20 | ;; Name for this file's array of compiled-functions. 21 | "tl_tl_util_funcs" 22 | ;; Compiled-function objects defined in this file. 23 | `(TL::FLET-SEARCH-PREDICATE-IN-SEARCH-TEST-0) 24 | ;; Used function type signatures. 25 | '((TL:COPY-LIST "copy_list" FUNCTION (LIST) LIST) 26 | (TL::ERROR-ONE-ARG "error_one_arg" FUNCTION (T T) NULL) 27 | (TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 28 | (TL:NTHCDR "nthcdr" FUNCTION (FIXNUM LIST) T) 29 | (TL:STRING-EQUAL "string_equal" FUNCTION (T T) T)) 30 | ;; Defined functions. 31 | '((TL::COMPUTE-NEW-PLIST . "compute_new_plist") 32 | (TL:COPY-OPTIMIZED-CONSTANT . "copy_optimized_constant") 33 | (TL:COPY-SEQ . "copy_seq") 34 | (TL:COPY-TREE . "copy_tree") 35 | (TL:EQUALP . "equalp") 36 | (TL:FILL . "fill") 37 | (TL:FILL-ARRAY-DOUBLE-FLOAT . "fill_array_double_float") 38 | (TL::FILL-ARRAY-SIGNED-BYTE-16 . "fill_array_signed_byte_16") 39 | (TL:FILL-ARRAY-UNSIGNED-BYTE-16 . "fill_array_unsigned_byte_16") 40 | (TL:FILL-ARRAY-UNSIGNED-BYTE-8 . "fill_array_unsigned_byte_8") 41 | (TL:FILL-LIST . "fill_list") 42 | (TL:FILL-SIMPLE-VECTOR . "fill_simple_vector") 43 | (TL::FLET-SEARCH-PREDICATE-IN-SEARCH-TEST-0 . "flet_search_predicate_in_search_test_0") 44 | (TL::GENERIC-POSITION . "generic_position") 45 | (TL::GENERIC-SEARCH . "generic_search") 46 | (TL::GENERIC-SORT-VECTOR . "generic_sort_vector") 47 | (TL::GENERIC-SXHASH . "generic_sxhash") 48 | (TL:LIST-LENGTH . "list_length") 49 | (TL::NON-LIST-REMOVE-ERROR . "non_list_remove_error") 50 | (TL::NSUBST-EQL-IDENT . "nsubst_eql_ident") 51 | (TL::NSUBST-EQL-IDENT-AUX . "nsubst_eql_ident_aux") 52 | (TL:PAIRLIS . "pairlis") 53 | (TL::QUICK-SORT-LIST . "quick_sort_list") 54 | (TL:REALLOC-REGION-UP-TO-LIMIT . "realloc_region_up_to_limit") 55 | (TL:REGION-BYTES-AVAILABLE . "region_bytes_available") 56 | (TL:REGION-BYTES-SIZE . "region_bytes_size") 57 | (TL:REGION-BYTES-USED . "region_bytes_used") 58 | (TL::REGION-NUMBER-OF-NAME . "region_number_of_name") 59 | (TL::SEARCH-LIST-FUNCTION . "search_list_function") 60 | (TL::SEARCH-TEST . "search_test") 61 | (TL:SUBSTITUTE . "substitute") 62 | (TL::SXHASH-ARRAY-16 . "sxhash_array_16") 63 | (TL::SXHASH-CONS-TREE . "sxhash_cons_tree") 64 | (TL::SXHASH-DOUBLE-FLOAT . "sxhash_double_float") 65 | (TL::TREE-EQUAL-TEST . "tree_equal_test") 66 | (TL:VECTORP . "vectorp")) 67 | ;; Used variables = (symbol c-name . type). 68 | '((*PACKAGE* "SpackageS" . OBJ) 69 | (CURRENT-REGION "current_region" . OBJ)) 70 | ;; Defined variables 71 | '((TL::*DECOMPOSE-FLOAT-BUFFER* . "Sdecompose_float_bufferS")) 72 | ;; Used class typedefs. 73 | NIL 74 | ) 75 | -------------------------------------------------------------------------------- /tl/c/versions.h: -------------------------------------------------------------------------------- 1 | /*** 2 | * 3 | * Module: tl/c/versions.h 4 | * 5 | * Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 6 | * 7 | * Description: Translation of tl/lisp/versions.lisp. 8 | * by ThinLisp http://www.thinlisp.org 9 | * 10 | */ 11 | 12 | 13 | typedef struct { 14 | unsigned int type : 8; 15 | unsigned int length : 24; 16 | unsigned int fill_length: 24; 17 | unsigned char body[5]; 18 | } Str_5; 19 | 20 | typedef struct { 21 | unsigned int type : 8; 22 | unsigned int length : 24; 23 | unsigned int fill_length: 24; 24 | unsigned char body[9]; 25 | } Str_9; 26 | 27 | typedef struct { 28 | unsigned int type : 8; 29 | unsigned int length : 24; 30 | unsigned int fill_length: 24; 31 | unsigned char body[45]; 32 | } Str_45; 33 | 34 | typedef struct { 35 | unsigned int type : 8; 36 | unsigned int length : 24; 37 | unsigned int fill_length: 24; 38 | unsigned char body[21]; 39 | } Str_21; 40 | 41 | typedef struct { 42 | unsigned int type : 8; 43 | unsigned int length : 24; 44 | unsigned int fill_length: 24; 45 | unsigned char body[17]; 46 | } Str_17; 47 | 48 | typedef struct { 49 | unsigned int type : 8; 50 | unsigned int length : 24; 51 | unsigned int fill_length: 24; 52 | unsigned char body[13]; 53 | } Str_13; 54 | 55 | typedef struct { 56 | unsigned int type : 8; 57 | unsigned int length : 24; 58 | unsigned int fill_length: 24; 59 | unsigned char body[25]; 60 | } Str_25; 61 | 62 | typedef struct { 63 | unsigned int type : 8; 64 | unsigned int length : 24; 65 | unsigned int fill_length: 24; 66 | unsigned char body[29]; 67 | } Str_29; 68 | 69 | extern Sym tl_versions_symbols[37]; 70 | 71 | extern Obj SpackageS; 72 | 73 | extern Obj current_region; 74 | 75 | extern Sym tl_boot_symbols[]; 76 | 77 | extern void collect_all_used_systems(Obj); 78 | extern Obj find_package_1(Obj); 79 | extern Obj find_package_or_error_1(Obj); 80 | extern Obj format_function(Obj, unsigned char *, Obj); 81 | extern Obj get(Obj, Obj, Obj); 82 | extern sint32 get_platform_code(void); 83 | extern Obj init_symbol_into_package(Obj, Obj, sint32, Obj); 84 | extern Obj intern_string_in_package(unsigned char *, sint32, Obj); 85 | extern Obj memq(Obj, Obj); 86 | extern Obj nreverse(Obj); 87 | extern Obj set_get(Obj, Obj, Obj); 88 | extern sint32 sxhash_string(unsigned char *); 89 | -------------------------------------------------------------------------------- /tl/c/versions.tlt: -------------------------------------------------------------------------------- 1 | ;;;; Module tl/c/versions.c 2 | 3 | ;;; Copyright (c) 2001 The Thinlisp Group All Rights Reserved. 4 | 5 | ;;; Translation data for tl/lisp/versions.lisp. 6 | ;;; The following is the value of the trans-data-tlt-version parameter. 7 | 2 8 | 9 | (make-trans-data 10 | ;; Used quoted symbols = (symbol symbol-array . index). 11 | '((:SYSTEM-MODULES "tl_boot_symbols" . 3) 12 | (:SYSTEM-NICKNAMES "tl_boot_symbols" . 1) 13 | (:SYSTEM-USED-SYSTEMS "tl_boot_symbols" . 2)) 14 | ;; Name for this file's array of quoted symbols. 15 | "tl_versions_symbols" 16 | ;; Quoted symbols defined in this file. 17 | `(:NICKNAMES-TO 18 | :ALIAS 19 | :SYSTEM-ALL-USED-SYSTEMS 20 | TL::UNIX 21 | TL::DOS 22 | TL::VMS 23 | TL::WIN32 24 | TL::I386 25 | TL::AVIION 26 | TL::SGI 27 | TL::SEQUENT 28 | TL::NEXT 29 | TL::DECSTATION 30 | TL::MASSCOMP 31 | TL::HP9000S300 32 | TL::HP9000S400 33 | TL::HP9000S700 34 | TL::HP9000S800 35 | TL::RS6000 36 | TL::SUN3 37 | TL::SUN4 38 | TL::SPARCSOL 39 | TL::ALPHAVMS 40 | TL::MOTOROLA 41 | TL::STRATUS 42 | TL::HARRIS 43 | TL::NEC 44 | TL::ALPHAOSF 45 | TL::ALPHANT 46 | TL::INTELNT 47 | TL::NCR 48 | TL::WINDOWS95 49 | TL::FREEBSD 50 | TL::LINUX 51 | TL::MACOSX 52 | TL::EXPERIMENTAL-PORT 53 | TL::COMPAQ) 54 | ;; Used compiled-functions = (name func-array . index). 55 | NIL 56 | ;; Name for this file's array of compiled-functions. 57 | NIL 58 | ;; Compiled-function objects defined in this file. 59 | NIL 60 | ;; Used function type signatures. 61 | '((TL::FIND-PACKAGE-1 "find_package_1" FUNCTION (T) T) 62 | (TL::FIND-PACKAGE-OR-ERROR-1 "find_package_or_error_1" FUNCTION (T) PACKAGE) 63 | (TL::FORMAT-FUNCTION "format_function" FUNCTION (T STRING T) T) 64 | (TL:GET "get" FUNCTION (T T &OPTIONAL T) T) 65 | (TL::INTERN-STRING-IN-PACKAGE "intern_string_in_package" FUNCTION (STRING FIXNUM PACKAGE) *) 66 | (TL:MEMQ "memq" FUNCTION (T LIST) T) 67 | (TL:NREVERSE "nreverse" FUNCTION (LIST) LIST) 68 | (TL::SET-GET "set_get" FUNCTION (T T T) T) 69 | (TL:SXHASH-STRING "sxhash_string" FUNCTION (STRING) FIXNUM)) 70 | ;; Defined functions. 71 | '((TL::COLLECT-ALL-USED-SYSTEMS . "collect_all_used_systems") 72 | (TL:MACHINE-MODEL . "machine_model") 73 | (TL:NORMALIZE-MODULE-NAME . "normalize_module_name") 74 | (TL:NORMALIZE-SYSTEM-NAME . "normalize_system_name") 75 | (TL:SYSTEM-ALIAS . "system_alias") 76 | (TL:SYSTEM-ALL-USED-SYSTEMS . "system_all_used_systems") 77 | (TL:SYSTEM-MODULES . "system_modules") 78 | (TL:SYSTEM-NICKNAMES . "system_nicknames") 79 | (TL:SYSTEM-USED-SYSTEMS . "system_used_systems")) 80 | ;; Used variables = (symbol c-name . type). 81 | '((*PACKAGE* "SpackageS" . OBJ) 82 | (CURRENT-REGION "current_region" . OBJ)) 83 | ;; Defined variables 84 | '((TL::ALPHANT-CODE . "alphant_code") 85 | (TL::ALPHAOSF-CODE . "alphaosf_code") 86 | (TL::ALPHAVMS-CODE . "alphavms_code") 87 | (TL::AVIION-CODE . "aviion_code") 88 | (TL::COLLECTED-SYSTEMS . "collected_systems") 89 | (TL::DECSTATION-CODE . "decstation_code") 90 | (TL::DOS-CODE . "dos_code") 91 | (TL::FREEBSD-CODE . "freebsd_code") 92 | (TL:G2-MACHINE-TYPE . "g2_machine_type") 93 | (TL:G2-OPERATING-SYSTEM . "g2_operating_system") 94 | (TL::HARRIS-CODE . "harris_code") 95 | (TL::HP9000S300-CODE . "hp9000s300_code") 96 | (TL::HP9000S400-CODE . "hp9000s400_code") 97 | (TL::HP9000S700-CODE . "hp9000s700_code") 98 | (TL::HP9000S800-CODE . "hp9000s800_code") 99 | (TL::I386-CODE . "i386_code") 100 | (TL::INTELNT-CODE . "intelnt_code") 101 | (TL::LINUX386-CODE . "linux386_code") 102 | (TL:MACHINE-MODEL-VAR . "machine_model_var") 103 | (TL::MACOSX-CODE . "macosx_code") 104 | (TL::MASSCOMP-CODE . "masscomp_code") 105 | (TL::MOTOROLA-CODE . "motorola_code") 106 | (TL::NCR-CODE . "ncr_code") 107 | (TL::NEC-CODE . "nec_code") 108 | (TL::NEXT-CODE . "next_code") 109 | (TL::RS6000-CODE . "rs6000_code") 110 | (TL::SEQUENT-CODE . "sequent_code") 111 | (TL::SGI-CODE . "sgi_code") 112 | (TL::SPARCSOL-CODE . "sparcsol_code") 113 | (TL::STRATUS-CODE . "stratus_code") 114 | (TL::SUN3-CODE . "sun3_code") 115 | (TL::SUN4-CODE . "sun4_code") 116 | (TL::TL-USER-PACKAGE . "tl_user_package") 117 | (TL::VMS-CODE . "vms_code") 118 | (TL::WINDOWS95-CODE . "windows95_code")) 119 | ;; Used class typedefs. 120 | NIL 121 | ) 122 | -------------------------------------------------------------------------------- /tl/lisp/apply.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TL") 2 | 3 | ;;;; Module APPLY 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1997 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Apply Implementation 29 | 30 | 31 | 32 | 33 | ;;; This file contains the function that the macro tl:apply expands into when we 34 | ;;; are translating. It can handle optional arguments, but not keyword or rest 35 | ;;; arguments, which are only availabe in macros within TL. 36 | 37 | ;;; Note that this can only handle tl:lambda-parameters-limit (currently 20) 38 | ;;; arguments in its dispatch. If we want to increase this number, we must also 39 | ;;; edit tl/c/tlt.h to define these function types. 40 | 41 | (defun apply-1 (function args) 42 | (let* ((rest-length (length args)) 43 | (function-args 44 | (cond ((> rest-length 1) 45 | (let ((next-to-last-cons (nthcdr (- rest-length 2) args))) 46 | (setf (cdr next-to-last-cons) 47 | (cadr-of-conses next-to-last-cons)) 48 | args)) 49 | (t 50 | (car (the cons args))))) 51 | (given-arg-count (length function-args)) 52 | (compiled-function 53 | (typecase function 54 | (null 55 | (error "NIL given as the function argument to apply")) 56 | (symbol 57 | (if (fboundp function) 58 | (symbol-function function) 59 | (error "Cannot apply ~s, it does not name a function." 60 | function))) 61 | (compiled-function 62 | function) 63 | (t 64 | (error "~s given as the function argument to apply." 65 | function)))) 66 | (actual-arg-count 67 | (tli::compiled-function-arg-count compiled-function))) 68 | (declare (type fixnum rest-length given-arg-count actual-arg-count)) 69 | (when (/= given-arg-count actual-arg-count) 70 | (if (and (< given-arg-count actual-arg-count) 71 | (>= (+ given-arg-count 72 | (tli::compiled-function-optional-arguments 73 | compiled-function)) 74 | actual-arg-count)) 75 | (cond 76 | (function-args 77 | ;; Note that this implementation depends on the extent of dynamic 78 | ;; extent conses extending through the body of the containing 79 | ;; function. 80 | (macrolet ((optional-argument-conses () 81 | `(tli::list-dynamic-extent 82 | ,@(loop repeat lambda-parameters-limit 83 | collect nil)))) 84 | (let ((conses (optional-argument-conses))) 85 | (loop for cons = conses then (cdr-of-cons cons) 86 | for arg-cons = function-args then next-arg-cons? 87 | for next-arg-cons? = (cdr-of-cons arg-cons) 88 | while next-arg-cons? do 89 | (setf (car cons) 90 | (car (the cons arg-cons))) 91 | finally 92 | (setf (car cons) (car (the cons arg-cons))) 93 | (setf (cdr cons) 94 | (nthcdr 95 | (- (tli::compiled-function-optional-arguments 96 | compiled-function) 97 | (- actual-arg-count given-arg-count)) 98 | (tli::compiled-function-default-arguments 99 | compiled-function)))) 100 | (setq function-args conses)))) 101 | (t 102 | (setq function-args 103 | (tli::compiled-function-default-arguments 104 | compiled-function)))) 105 | (error "Argument count mismatch in APPLY ~s on ~s" 106 | compiled-function function-args))) 107 | (macrolet ((dispatch-to-apply-primitive 108 | (arglist-var actual-arg-count-var compiled-function-var) 109 | (let ((arg-list (gensym)) 110 | (arg-vars (loop repeat lambda-parameters-limit 111 | collect (gensym)))) 112 | `(let ((,arg-list ,arglist-var) 113 | ,@arg-vars) 114 | (block set-vars 115 | ,@(loop for arg in arg-vars 116 | nconc 117 | `((unless ,arg-list 118 | (return-from set-vars nil)) 119 | (setq ,arg (car-of-cons ,arg-list)) 120 | (setq ,arg-list (cdr-of-cons ,arg-list))))) 121 | (case (the fixnum ,actual-arg-count-var) 122 | ,@(loop for arg-count from 0 123 | to tl:lambda-parameters-limit 124 | collect 125 | `((,arg-count) 126 | (if (/= (tli::compiled-function-sets-values-count 127 | ,compiled-function-var) 128 | 0) 129 | (tli::funcall-internal 130 | t ,compiled-function-var 131 | ,@(loop repeat arg-count 132 | for arg in arg-vars 133 | collect arg)) 134 | (tli::funcall-internal 135 | nil ,compiled-function-var 136 | ,@(loop repeat arg-count 137 | for arg in arg-vars 138 | collect arg))))) 139 | (t 140 | (error "Calling APPLY on ~a with ~a args, it can only handle ~a." 141 | ,compiled-function-var ,actual-arg-count-var 142 | ,lambda-parameters-limit))))))) 143 | (tli::set-thread-closure-env 144 | (tli::compiled-function-closure-environment compiled-function)) 145 | (dispatch-to-apply-primitive 146 | function-args actual-arg-count compiled-function)))) 147 | -------------------------------------------------------------------------------- /tl/lisp/boot.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TL") 2 | 3 | ;;;; Module BOOT 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1996 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Bootstrapping TL 29 | 30 | 31 | 32 | 33 | ;;; Loading this module will define the TL system, which implements the 34 | ;;; translated primitives in TL, ThinLisp. TL stands upon TLT, the ThinLisp 35 | ;;; Translator, which should already have been loaded when this file is loaded. 36 | 37 | (declare-system (tl :library t :used-systems nil 38 | :extra-c-files ("tl") 39 | :extra-h-files ("tl")) 40 | boot 41 | stubs 42 | tl-types 43 | inline 44 | tl-prim 45 | do 46 | format 47 | input 48 | tl-basics 49 | loop 50 | apply 51 | generic-math 52 | generic-prim 53 | packages 54 | tl-util 55 | versions 56 | forward 57 | tl-extension 58 | tl-time) 59 | -------------------------------------------------------------------------------- /tl/lisp/do.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TL") 2 | 3 | ;;;; Module DO 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1996 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Simple Looping 29 | 30 | 31 | 32 | 33 | ;;; This module implements the simple looping macros for TL. Some of this code 34 | ;;; has been pulled from CMULISP. 35 | 36 | ;;; Note that in TL:DOTIMES, the termination count must always be a fixnum. 37 | 38 | (defmacro dotimes ((var count &optional (result nil)) &body body) 39 | (multiple-value-bind (decls forms) 40 | (split-declarations-and-body body) 41 | (cond 42 | ((fixnump count) 43 | `(let ((,var 0)) 44 | (declare (type fixnum ,var)) 45 | ,@decls 46 | (block nil 47 | (tli::for-loop 48 | (nil (< ,var ,count) (setq ,var (+ ,var 1))) 49 | ,@forms) 50 | ,result))) 51 | (t 52 | (let ((end-value (gensym))) 53 | `(let ((,end-value ,count) 54 | (,var 0)) 55 | (declare (type fixnum ,end-value ,var)) 56 | ,@decls 57 | (block nil 58 | (tli::for-loop 59 | (nil (< ,var ,end-value) (setq ,var (+ ,var 1))) 60 | ,@forms) 61 | ,result))))))) 62 | 63 | 64 | 65 | 66 | ;;; We repeatedly bind the var instead of setting it so that we never give the 67 | ;;; var a random value such as NIL (which might conflict with a declaration). 68 | ;;; If there is a result form, we introduce a gratitous binding of the variable 69 | ;;; to NIL w/o the declarations, then evaluate the result form in that 70 | ;;; environment. We spuriously reference the gratuitous variable, since we 71 | ;;; don't want to use IGNORABLE on what might be a special var. 72 | 73 | (defmacro dolist ((var list &optional (result nil)) &body body) 74 | (let ((the-list (gensym))) 75 | `(let ((,the-list ,list)) 76 | (block nil 77 | (tli::for-loop 78 | (nil ,the-list (setq ,the-list (cdr (the cons ,the-list)))) 79 | (let ((,var (car (the cons ,the-list)))) 80 | ,@body)) 81 | ,(if result 82 | `(let ((,var nil)) 83 | ,var 84 | ,result) 85 | nil))))) 86 | 87 | (defun-for-macro do-do-body (varlist endlist code decl bind step name block) 88 | (let* ((inits ()) 89 | (steps ()) 90 | (endtest (car endlist))) 91 | ;; Check for illegal old-style do. 92 | (when (or (not (listp varlist)) (atom endlist)) 93 | (lisp:error "Ill-formed ~S -- possibly illegal old style DO?" name)) 94 | ;; Parse the varlist to get inits and steps. 95 | (dolist (v varlist) 96 | (cond ((symbolp v) (push v inits)) 97 | ((listp v) 98 | (unless (symbolp (first v)) 99 | (lisp:error "~S step variable is not a symbol: ~S" name (first v))) 100 | (case (tli::length-trans v) 101 | (1 (push (first v) inits)) 102 | (2 (push v inits)) 103 | (3 (push (list (first v) (second v)) inits) 104 | (setq steps (list* (third v) (first v) steps))) 105 | (t (lisp:error "~S is an illegal form for a ~S varlist." v name)))) 106 | (t (lisp:error "~S is an illegal form for a ~S varlist." v name)))) 107 | ;; And finally construct the new form. 108 | `(block ,block 109 | (,bind ,(nreverse inits) 110 | ,@decl 111 | (tagbody 112 | next-loop 113 | ,@(when endtest `((when ,endtest (go end-loop)))) 114 | ,@code 115 | ,(if (cddr steps) 116 | `(,step ,@(nreverse steps)) 117 | `(setq ,@(nreverse steps))) 118 | (go next-loop) 119 | ,@(when endtest '(end-loop)) 120 | (return-from ,block (progn ,@(cdr endlist)))))))) 121 | 122 | 123 | 124 | 125 | ;;; DO ({(Var [Init] [Step])}*) (Exit-Test Exit-Form*) Declaration* Form* 126 | ;;; Iteration construct. Each Var is initialized in parallel to the value of 127 | ;;; the specified Init form. On subsequent iterations, the Vars are assigned 128 | ;;; the value of the Step form (if any) in paralell. The Test is evaluated 129 | ;;; before each evaluation of the body Forms. When the Test is true, the the 130 | ;;; Exit-Forms are evaluated as a PROGN, with the result being the value of the 131 | ;;; DO. A block named NIL is established around the entire expansion, allowing 132 | ;;; RETURN to be used as an laternate exit mechanism." 133 | 134 | (defmacro do (varlist endlist &body decls-and-forms) 135 | (multiple-value-bind (decls body) 136 | (split-declarations-and-body decls-and-forms) 137 | (do-do-body varlist endlist body decls 'let 'psetq 'do nil))) 138 | 139 | 140 | 141 | 142 | ;;; DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* 143 | 144 | ;;; Iteration construct. Each Var is initialized sequentially (like LET*) to the 145 | ;;; value of the specified Init form. On subsequent iterations, the Vars are 146 | ;;; sequentially assigned the value of the Step form (if any). The Test is 147 | ;;; evaluated before each evaluation of the body Forms. When the Test is true, 148 | ;;; the the Exit-Forms are evaluated as a PROGN, with the result being the value 149 | ;;; of the DO. A block named NIL is established around the entire expansion, 150 | ;;; allowing RETURN to be used as an laternate exit mechanism." 151 | 152 | (defmacro do* (varlist endlist &body decls-and-forms) 153 | (multiple-value-bind (decls body) 154 | (split-declarations-and-body decls-and-forms) 155 | (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))) 156 | -------------------------------------------------------------------------------- /tl/lisp/generic-prim.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TL") 2 | 3 | ;;;; Module GENERIC-PRIM 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1997 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Glenn Iba 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Generic Functions Mirroring TLT-PRIM 29 | 30 | 31 | 32 | 33 | (defun generic-aref (array index) 34 | (declare (type fixnum index) 35 | (consing-area either) 36 | (return-type t)) 37 | (macrolet ((aref-typecase (array-var array-index) 38 | `(typecase ,array-var 39 | ,@(loop for type-triple in tli::primitive-array-types 40 | for type = (first type-triple) 41 | collect 42 | `(,type 43 | (aref (the ,type ,array-var) ,array-index))) 44 | (t 45 | (error "Unrecognized array-type of ~s for AREF." 46 | ,array-var))))) 47 | (aref-typecase array index))) 48 | 49 | 50 | (defun generic-set-aref (array index value) 51 | (declare (type fixnum index) 52 | (return-type t)) 53 | (macrolet ((set-aref-typecase (array-var array-index new-value) 54 | `(typecase ,array-var 55 | ,@(loop for type-triple in tli::primitive-array-types 56 | for type = (first type-triple) 57 | for elt-type = (second type-triple) 58 | collect 59 | `(,type 60 | ;; should this call SET-AREF instead of (SETF-ing (AREF ...)) ??? 61 | (setf (aref (the ,type ,array-var) ,array-index) 62 | (the ,elt-type ,new-value)))) 63 | (t 64 | (error "Unrecognized array-type of ~s for SET-AREF." 65 | ,array-var))))) 66 | (set-aref-typecase array index value) 67 | value)) 68 | 69 | 70 | 71 | (defun generic-elt (sequence index) 72 | (declare (type fixnum index) 73 | (consing-area either) 74 | (return-type t)) 75 | (macrolet ((elt-typecase (sequence-var sequence-index) 76 | `(typecase ,sequence-var 77 | (list (nth ,sequence-index (the list ,sequence-var))) 78 | ,@(loop for type-triple in tli::primitive-array-types 79 | for type = (first type-triple) 80 | collect 81 | `(,type 82 | (aref (the ,type ,sequence-var) ,sequence-index))) 83 | (t 84 | (error "Unrecognized sequence type of ~s for ELT." 85 | ,sequence-var))))) 86 | (elt-typecase sequence index))) 87 | 88 | (defun generic-set-elt (sequence index value) 89 | (declare (type fixnum index) 90 | (return-type t)) 91 | (macrolet ((set-elt-typecase (sequence-var sequence-index new-value) 92 | `(typecase ,sequence-var 93 | (list (setf (nth ,sequence-index (the list ,sequence-var)) 94 | ,new-value)) 95 | ,@(loop for type-triple in tli::primitive-array-types 96 | for type = (first type-triple) 97 | for elt-type = (second type-triple) 98 | collect 99 | `(,type 100 | (setf (elt (the ,type ,sequence-var) ,sequence-index) 101 | (the ,elt-type ,new-value)))) 102 | (t 103 | (error "Unrecognized sequence type of ~s for SET-ELT." 104 | ,sequence-var))))) 105 | (set-elt-typecase sequence index value) 106 | value)) 107 | 108 | -------------------------------------------------------------------------------- /tl/lisp/inline.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TL") 2 | 3 | ;;;; Module INLINE 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1997 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | ;;; Author: Glenn Iba 23 | 24 | 25 | 26 | 27 | 28 | 29 | ;;;; Functions that are to be inlined via compiler macros 30 | 31 | 32 | 33 | 34 | ;;; This module contains basic function definitions that are needed early on, 35 | ;;; and that are normally to be inlined via compiler macros. 36 | 37 | 38 | 39 | 40 | 41 | ;;; Note that the implementation of `eql' can rely primarily on EQ tests, 42 | ;;; but only needs to compare values of numbers in the case where they are both 43 | ;;; double floats. Since fixnums and characters are immediate, EQ is an 44 | ;;; accurate test for these types. 45 | 46 | (declaim (functional eql)) 47 | 48 | (defun eql (a b) 49 | (declare (return-type t)) 50 | ;; The silly if wrapper here puts the translation of this function into a 51 | ;; required type of boolean, which translates better than the general value 52 | ;; returning translations of AND and OR. -jra 2/23/96 53 | (if (or (eq a b) 54 | (and (typep a 'double-float) 55 | (typep b 'double-float) 56 | (= (the double-float a) (the double-float b)))) 57 | t 58 | nil)) 59 | 60 | 61 | 62 | 63 | ;;; The variable `tli::symbol-plist-of-nil' is used by the translations for 64 | ;;; symbol-plist. 65 | 66 | (defvar tli::symbol-plist-of-nil nil) 67 | 68 | 69 | 70 | 71 | ;;; The function make-gensymed-symbol is defined in packages, since it needs to 72 | ;;; be after format. 73 | 74 | (defmacro gensym (&optional string-or-number) 75 | `(the symbol 76 | ,(if (tli::eval-feature :translator) 77 | `(make-gensymed-symbol ,string-or-number) 78 | (if string-or-number 79 | `(lisp:gensym ,string-or-number) 80 | `(lisp:gensym))))) 81 | 82 | 83 | 84 | 85 | ;;; The following operations implement the built-in list searching facilities, 86 | ;;; including optimizations for the standard EQ, EQL, and EQUAL tests. 87 | 88 | (defmacro my-identity (x) 89 | x) 90 | 91 | 92 | 93 | 94 | ;;; The macro `substitution-function-p' is a predicate used to declare that a 95 | ;;; symbol was defined using the def-substitution mechinism. This knowledge is 96 | ;;; useful to code walkers which then know they may treat the forms as function 97 | ;;; like. 98 | 99 | (defmacro substitution-function-p (name) 100 | `(get ,name 'substitution-function-p)) 101 | -------------------------------------------------------------------------------- /tl/lisp/tl-time.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TL") 2 | 3 | ;;;; Module TL-TIME 4 | 5 | ;;; Copyright (c) 2000-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1997 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Time Functions 29 | 30 | 31 | 32 | ;;; This module contains support for the time related functions of Common Lisp. 33 | ;;; For now I'll start with the internal real time and sleeping functions. 34 | 35 | (declaim (inline get-internal-real-time 36 | get-internal-run-time)) 37 | 38 | (def-inlined-pseudo-function-with-side-effects (init-cronometer :void) () 39 | nil) 40 | 41 | (def-inlined-pseudo-function-with-side-effects (cronometer :fixnum) () 42 | (tli::get-internal-real-time)) 43 | 44 | (init-cronometer) 45 | 46 | (defun get-internal-real-time () 47 | (declare (return-type fixnum)) 48 | (cronometer)) 49 | 50 | (def-inlined-pseudo-function (cpu-run-time :fixnum) () 51 | (tli::get-internal-run-time)) 52 | 53 | (defun get-internal-run-time () 54 | (declare (return-type fixnum)) 55 | (cpu-run-time)) 56 | 57 | (def-inlined-pseudo-function (ticks-per-second :fixnum) () 58 | tli::internal-time-units-per-second) 59 | 60 | (declaim (type fixnum internal-time-units-per-second)) 61 | 62 | (defparameter internal-time-units-per-second (ticks-per-second)) 63 | 64 | (def-inlined-pseudo-function-with-side-effects (sleep-ticks :void) ((sleep-seconds :fixnum)) 65 | (tli::sleep (/e (coerce-to-double-float sleep-seconds) 66 | (coerce-to-double-float tli::internal-time-units-per-second)))) 67 | 68 | (defun sleep (seconds) 69 | (declare (return-type t) 70 | (type double-float seconds)) 71 | (sleep-ticks (floore-first (*e seconds 72 | (coerce-to-double-float 73 | internal-time-units-per-second)))) 74 | nil) 75 | -------------------------------------------------------------------------------- /tlt/.cvsignore: -------------------------------------------------------------------------------- 1 | dev 2 | -------------------------------------------------------------------------------- /tlt/lisp/clos.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TLI") 2 | 3 | ;;;; Module CLOS 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1996 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; CLOS 29 | 30 | 31 | 32 | 33 | ;;; This module implements a subset of CLOS. In particular, this implementation 34 | ;;; assumes that all classes that will be defined have already been defined, and 35 | ;;; therefore it makes optimizations that would be incorrect if further 36 | ;;; subclasses could be defined. 37 | 38 | ;;; There are some cases where this will not be appropriate. In particular, if 39 | ;;; there are systems that are distributed as binary libraries (i.e. the Lisp 40 | ;;; source is not included), and so no retranslation of that system could be 41 | ;;; done after it had been specialized by a user, then we need to be able to 42 | ;;; declare that the classes in that library may not be optimized as strongly as 43 | ;;; the default case. A future feature of TL could be a `tl:subclassable' 44 | ;;; declaration as an extension to Common Lisp that informs TL that it would not 45 | ;;; make assumptions about the subclass tree of a class while translating. 46 | ;;; Hopefully this feature will be rarely used, since it has a devastating 47 | ;;; effect on the performance of many operations. For those Dylan afficianados 48 | ;;; out there, it is as if every class were declared sealed by default, and you 49 | ;;; had to explicitly unseal them to get the more dynamic behavior. 50 | 51 | (defmacro def-metaclasses (&rest names) 52 | `(tl:progn 53 | ,@(loop for name in names 54 | collect 55 | `(tl:setf (tl:get ','name 'metaclass) t)) 56 | nil)) 57 | 58 | (def-metaclasses tl:standard-class tl:built-in-class tl:structure-class) 59 | 60 | ;(defclass standard-object) 61 | 62 | ;(defclass standard-class) 63 | 64 | ; Update-instance-for-redefined-class 65 | 66 | ; shared-initialize 67 | 68 | ; slot-value 69 | 70 | ; change-class 71 | 72 | ; defmethod 73 | 74 | ; defgeneric 75 | 76 | ; class type, instances describe classes 77 | 78 | ; method - an implementation for a particular op/class 79 | 80 | ; standard-method - subclass of method 81 | 82 | ; method-combination - indirect instance of the method-combination class that 83 | ; represents the type of method combination used for a particular generic 84 | ; function. 85 | 86 | ; coerce function - no effect 87 | 88 | ; type-of returns the symbol naming the class 89 | 90 | ; type boolean => (member t nil) 91 | 92 | ; generic-function, standard-generic-function type - dispatches to methods 93 | 94 | 95 | (defmacro tl:function-keywords (method) 96 | (error "tl:function-keywords unsupported : ~a" method)) 97 | 98 | 99 | (defun ensure-generic-function (function-name &key argument-precedence-order 100 | declare documentation 101 | environment generic-function-class 102 | lambda-list method-class 103 | method-combination 104 | generic-function ) 105 | (error "stub")) 106 | 107 | (defgeneric allocate-instance (class &rest initargs &key &allow-other-keys) 108 | ) 109 | 110 | (defgeneric reinitialize-instance (instance &rest initargs &key &allow-other-keys) 111 | ) 112 | 113 | (defgeneric shared-initialize (instance slot-names &rest initargs &key &allow-other-keys) 114 | ) 115 | 116 | (defgeneric update-instance-for-different-class 117 | (previous current &rest initargs &key &allow-other-keys) 118 | ) 119 | 120 | (defmethod update-instance-for-redefined-class 121 | (instance added-slots discarded-slots property-list &rest initargs 122 | &key &allow-other-keys) 123 | ) 124 | 125 | (defgeneric change-class (instance new-class &rest initargs) 126 | ) 127 | 128 | 129 | (defun slot-boundp (instance slot-name) 130 | ) 131 | 132 | (defun slot-exists-p (object slot-name) 133 | nil) 134 | 135 | (defun slot-makunbound (instance slot-name) 136 | instance) 137 | 138 | (defgeneric slot-missing (class object slot-name operation &optional new-value) 139 | ) 140 | 141 | (defgeneric slot-unbound (class instance slot-name) 142 | ) 143 | 144 | (defun slot-value (object name) 145 | nil) 146 | 147 | (defgeneric no-applicable-method () 148 | nil) 149 | 150 | (defun determine-effective-method () 151 | ; 1. Select the applicable methods. 152 | 153 | ; 2. Sort the applicable methods by precedence order, putting the most 154 | ; specific method first. 155 | 156 | ; 3. Apply method combination, to the sorted list of applicable methods, 157 | ; producing the effective method. 158 | 159 | nil) 160 | 161 | (defun precedence-order-sort () 162 | ; 1. Examine parameter specializers in left to right order, or in the order 163 | ; provided by the :argument-precedence-order option to defgeneric or to any of 164 | ; the other operations that specify generic function options. 165 | 166 | ; 2. Compare parameter specializers from each method. When they argree, the 167 | ; next pair are compared fro agreement. If all agree, then the two methods 168 | ; must have different qualifiers, so relative order between them is 169 | ; unimportant. When they do not agree, the most specific superior class of 170 | ; the actual argument is more specific and so is sorted closer to the front of 171 | ; the list. 172 | 173 | ; 3. If just one pair of corresponding parameter specializers is (eql object), 174 | ; the method with that parameter specializer precedes the other method. If 175 | ; both parameter specializers are eql expressions, the specializers must 176 | ; agree. The resulting list has the most specific first, and the least 177 | ; specific last. 178 | 179 | nil) 180 | 181 | (defun apply-method-combination () 182 | ; 1. Before methods are run in most specific-first order, and after methods 183 | ; are run in least-specific-first order. 184 | 185 | ; 2. All of the around methods are run before any other methods, so for 186 | ; example a less specific around method could run before a more specific 187 | ; primary method. 188 | 189 | ; 3. If only primary methods are used and if call-next-method is not used, 190 | ; only the most specific method is invoked, that is more specific primary 191 | ; methods shadow more general ones. 192 | 193 | ; 4. If any around methods exist, they provide the values returned from the 194 | ; generic function. If not, then the primary method supplies the values. If 195 | ; no around or primary methods exist, then the values returned by 196 | ; no-applicable-method are returned. 197 | 198 | nil) 199 | 200 | (defgeneric call-next-method () 201 | ; Can be called within around methods or primary methods to invoke the next 202 | ; around method or primary method, respectively. If no other around method or 203 | ; primary method exists, then no-next-method is called. 204 | nil) 205 | 206 | (defgeneric no-next-method () 207 | ; This is called with call-next-method comes up empty. 208 | nil) 209 | 210 | (defun next-method-p () 211 | ; Returns whether or not a next method exists. 212 | nil) 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | ;;; Def-class, make-instance 221 | -------------------------------------------------------------------------------- /tlt/lisp/defvar.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TLI") 2 | 3 | ;;;; Module DEFVAR 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1996 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Variable Definitions 29 | 30 | 31 | 32 | 33 | ;;; This module implements the macros `tl:defvar', `tl:defparameter', and 34 | ;;; `tl:defconstant'. Defvar and defparameter define global variables that are 35 | ;;; translated into C variables. Defconstant defines pointers to variable 36 | ;;; values that are always inlined into the referencing locations. 37 | 38 | (defmacro tl:defvar (name &optional (initial-value no-initial-value) 39 | (documentation nil)) 40 | (declare (ignore documentation)) 41 | `(tl:progn 42 | (tl:declaim (special ,name)) 43 | (def-named-variable ,name :variable ,initial-value))) 44 | 45 | (defmacro tl:defparameter (name initial-value) 46 | `(tl:progn 47 | (tl:declaim (special ,name)) 48 | (def-named-variable ,name :parameter ,initial-value))) 49 | 50 | (defmacro tl:defconstant (name initial-value) 51 | `(tl:progn 52 | (tl:declaim (constant ,name)) 53 | (def-named-variable ,name :constant ,initial-value))) 54 | 55 | 56 | 57 | 58 | ;;; The macro `def-translatable-lisp-var' is used to define a variable for TL on 59 | ;;; a symbol that is an underlying Lisp implementation variable. An example is 60 | ;;; *features*. We must use the Lisp package version so that the reader can 61 | ;;; interpret #+ reader macros appropriately, but we want to distinguish a use 62 | ;;; of this variable from a use of some other Lisp variable that we do not have 63 | ;;; a definition or translation for. This macro does the trick, standing in for 64 | ;;; a defvar, as far as the translator is concerned, but while still using the 65 | ;;; previously defined defvar while in development. 66 | 67 | (defmacro tl:def-translatable-lisp-var 68 | (name &optional (initial-value no-initial-value)) 69 | `(tl:progn 70 | (tl:declaim (special ,name)) 71 | (def-named-variable ,name :underlying-lisp-variable ,initial-value))) 72 | 73 | (defmacro def-translatable-lisp-constant 74 | (name initial-value) 75 | `(tl:progn 76 | (tl:declaim (constant ,name)) 77 | (def-named-variable ,name :underlying-lisp-constant ,initial-value))) 78 | -------------------------------------------------------------------------------- /tlt/lisp/l-stack.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TLI") 2 | 3 | ;;;; Module L-STACK 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1995 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Lisp Stacks 29 | 30 | 31 | 32 | 33 | ;;; Within the TL runtime environment, each thread of execution gets a stack for 34 | ;;; storing global variable bindings, unwind-protect cleanups, sets of values 35 | ;;; from multiple-value-prog1 forms, and catch scopes. This file contains 36 | ;;; functions that emit code that manages the stack. These are generally called 37 | ;;; from the l-expr translations in L-TRANS. 38 | 39 | 40 | 41 | 42 | 43 | 44 | ;;;; Stack Layout 45 | 46 | 47 | 48 | 49 | ;;; The Lisp stack is constructed as follows. Within the Thread_state struct 50 | ;;; for a thread, there is a member called throw_stack and another called 51 | ;;; throw_stack_top. These names came from an early point in the implementation 52 | ;;; when only catch and throw had been implemented, and these stacks had not yet 53 | ;;; been used for global variable binding or unwind-protect scopes. The 54 | ;;; throw_stack is an array of Obj elements, and the throw_stack_top is an 55 | ;;; integer pointing to the highest occupied element of the stack. In other 56 | ;;; words, when the stack is empty, throw_stack_top equals -1. (Yes, it's 57 | ;;; strange, and I can't remember why in the world I did it that way, but lots 58 | ;;; of code depends on that now, so we're somewhat stuck. 59 | 60 | ;;; The stack can be walked from the top down towards the bottom. The things 61 | ;;; held on the stack are stack frames. The topmost element of every stack 62 | ;;; frame is an integer denote the stack frame type. The number of stack 63 | ;;; elements and their interpretation are different per type of stack frame. 64 | ;;; The Stack_frames enumeration in tl/c/tl.h defines the constants used to mark 65 | ;;; the different stack frame types. 66 | 67 | 68 | 69 | 70 | 71 | 72 | ;;;; Global Variable Bindings 73 | 74 | 75 | 76 | 77 | ;;; The binding style used for TL depends on whether or not TL is compiled for 78 | ;;; multi-threading (i.e. has the THREAD variable set when invoking the 79 | ;;; makefiles). The C macros GET_GLOBAL and SET_GLOBAL implement global 80 | ;;; variable getting and setting of the current bound value within the current 81 | ;;; thread. In both situations, references to special variables are translated 82 | ;;; as calls to GET_GLOBAL and SET_GLOBAL, and given as their first argument a 83 | ;;; reference to a C global variable that represents the value cell of the 84 | ;;; symbol naming the special variable. 85 | 86 | ;;; If TL is compiled without multi-threading, then shallow binding will be 87 | ;;; used. The C global variable will always contain the value of the current 88 | ;;; binding, and the stack will contain previous binding values which must be 89 | ;;; restored as binding scopes are exited. In shallow binding, calls to 90 | ;;; GET_GLOBAL and SET_GLOBAL get and set the value of the global C variable 91 | ;;; directly without any intervening function calls or further processing. 92 | ;;; Binding a special means storing the current value of the C global into the 93 | ;;; binding frame on the stack, and then overwriting the C global with the new 94 | ;;; bound value. Unbinding a special means restoring the value from the binding 95 | ;;; frame by overwriting the value of the C global. 96 | 97 | ;;; When compiled with multi-threading, then deep binding is used. The current 98 | ;;; binding varies per thread, since the dynamic scope of a binding only applies 99 | ;;; to the thread in which the binding was made. The value of the C global 100 | ;;; variable contains the value of the default binding, i.e. the value shared 101 | ;;; between threads that have not further bound that variable. The stack 102 | ;;; contains new bindings which themselvs hold the value for new bindings. In 103 | ;;; deep binding, calls to GET_GLOBAL and SET_GLOBAL must first search the stack 104 | ;;; of the currently running thread for any bindings of the special variable. 105 | ;;; If a thread specific binding is found, then the value of the special 106 | ;;; variable is fetched or set into the memory location within the topmost 107 | ;;; binding frame for that variable on the stack. If no binding frame for that 108 | ;;; variable is found, then the C global variable is used. Each binding frame 109 | ;;; on the stack is identified with the address of the C global variable. 110 | 111 | ;;; The function `bind-global-for-let' emits code to bind a global variable. 112 | ;;; The stack frame for a binding contains the following elements, from the top 113 | ;;; of the frame down towards the bottom: 114 | ;;; 1. BINDING_FRAME, i.e. the stack frame type marker 115 | ;;; 2. The address of the C global variable 116 | ;;; 3. The value of the binding. 117 | 118 | ;;; When using shallow binding (i.e. non-threaded compilation) the value will 119 | ;;; actually be the value of the previous binding and will be used to restore 120 | ;;; the previous binding. When using deep binding, the value element of this 121 | ;;; stack frame is actually the memory location of the new binding, and all gets 122 | ;;; and sets of the global variable will occur into this location. 123 | 124 | (defun bind-global-for-let (global-identifier new-value-identifier 125 | c-compound-statement 126 | &optional thread-state-identifier) 127 | (emit-expr-to-compound-statement 128 | (make-c-function-call-expr 129 | (make-c-name-expr "bind_global") 130 | (list (make-c-unary-expr #\& (make-c-name-expr global-identifier)) 131 | (make-c-name-expr (or thread-state-identifier "THREAD_STATE")) 132 | (make-c-name-expr new-value-identifier))) 133 | c-compound-statement)) 134 | 135 | (defun rebind-globals-for-let (specials-to-rebind c-compound-statement 136 | &optional thread-state-var) 137 | (loop for (global-var . new-value) in specials-to-rebind do 138 | (bind-global-for-let global-var new-value c-compound-statement 139 | thread-state-var))) 140 | 141 | (defun unbind-globals-for-let (globals c-compound-statement 142 | &optional thread-state-var) 143 | (loop for index fixnum from 0 144 | for global in (reverse globals) 145 | do 146 | (when (not (stringp global)) 147 | (translation-error "Unbinding global ~s, which was not a string" global)) 148 | (emit-expr-to-compound-statement 149 | (make-c-function-call-expr 150 | (make-c-name-expr "unbind_global") 151 | (list (make-c-unary-expr #\& (make-c-name-expr global)) 152 | (make-c-name-expr (or thread-state-var "THREAD_STATE")))) 153 | c-compound-statement))) 154 | -------------------------------------------------------------------------------- /tlt/lisp/regions.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TLI") 2 | 3 | ;;;; Module REGIONS 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1996 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Memory Regions 29 | 30 | 31 | 32 | 33 | ;;; This module contains operations for specifying and manipulating memory 34 | ;;; regions within TL applications. 35 | 36 | ;;; The function `region-number-for-type-and-area' takes a Lisp type and an area 37 | ;;; name, one of either tl:permannent or tl:temporary. This function returns an 38 | ;;; integer that is the region number for creating the given type in the given 39 | ;;; area. Note that this number is only used for error checking at runtime to 40 | ;;; verify that the consing area is what the declaration said it should be. 41 | 42 | (defun region-number-for-type-and-area (lisp-type area) 43 | (cond ((eq area 'tl:temporary) 44 | (unless (eq lisp-type 'double-float) 45 | (translation-warning 46 | "Attempting to allocate a ~s in a temporary area. Only floats can go there." 47 | lisp-type)) 48 | 2) 49 | ((eq area 'tl:permanent) 50 | (if (eq lisp-type 'symbol) 51 | 1 52 | 0)) 53 | ((eq area 'tl:either) 54 | -1) 55 | (t 56 | (translation-error "Bad area name ~s." area)))) 57 | 58 | 59 | 60 | 61 | ;;; The function `declared-area-name' takes an environment and a Lisp type and 62 | ;;; returns the symbol naming the current area declared within the environment. 63 | ;;; If none is visible, this function issues a translation warning and returns 64 | ;;; tl:permanent. 65 | 66 | (defun declared-area-name (env type-to-allocate) 67 | (let ((area? (tl:declaration-information 'tl:consing-area env))) 68 | (if area? 69 | area? 70 | (let ((enclosing-function? (tl:declaration-information 'scope-name env))) 71 | (cond ((null enclosing-function?) 72 | 'tl:permanent) 73 | ((function-decl enclosing-function? 'tl:conser) 74 | 'tl:either) 75 | (t 76 | (translation-warning 77 | "Consing a ~s with no surrounding consing-area declaration." 78 | type-to-allocate) 79 | 'tl:permanent)))))) 80 | 81 | 82 | 83 | 84 | ;;; The function `check-area-for-conser-call' is called when translating a call 85 | ;;; to a function that conses into the current area (i.e. a conser). If there 86 | ;;; is no current area declaration, this will issue a warning. 87 | 88 | (defun check-area-for-conser-call (conser-function-name env) 89 | (let ((area? (tl:declaration-information 'tl:consing-area env))) 90 | (unless (or area? 91 | (null (tl:declaration-information 'scope-name env))) 92 | (translation-warning 93 | "Calling a consing function, ~a, without a surrounding consing-area declaration." 94 | conser-function-name)) 95 | nil)) 96 | 97 | 98 | 99 | 100 | ;;; The macros `with-temporary-area' and `with-permanent-area' are implemented 101 | ;;; by rebinding the variables Current-region and Temporary-area-top. These 102 | ;;; variables are defined in TL. 103 | 104 | (def-tl-macro tl:with-temporary-area (&body forms) 105 | `(tl:let* ((current-region 106 | ,(region-number-for-type-and-area 'double-float 'tl:temporary)) 107 | (temporary-area-top temporary-area-top)) 108 | (tl:declare (tl:consing-area tl:temporary)) 109 | ,@forms)) 110 | 111 | (def-tl-macro tl:with-permanent-area (&body forms) 112 | `(tl:let* ((current-region 113 | ,(region-number-for-type-and-area 'double-float 'tl:permanent))) 114 | (tl:declare (tl:consing-area tl:permanent)) 115 | ,@forms)) 116 | -------------------------------------------------------------------------------- /tlt/lisp/symbols.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TLI") 2 | 3 | ;;;; Module SYMBOLS 4 | 5 | ;;; Copyright (c) 1999-2001 The ThinLisp Group 6 | ;;; Copyright (c) 1995 Gensym Corporation. 7 | ;;; All rights reserved. 8 | 9 | ;;; This file is part of ThinLisp. 10 | 11 | ;;; ThinLisp is open source; you can redistribute it and/or modify it 12 | ;;; under the terms of the ThinLisp License as published by the ThinLisp 13 | ;;; Group; either version 1 or (at your option) any later version. 14 | 15 | ;;; ThinLisp is distributed in the hope that it will be useful, but 16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18 | 19 | ;;; For additional information see 20 | 21 | ;;; Author: Jim Allard 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;;;; Symbols in Runtime Images 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | (defun emit-symbol-array-initialization (c-file array-name symbol-list initial-index) 37 | (let* ((symbols-func (c-file-top-level-symbols-function c-file)) 38 | (symbols-body (c-func-body-statement symbols-func)) 39 | (package-to-c-var-alist nil)) 40 | (loop for index from initial-index 41 | for symbol in symbol-list 42 | for symbol-name = (symbol-name symbol) 43 | for home-package? = (symbol-package symbol) 44 | for package? 45 | = (if (eq home-package? *lisp-package*) 46 | (if (find-symbol symbol-name *tl-package*) 47 | *tl-package* 48 | (translation-error 49 | "Attempting to make a pointer to ~s, a LISP symbol ~ 50 | not accessible from the TL package." 51 | symbol)) 52 | home-package?) 53 | for package-var? = (cdr (assq package? package-to-c-var-alist)) 54 | for symbol-expr = (make-c-subscript-expr (make-c-name-expr array-name) 55 | (make-c-literal-expr index)) 56 | do 57 | (when (and package? (null package-var?)) 58 | (setq package-var? 59 | (lexical-c-variable-identifier 60 | (intern (format nil "CACHED-~a-PACKAGE" (package-name package?))) 61 | symbols-func 'obj nil)) 62 | (setq package-to-c-var-alist 63 | (cons (cons package? package-var?) package-to-c-var-alist)) 64 | (emit-expr-to-compound-statement 65 | (make-c-infix-expr 66 | (make-c-name-expr package-var?) 67 | "=" (make-c-function-call-expr 68 | (make-c-name-expr "find_package_1") 69 | (list (translate-string-constant-into-c 70 | (package-name package?) 'obj c-file 71 | nil symbols-func symbols-body :c-expr)))) 72 | symbols-body)) 73 | (emit-expr-to-compound-statement 74 | (make-c-function-call-expr 75 | (make-c-name-expr "init_symbol_into_package") 76 | (list 77 | (make-c-cast-expr 'obj (make-c-unary-expr #\& symbol-expr)) 78 | (translate-string-constant-into-c 79 | symbol-name 'obj c-file nil symbols-func symbols-body :c-expr) 80 | (make-c-literal-expr (funcall 'tl:sxhash-string symbol-name)) 81 | (make-c-name-expr (if package? package-var? "NULL")))) 82 | symbols-body) 83 | 84 | ;; Mark the external bit on symbols that are external to their package. 85 | (when package? 86 | (multiple-value-bind (new-sym internal) 87 | (find-symbol symbol-name package?) 88 | (declare (ignore new-sym)) 89 | (when (eq internal :external) 90 | (emit-expr-to-compound-statement 91 | (make-c-infix-expr 92 | (make-c-direct-selection-expr symbol-expr "external") 93 | "=" (make-c-literal-expr 1)) 94 | symbols-body)))) 95 | 96 | (cond ((or (eq package? *keyword-package*) (eq symbol 't)) 97 | ;; Hook up symbol-value to point to self. 98 | (emit-expr-to-compound-statement 99 | (make-c-infix-expr 100 | (make-c-direct-selection-expr symbol-expr "symbol_value") 101 | "=" (make-c-cast-expr 'obj (make-c-unary-expr #\& symbol-expr))) 102 | symbols-body)) 103 | ((memqp (tl:variable-information symbol) '(:special :constant)) 104 | (let ((c-value-var-name (c-identifier-for-variable 105 | symbol *global-c-namespace* 106 | (c-func-namespace symbols-func)))) 107 | (when (register-used-variable 108 | c-file symbol c-value-var-name 'obj) 109 | (register-needed-variable-extern 110 | c-file '("extern") 'obj c-value-var-name)) 111 | ;; Hook up non-local-value pointer. 112 | (emit-expr-to-compound-statement 113 | (make-c-infix-expr 114 | (make-c-direct-selection-expr symbol-expr "local_value") 115 | "=" (make-c-literal-expr 0)) 116 | symbols-body) 117 | 118 | (emit-expr-to-compound-statement 119 | (make-c-infix-expr 120 | (make-c-direct-selection-expr symbol-expr "symbol_value") 121 | "=" (make-c-cast-expr 122 | 'obj (make-c-unary-expr 123 | #\& (make-c-name-expr 124 | c-value-var-name)))) 125 | symbols-body)))) 126 | ;; Hook up a compiled-function constant to this symbol when the 127 | ;; function-type of the symbol is :function, and when it does not have a 128 | ;; direct C translation function. 129 | (multiple-value-bind (function-type? local? decls) 130 | (tl:function-information symbol) 131 | (declare (ignore local?)) 132 | (when (and (eq function-type? :function) 133 | (or (assq 'computed-ftype decls) 134 | (assq 'ftype decls)) 135 | (not (assq 'c-translator decls))) 136 | ;; Hook up symbol-function pointer to a compiled-function. 137 | (emit-expr-to-compound-statement 138 | (make-c-infix-expr 139 | (make-c-direct-selection-expr symbol-expr "symbol_function") 140 | "=" (translate-compiled-function-constant-into-c 141 | symbol decls c-file nil symbols-func symbols-body :c-expr)) 142 | symbols-body)))))) 143 | -------------------------------------------------------------------------------- /tlt/lisp/symbols.txt: -------------------------------------------------------------------------------- 1 | This file was generated by Rick Harris to show which symbols from the Chestnut 2 | RTL we link against. This can be used as a first approximation about what 3 | runtime library routines we will have to build. 4 | -------------------- 5 | 6 | @ means g2 only (not gsi) 7 | 8 | --- initialization --- 9 | initialization of lists, arrays, floats, 10 | functions, bignums, packages, strings, 11 | and symbols 12 | initialization of variables 13 | 14 | --- memory allocation --- 15 | adjust-area-target-sizes 16 | allocate-memory-to-target 17 | area-memory-limit 18 | area-memory-used 19 | restore-frontier 20 | room 21 | 22 | --- other --- 23 | sleep @ 24 | %pointer 25 | 26 | --- error system --- 27 | break 28 | cerror 29 | exit @ 30 | 31 | --- control flow --- 32 | catch, throw 33 | block, return-from 34 | tagbody, go 35 | unwind-protect 36 | 37 | --- functions --- 38 | MAKE-FUNCTION @ 39 | functionp @ 40 | 41 | --- function calling and return --- 42 | optional, keyword, and rest arguments 43 | multiple values 44 | apply 45 | funcall 46 | mapcar @ 47 | 48 | --- numbers --- 49 | + - * / 50 | < <= = >= /= 51 | 1- 1+ 52 | max 53 | min 54 | truncate 55 | mod 56 | rem 57 | minusp 58 | plusp 59 | zerop 60 | ceiling 61 | fceiling 62 | fround 63 | integer-length 64 | abs 65 | random 66 | round 67 | ffloor 68 | floor 69 | ftruncate 70 | atan @ 71 | cos @ 72 | expt @ 73 | log @ 74 | sin @ 75 | sqrt @ 76 | 77 | --- integers --- 78 | ash 79 | evenp @ 80 | oddp @ 81 | isqrt @ 82 | logand 83 | logandc2 84 | logbitp 85 | logior 86 | lognot 87 | logtest 88 | logxor 89 | 90 | --- floats --- 91 | float 92 | scale-float @ 93 | 94 | --- number conversions --- 95 | cdouble-to-double 96 | clong-to-bignum 97 | integer-to-long 98 | 99 | --- time --- 100 | encode-universal-time @ 101 | get-universal-time @ 102 | 103 | --- streams --- 104 | extend-string-output-stream @ 105 | get-output-stream-string @ 106 | make-broadcast-stream 107 | make-string-output-stream @ 108 | 109 | --- hashing --- 110 | sxhash @ 111 | 112 | --- pathnames --- 113 | directory-namestring @ 114 | merge-pathnames @ 115 | pathname @ 116 | pathname-directory @ 117 | pathname-name @ 118 | pathname-type @ 119 | pathname-version @ 120 | make-pathname @ 121 | 122 | --- filesystem --- 123 | directory @ 124 | open @ 125 | close @ 126 | file-write-date 127 | probe-file @ 128 | 129 | --- input --- 130 | read @ 131 | read-line @ 132 | read-from-string @ 133 | 134 | --- output --- 135 | force-output @ 136 | format @ 137 | princ @ 138 | print @ 139 | terpri @ 140 | write-char @ 141 | write-string @ 142 | 143 | --- eval --- 144 | eval-run @ 145 | macroexpand @ 146 | 147 | --- symbols --- 148 | gensym 149 | make-symbol 150 | symbol-value, setf 151 | symbol-function, setf 152 | set 153 | boundp 154 | fboundp 155 | fmakunbound 156 | symbol-package 157 | symbol-name 158 | 159 | --- packages --- 160 | export 161 | find-package 162 | find-symbol 163 | import 164 | intern 165 | make-package 166 | package-name @ 167 | package-use-list @ 168 | 169 | --- plists --- 170 | do-remf 171 | get, setf 172 | getf,setf 173 | remprop 174 | 175 | --- arrays --- 176 | aref, setf 177 | array-dimension 178 | array-element-type @ 179 | array-total-size 180 | make-array 181 | vector @ 182 | 183 | --- lists --- 184 | cons 185 | fifth 186 | copy-list @ 187 | copy-tree @ 188 | append 189 | nconc 190 | assoc @ 191 | last 192 | list 193 | list-length 194 | list* 195 | make-list 196 | ncons 197 | nth 198 | nthcdr 199 | nreconc @ 200 | member 201 | set-difference @ 202 | set-exclusive-or @ 203 | union 204 | assoc 205 | nsubst @ 206 | 207 | --- sequences --- 208 | elt @ 209 | length 210 | concatenate @ 211 | copy-seq @ 212 | delete @ 213 | nreverse 214 | reverse 215 | subseq @ 216 | adjoin 217 | count @ 218 | delete @ 219 | fill @ 220 | find @ 221 | position 222 | rassoc @ 223 | remove-if @ 224 | remove @ 225 | replace @ 226 | search @ 227 | sort @ 228 | substitute @ 229 | 230 | --- strings --- 231 | SI-istring 232 | SI-string-base 233 | string 234 | string-append 235 | make-string 236 | nstring-downcase @ 237 | nstring-upcase 238 | string-downcase 239 | string-eq 240 | string-equal 241 | string-greaterp @ 242 | string-lessp @ 243 | string-lt @ 244 | string-not-equal @ 245 | string-not-greaterp @ 246 | string-not-lessp @ 247 | string-upcase @ 248 | 249 | --- characters --- 250 | digit-char 251 | digit-char-p 252 | 253 | --- equality --- 254 | eq 255 | eql 256 | equal 257 | 258 | --- types --- 259 | type-of @ 260 | 261 | 262 | 263 | -------------------------------------------------------------------------------- /tlt/lisp/tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package "TL") 2 | 3 | (defun svref (a b) 4 | (declare (simple-vector a) 5 | (fixnum b) 6 | (return-type t)) 7 | (aref a b)) 8 | 9 | (defun uffda (x y) 10 | (svref x y)) 11 | 12 | (defun frob (x y) 13 | (declare (fixnum x y)) 14 | (+ x y)) 15 | 16 | (defun frob-2 (x y) 17 | (declare (return-type fixnum) 18 | (fixnum x)) 19 | (+ x (the fixnum y))) 20 | 21 | (defun frob-3 (x y) 22 | (declare (return-type fixnum) (fixnum x)) 23 | (+ x y)) 24 | 25 | (defun frob-4 (x y) 26 | (declare (return-type fixnum) (fixnum x) (type t y)) 27 | (+ x y)) 28 | 29 | (defun frob-5 (x y) 30 | (+ x y)) 31 | 32 | (defun uffda (x y z) 33 | (declare (fixnum x y z) 34 | (return-type fixnum)) 35 | (let ((a (+ x y)) 36 | (b (- y z))) 37 | (declare (fixnum a b)) 38 | (let ((c b)) 39 | (declare (fixnum c)) 40 | (+ a c)))) 41 | 42 | (defun uffda2 (x y z) 43 | (declare (fixnum x y z) 44 | (return-type fixnum)) 45 | (let* ((a (+ x y)) 46 | (b (- y z)) 47 | (d (+ a b))) 48 | (declare (fixnum a b d)) 49 | (let ((c b)) 50 | (declare (fixnum c)) 51 | (+ a c)))) 52 | 53 | (defun lotsa-values () 54 | (declare (return-type *)) 55 | 23) 56 | 57 | (defun some-values () 58 | (values 1 2 3)) 59 | 60 | (defun mvp1-test () 61 | (multiple-value-prog1 (lotsa-values) 62 | (lotsa-values))) 63 | 64 | (defun mvp1-test2 () 65 | (declare (return-type fixnum)) 66 | (multiple-value-prog1 (uffda2 1 2 3) 67 | (lotsa-values))) 68 | 69 | (defun multiple-value-test () 70 | (declare (return-type t)) 71 | (multiple-value-bind (a b) (lotsa-values) 72 | (if b 73 | (+ a b) 74 | (if a 75 | (+ a a) 76 | nil)))) 77 | 78 | (defun mvb-2 () 79 | (multiple-value-bind (a b) (values 1 2) 80 | (declare (number a b) 81 | (fat-and-slow)) 82 | (+ a b))) 83 | 84 | (defun mvb-3 () 85 | (declare (optimize (safety 3))) 86 | (multiple-value-bind (a b) 87 | (lotsa-values) 88 | (declare (fixnum a b)) 89 | (> a b))) 90 | 91 | 92 | (defun simple-return-from (a b) 93 | (declare (fixnum a b)) 94 | (if (> a 1) 95 | (return-from simple-return-from a) 96 | (setq a (- a))) 97 | (+ a b)) 98 | 99 | (defun simple-return-from1 (a b) 100 | (declare (fixnum a b) (return-type (values fixnum))) 101 | (if (> a 1) 102 | (return-from simple-return-from a) 103 | (setq a (- a))) 104 | (+ a b)) 105 | 106 | (defun simple-unwind-protect (a b) 107 | (declare (fixnum a b)) 108 | (unwind-protect 109 | (if (> a 23) 110 | (+ a b) 111 | (return-from simple-unwind-protect b)) 112 | (simple-return-from a b))) 113 | 114 | (defun unwind-protect-test (a b) 115 | (declare (fixnum a b)) 116 | (tagbody 117 | (return-from unwind-protect-test 118 | (unwind-protect 119 | (if (> a 23) 120 | (if (< b 12) 121 | (+ a b) 122 | (go other-exit)) 123 | (return-from unwind-protect-test b)) 124 | (simple-return-from a b))) 125 | other-exit 126 | (return-from unwind-protect-test 23))) 127 | 128 | (defun throw-test (a b) 129 | (throw a b)) 130 | 131 | 132 | (progn 133 | 134 | (defvar thingee 1) 135 | 136 | (defparameter thingee2 2) 137 | 138 | (defconstant thingee3 3) 139 | 140 | (defun thingee-all () 141 | (declare (fat-and-slow)) 142 | (+ thingee thingee2 thingee3))) 143 | 144 | (defun a-string () 145 | (declare (return-type t)) 146 | "Yowsa") 147 | 148 | (progn 149 | (defconstant byte-array 150 | #.(lisp:make-array 10 :element-type '(unsigned-byte 8) :initial-element 9)) 151 | (defconstant double-byte-array 152 | #.(lisp:make-array 15 :element-type '(unsigned-byte 16) :initial-element 132))) 153 | 154 | (progn 155 | (defconstant list-1 '(1 2 3 4 "Uffda" (5 nil . 8) 23)) 156 | (defconstant list-2 (quote #.(let ((a (lisp:list 1 2 3))) (lisp:setf (lisp:cdr (lisp:last a)) a) a))) 157 | (defconstant list-3 (quote #.(let ((a (lisp:list nil 2 3))) (lisp:setf (lisp:car a) a) a)))) 158 | 159 | (defun and-test1 (a b) 160 | (and a (< a b))) 161 | 162 | (defun and-test2 (a b) 163 | (declare (return-type t)) 164 | (let ((result (and a b (< a b)))) 165 | result)) 166 | 167 | (defun and-test3 (a b) 168 | (declare (return-type t)) 169 | (if (and a b (not (< a b))) 170 | 1 171 | 2)) 172 | 173 | (defun or-test1 (a b c) 174 | (or a b c)) 175 | 176 | (defun or-test2 (a b c) 177 | (if (or a (progn (setq c 23) b) c) 178 | 1 2)) 179 | 180 | (defun or-test3 (a b c) 181 | (declare (return-type t)) 182 | (or a b c)) 183 | 184 | (defun set-second (a b) 185 | (setf (cdr (car (the cons a))) b)) 186 | 187 | 188 | (declare-system (gsi :library t :lisp-dir "lisp/") 189 | load 190 | bootstrap 191 | systems 192 | delta 193 | gsi-patches 194 | loop 195 | lisp-fixes 196 | tl-extension 197 | (tldebug :include-test :development) 198 | os-foreign 199 | basics 200 | os-time 201 | os-settings 202 | os-memory 203 | primitives 204 | characters 205 | utilities0 206 | utilities1 207 | utilities2 208 | utilities3 209 | os-error 210 | launch 211 | networks 212 | int1 213 | int2 214 | int3 215 | int4 216 | gsi-common 217 | rpc-common1 218 | rpc-common2 219 | gsi 220 | gsi-rpc1 221 | gsi-rpc2 222 | translate) 223 | -------------------------------------------------------------------------------- /tlt/lisp/tlt-trans.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ska80/thinlisp/173573a723256d901887f1cbc26d5403025879ca/tlt/lisp/tlt-trans.txt -------------------------------------------------------------------------------- /tlt/lisp/wish-list.txt: -------------------------------------------------------------------------------- 1 | ;;;; Module WISH-LIST 2 | 3 | ;;; Copyright (c) 1997 Gensym Corporation. 4 | ;;; All rights reserved. 5 | 6 | ;;; Jim Allard, Glenn Iba, and Ben Hyde 7 | 8 | 9 | 10 | 11 | ;;;; Things that need attention. 12 | 13 | The princ handling of pathnames in cmu lisp is different 14 | from other platforms. That should be patched and submitted 15 | back to them. 16 | 17 | Jim should review my change to avoid using packages that 18 | are otherwise not referenced in the translate. 19 | 20 | Jim should decide where to put the compile time error 21 | funtion derror, etc. 22 | 23 | Jim should decide where the unix-style-namestring function 24 | should really reside. 25 | 26 | We need to have a way for systems to declare thier C library 27 | dependencies, for example so -lm can appear on the unix makefile. 28 | 29 | 30 | ;;;; Wish List of Future Work 31 | 32 | 33 | This file should be added to whenever we see a thing we would like to do but 34 | can't quite justify right now. Please sign and date all wishes. 35 | 36 | 37 | 38 | 39 | For safety 3 translations, a bounds checked set of AREF, SET-AREF, ELT, and 40 | SET-ELT implementations for the type-specific translations. -jallard 3/6/97 41 | 42 | 43 | 44 | 45 | For safety 3 translations, a overflow detecting set of fixnum arithmetic 46 | operations for type-specific translations. Note that generic-plus and friends 47 | already perform overflow detection when translated safely. -jallard 3/6/97 48 | 49 | 50 | 51 | 52 | Declare static would make a function local to a file. -jallard 3/7/97 53 | 54 | 55 | 56 | 57 | Incremental translation and recompile: 58 | Only translate/recompile changed files or files that depend on changed files. 59 | When writing translator output files, check if there's really a change first, 60 | and if no change, don't write. Then the c compiler will see the old 61 | write date, and skip recomiling it. 62 | - giba 4/18/97 63 | 64 | 65 | 66 | 67 | Complete coverage of type-coercion possibilities: 68 | Handle coercions for all pairs of types. 69 | In lieu of (or until) that, have translation warnings generated when 70 | "bottoming out" on the void case. Have such warnings be "gated" by 71 | a declaration to suppress the warnings when the behavior of the 72 | void case is being relied upon. 73 | - giba 4/18/97 74 | 75 | 76 | 77 | 78 | For translated files with empty initialization functions, don't emit the 79 | function at all to allow for possible elimination of the object file from 80 | executables by the linker. This is related to the desire to have library 81 | initializations all happen within a single file. -jallard 4/22/97 82 | It's an olde C hack to move the init code into a single contigously 83 | linked segment where it will page in once, and then page out forever, 84 | that's typically done by placing the init functions in their own files, 85 | and then naming them zmod1 zmod2 hoping nobody names any modules starting 86 | with z. The linker command usually just happens to be in alphabetical 87 | order, and or the linker packs them in that order. - ben 24jul97 88 | 89 | 90 | 91 | 92 | Special variables are pushed using three slots on the binding stack. One of 93 | these is the opcode zero (aka restore special binding). There are 3 thousand 94 | lines doing those bindings in TW. That opcode could be avoided. First have the 95 | binding stack default to opcode zero. Other frames types are then denoted by 96 | some characteritic of the restore binding entry, say a unique address, that is 97 | never special bound (i.e. an address in the code segment). - ben 24jul97. 98 | 99 | 100 | 101 | 102 | This code 103 | getfq_function_no_default 104 | ((x!=NULL)?((Sym *)x)->symbol_plist : symbol_plist_of_nil,prop) 105 | would be better as: 106 | get_function_no_default(x) 107 | - ben 24jul97 108 | 109 | 110 | 111 | 112 | There are cases where a fixnum declaration makes the code worse. 113 | These arise in places where the variable is used in combination 114 | with less declared things: function calls, globals variables that are 115 | only locally declared fixnum, etc. and when the cost of the 116 | operations in the Lisp fixnum representation isn't that much 117 | less than the cost of sint32 operations. Of course this is a 118 | problem that might require significant compuation to find the 119 | best representation for the variable. This is an example 120 | typical of a surpizing number of loops. 121 | > (trans '(defun foo (x) (loop for i from 1 to 2 doing (foo i)))) 122 | Obj foo (Obj x) 123 | { 124 | sint32 i; 125 | 126 | i = 1; 127 | for (;!(i>2);i = (i+1)) 128 | foo((Obj)((i<<2)+1)); 129 | return (Obj)NULL; 130 | } 131 | This is another typical of most of the drawing code. 132 | > (defvar left-edge) 133 | > (defvar right-edge) 134 | > (trans '(defun foo (x) (>2)>2)) ? ((Obj)(&T)) : (Obj)NULL); 141 | Values_count = 1; 142 | return temp; 143 | } 144 | else { 145 | Values_count = 1; 146 | return (Obj)NULL; 147 | } 148 | } 149 | - ben 24jul97 150 | 151 | 152 | 153 | 154 | The init that sets up the symbols of each package. eg: 155 | insert_symbol_into_package(init_symbol((Obj)(&(tw_keydefs_symbols[68])), 156 | (Obj)(&str_const_73),331),cached_ab_package); /* "F35" */ 157 | of which there are 3.5K instances could be compacted in a number of ways. 158 | to make it both faster and smaller. The two function calls could 159 | be one. The package arg could be a global. The hash code 331 could 160 | be hidden in some slot of the uninitialized symbol. str_const_N of 161 | the same size could be placed in a table. 162 | - ben 24jul97 163 | 164 | 165 | 166 | 167 | Do we know how to add/ignore declarations in Lucid? 168 | - ben 29jul97 169 | 170 | 171 | 172 | I've always wished I could declare lexically that nonlocal 173 | exit was illegal. By example: 174 | (defmacro with-dirt (() &body body) 175 | `(locally (declare disallow-lexical-exit) 176 | (dirty) 177 | (prog1 ,@body 178 | (clean)))) 179 | I want to be sure clean gets done, at least lexically, 180 | but if the user does: 181 | (block nil (with-dirt (return :mud))) 182 | he should get a warning. 183 | - ben 29jul97 184 | 185 | 186 | 187 | 188 | I've always wanted access to a denotation for the 189 | top level form so I could write warnings in macros 190 | that mention it. 191 | - ben 29jul97 192 | 193 | 194 | pm-print should do something more helpful for wide strings. 195 | - ben 29jull97 196 | (I believe this is fixed now ben 7aug97) 197 | 198 | 199 | 200 | Fix the bug that the :fill-pointer argument to make-array is essentially 201 | ignored. (I.e., the value isn't slammed into the newly made array.) 202 | -jallard 7/29/97 203 | 204 | 205 | 206 | 207 | Make-wide-string and friends should be changed to use the fill-pointer already 208 | in (array (unsigned-byte 16)). -jallard 7/29/97 209 | 210 | 211 | It looks to me as if we have enough info to warn of unused 212 | C functions, and possibly to automaticly eliminate them. 213 | Of course a declaration of use might be required for debugging 214 | functions. 215 | - ben 29jul97 216 | 217 | 218 | A function that takes an object and returns some indication of 219 | it's plausablity as a Lisp object would be a big help in 220 | the GDB debugging tools. Such a function might check that 221 | the object was allocated in with in the address space of 222 | the process, and that it's header had a reasonable value 223 | stored in it. Just for fun it might return the type of 224 | the object as well. - ben 7aug97 225 | 226 | 227 | pm-print prints integral floats without a decmal point, bummer. 228 | - ben 8aug97 229 | (I'm taking a stab at that by improving the value returned by 230 | pm-type-of, which is used by pm-describe) 231 | 232 | 233 | --------------------------------------------------------------------------------