├── LICENSE ├── README ├── compiler ├── implementation.lisp ├── libc-support.lisp ├── package.lisp ├── reader.lisp ├── state.lisp └── type.lisp ├── contributors ├── libc ├── ctype.lisp ├── errno.lisp ├── fcntl.h ├── include │ ├── Sys │ │ ├── stat.h │ │ ├── time.h │ │ ├── times.h │ │ └── types.h │ ├── float.h │ ├── setjmp.h │ ├── signal.h │ ├── stddef.h │ └── unistd.h ├── math.lisp ├── package.lisp ├── scanf.c ├── stdarg.h ├── stdarg.lisp ├── stdbool.h ├── stddef.lisp ├── stdio.h ├── stdio.lisp ├── stdlib.h ├── stdlib.lisp ├── string.c └── string.lisp ├── runtime └── program.lisp ├── test ├── basic-tests.lisp ├── package.lisp ├── program-tests.lisp ├── programs │ ├── define-function1 │ │ └── main.c │ ├── different-comment-styles │ │ ├── foobar.h │ │ └── main.c │ ├── hanly-113 │ │ └── main.c │ ├── hanly-83-scanf │ │ └── main.c │ ├── hanly-83 │ │ └── main.c │ ├── hardway-ex3 │ │ └── main.c │ ├── hello-world │ │ └── main.c │ ├── hello-world0 │ │ └── main.c │ ├── hs-while-string-copy │ │ └── main.c │ ├── if-then-else1 │ │ └── main.c │ ├── if-then-else2 │ │ └── main.c │ ├── inc-deref-associativity │ │ └── main.c │ ├── include-libc │ │ └── main.c │ ├── kr-echo │ │ └── main.c │ ├── kr-pg12 │ │ ├── main │ │ └── main.c │ ├── kr-pg16 │ │ └── main.c │ ├── main-return-include │ │ ├── foobar.h │ │ └── main.c │ ├── main-return-include1 │ │ ├── foobar.h │ │ └── main.c │ ├── main-return │ │ └── main.c │ ├── pointer-lvalue2 │ │ └── main.c │ ├── ptr-decl1 │ │ └── main.c │ └── varargs1 │ │ └── main.c ├── reader-tests.lisp └── test.lisp ├── vacietis.asd ├── vacietis.test.asd ├── vacietis.vcc.asd ├── vcc ├── package.lisp └── vcc.lisp └── zclib.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | Vacietis compiler license. All parts of Vacietis are licensed under 2 | the terms of the LLGPL 3 | 4 | Vacietis is copyright (C) 2010, 2011, 2012 Vladimir Sedach 5 | , unless otherwise noted 6 | 7 | This library is free software; you can redistribute it and/or modify 8 | it under the terms of the Lisp Lesser General Public License, which 9 | consists of the GNU Lesser General Public License version 3 as 10 | published by the Free Software Foundation and the Franz preamble. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | --------- 18 | 19 | The text of the LLGPL terms and conditions follows: 20 | 21 | Preamble to the Gnu Lesser General Public License 22 | 23 | Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 24 | 25 | The concept of the GNU Lesser General Public License version 3 26 | ("LGPL") has been adopted to govern the use and distribution of 27 | above-mentioned application. However, the LGPL uses terminology that 28 | is more appropriate for a program written in C than one written in 29 | Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if 30 | certain clarifications are made. This document details those 31 | clarifications. Accordingly, the license for the open-source Lisp 32 | applications consists of this document plus the LGPL. Wherever there 33 | is a conflict between this document and the LGPL, this document takes 34 | precedence over the LGPL. 35 | 36 | A "Library" in Lisp is a collection of Lisp functions, data and 37 | foreign modules. The form of the Library can be Lisp source code (for 38 | processing by an interpreter) or object code (usually the result of 39 | compilation of source code or built with some other 40 | mechanisms). Foreign modules are object code in a form that can be 41 | linked into a Lisp executable. When we speak of functions we do so in 42 | the most general way to include, in addition, methods and unnamed 43 | functions. Lisp "data" is also a general term that includes the data 44 | structures resulting from defining Lisp classes. A Lisp application 45 | may include the same set of Lisp objects as does a Library, but this 46 | does not mean that the application is necessarily a "work based on the 47 | Library" it contains. 48 | 49 | The Library consists of everything in the distribution file set before 50 | any modifications are made to the files. If any of the functions or 51 | classes in the Library are redefined in other files, then those 52 | redefinitions ARE considered a work based on the Library. If 53 | additional methods are added to generic functions in the Library, 54 | those additional methods are NOT considered a work based on the 55 | Library. If Library classes are subclassed, these subclasses are NOT 56 | considered a work based on the Library. If the Library is modified to 57 | explicitly call other functions that are neither part of Lisp itself 58 | nor an available add-on module to Lisp, then the functions called by 59 | the modified Library ARE considered a work based on the Library. The 60 | goal is to ensure that the Library will compile and run without 61 | getting undefined function errors. 62 | 63 | It is permitted to add proprietary source code to the Library, but it 64 | must be done in a way such that the Library will still run without 65 | that proprietary code present. Section 5 of the LGPL distinguishes 66 | between the case of a library being dynamically linked at runtime and 67 | one being statically linked at build time. Section 5 of the LGPL 68 | states that the former results in an executable that is a "work that 69 | uses the Library." Section 5 of the LGPL states that the latter 70 | results in one that is a "derivative of the Library", which is 71 | therefore covered by the LGPL. Since Lisp only offers one choice, 72 | which is to link the Library into an executable at build time, we 73 | declare that, for the purpose applying the LGPL to the Library, an 74 | executable that results from linking a "work that uses the Library" 75 | with the Library is considered a "work that uses the Library" and is 76 | therefore NOT covered by the LGPL. 77 | 78 | Because of this declaration, section 6 of LGPL is not applicable to 79 | the Library. However, in connection with each distribution of this 80 | executable, you must also deliver, in accordance with the terms and 81 | conditions of the LGPL, the source code of Library (or your derivative 82 | thereof) that is incorporated into this executable. 83 | 84 | End of Preamble 85 | 86 | GNU LESSER GENERAL PUBLIC LICENSE 87 | Version 3, 29 June 2007 88 | 89 | Copyright (C) 2007 Free Software Foundation, Inc. 90 | Everyone is permitted to copy and distribute verbatim copies 91 | of this license document, but changing it is not allowed. 92 | 93 | 94 | This version of the GNU Lesser General Public License incorporates 95 | the terms and conditions of version 3 of the GNU General Public 96 | License, supplemented by the additional permissions listed below. 97 | 98 | 0. Additional Definitions. 99 | 100 | As used herein, "this License" refers to version 3 of the GNU Lesser 101 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 102 | General Public License. 103 | 104 | "The Library" refers to a covered work governed by this License, 105 | other than an Application or a Combined Work as defined below. 106 | 107 | An "Application" is any work that makes use of an interface provided 108 | by the Library, but which is not otherwise based on the Library. 109 | Defining a subclass of a class defined by the Library is deemed a mode 110 | of using an interface provided by the Library. 111 | 112 | A "Combined Work" is a work produced by combining or linking an 113 | Application with the Library. The particular version of the Library 114 | with which the Combined Work was made is also called the "Linked 115 | Version". 116 | 117 | The "Minimal Corresponding Source" for a Combined Work means the 118 | Corresponding Source for the Combined Work, excluding any source code 119 | for portions of the Combined Work that, considered in isolation, are 120 | based on the Application, and not on the Linked Version. 121 | 122 | The "Corresponding Application Code" for a Combined Work means the 123 | object code and/or source code for the Application, including any data 124 | and utility programs needed for reproducing the Combined Work from the 125 | Application, but excluding the System Libraries of the Combined Work. 126 | 127 | 1. Exception to Section 3 of the GNU GPL. 128 | 129 | You may convey a covered work under sections 3 and 4 of this License 130 | without being bound by section 3 of the GNU GPL. 131 | 132 | 2. Conveying Modified Versions. 133 | 134 | If you modify a copy of the Library, and, in your modifications, a 135 | facility refers to a function or data to be supplied by an Application 136 | that uses the facility (other than as an argument passed when the 137 | facility is invoked), then you may convey a copy of the modified 138 | version: 139 | 140 | a) under this License, provided that you make a good faith effort to 141 | ensure that, in the event an Application does not supply the 142 | function or data, the facility still operates, and performs 143 | whatever part of its purpose remains meaningful, or 144 | 145 | b) under the GNU GPL, with none of the additional permissions of 146 | this License applicable to that copy. 147 | 148 | 3. Object Code Incorporating Material from Library Header Files. 149 | 150 | The object code form of an Application may incorporate material from 151 | a header file that is part of the Library. You may convey such object 152 | code under terms of your choice, provided that, if the incorporated 153 | material is not limited to numerical parameters, data structure 154 | layouts and accessors, or small macros, inline functions and templates 155 | (ten or fewer lines in length), you do both of the following: 156 | 157 | a) Give prominent notice with each copy of the object code that the 158 | Library is used in it and that the Library and its use are 159 | covered by this License. 160 | 161 | b) Accompany the object code with a copy of the GNU GPL and this license 162 | document. 163 | 164 | 4. Combined Works. 165 | 166 | You may convey a Combined Work under terms of your choice that, 167 | taken together, effectively do not restrict modification of the 168 | portions of the Library contained in the Combined Work and reverse 169 | engineering for debugging such modifications, if you also do each of 170 | the following: 171 | 172 | a) Give prominent notice with each copy of the Combined Work that 173 | the Library is used in it and that the Library and its use are 174 | covered by this License. 175 | 176 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 177 | document. 178 | 179 | c) For a Combined Work that displays copyright notices during 180 | execution, include the copyright notice for the Library among 181 | these notices, as well as a reference directing the user to the 182 | copies of the GNU GPL and this license document. 183 | 184 | d) Do one of the following: 185 | 186 | 0) Convey the Minimal Corresponding Source under the terms of this 187 | License, and the Corresponding Application Code in a form 188 | suitable for, and under terms that permit, the user to 189 | recombine or relink the Application with a modified version of 190 | the Linked Version to produce a modified Combined Work, in the 191 | manner specified by section 6 of the GNU GPL for conveying 192 | Corresponding Source. 193 | 194 | 1) Use a suitable shared library mechanism for linking with the 195 | Library. A suitable mechanism is one that (a) uses at run time 196 | a copy of the Library already present on the user's computer 197 | system, and (b) will operate properly with a modified version 198 | of the Library that is interface-compatible with the Linked 199 | Version. 200 | 201 | e) Provide Installation Information, but only if you would otherwise 202 | be required to provide such information under section 6 of the 203 | GNU GPL, and only to the extent that such information is 204 | necessary to install and execute a modified version of the 205 | Combined Work produced by recombining or relinking the 206 | Application with a modified version of the Linked Version. (If 207 | you use option 4d0, the Installation Information must accompany 208 | the Minimal Corresponding Source and Corresponding Application 209 | Code. If you use option 4d1, you must provide the Installation 210 | Information in the manner specified by section 6 of the GNU GPL 211 | for conveying Corresponding Source.) 212 | 213 | 5. Combined Libraries. 214 | 215 | You may place library facilities that are a work based on the 216 | Library side by side in a single library together with other library 217 | facilities that are not Applications and are not covered by this 218 | License, and convey such a combined library under terms of your 219 | choice, if you do both of the following: 220 | 221 | a) Accompany the combined library with a copy of the same work based 222 | on the Library, uncombined with any other library facilities, 223 | conveyed under the terms of this License. 224 | 225 | b) Give prominent notice with the combined library that part of it 226 | is a work based on the Library, and explaining where to find the 227 | accompanying uncombined form of the same work. 228 | 229 | 6. Revised Versions of the GNU Lesser General Public License. 230 | 231 | The Free Software Foundation may publish revised and/or new versions 232 | of the GNU Lesser General Public License from time to time. Such new 233 | versions will be similar in spirit to the present version, but may 234 | differ in detail to address new problems or concerns. 235 | 236 | Each version is given a distinguishing version number. If the 237 | Library as you received it specifies that a certain numbered version 238 | of the GNU Lesser General Public License "or any later version" 239 | applies to it, you have the option of following the terms and 240 | conditions either of that published version or of any later version 241 | published by the Free Software Foundation. If the Library as you 242 | received it does not specify a version number of the GNU Lesser 243 | General Public License, you may choose any version of the GNU Lesser 244 | General Public License ever published by the Free Software Foundation. 245 | 246 | If the Library as you received it specifies that a proxy can decide 247 | whether future versions of the GNU Lesser General Public License shall 248 | apply, that proxy's public statement of acceptance of any version is 249 | permanent authorization for you to choose that version for the 250 | Library. 251 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Vacietis is a C compiler for Common Lisp systems. 2 | 3 | Vacietis works by loading C code into a Common Lisp runtime as though 4 | it were Lisp code, where it can then be compiled or evaled. The loaded 5 | C code has the same function calling convention as regular CL code and 6 | uses the same numerical representations. C memory is backed by regular 7 | Common Lisp arrays. 8 | 9 | Vacietis comes with a libc implemented in portable Common Lisp. 10 | 11 | 12 | * INSTALLING: 13 | ---------- 14 | 15 | You can obtain Vacietis from github: 16 | git clone https://github.com/vsedach/Vacietis.git 17 | 18 | All Vacietis dependencies are available via Quicklisp 19 | (http://www.quicklisp.org/). If you put Vacietis in 20 | quicklisp/local-projects/ you can just load it with 21 | (ql:quickload "vacietis") 22 | 23 | 24 | * USAGE: 25 | ----- 26 | 27 | C code can be read in the same way as regular Lisp code by using 28 | readtables: 29 | 30 | (let ((*readtable* vacietis:c-readtable) 31 | (vacietis:*compiler-state* (vacietis:make-compiler-state))) 32 | (read )) 33 | 34 | The Vacietis reader keeps track of type and preprocessor 35 | macro declarations in a compiler state object bound by 36 | *compiler-state*. This mechanism is exposed to make it possible to 37 | create things like C REPLs. 38 | 39 | To simplify loading C files, a convenience function is provided that 40 | sets up the readtable, compiler state, and additional debugging 41 | information before calling LOAD: 42 | 43 | (vacietis:load-c-file "/foo/bar/file.c") 44 | 45 | 46 | * COMPILER EXECUTABLE: 47 | ------------------- 48 | 49 | The system vacietis.vcc produces a toy C compiler executable that can 50 | take a single-file C program and produce an executable 51 | program. Currently it needs CCL, CLISP, or SBCL to work. Sample run: 52 | 53 | (ql:quickload "vacietis.vcc") will produce the executable vcc/vcc in 54 | the Vacietis source directory. 55 | 56 | $ ./vcc ../test/programs/hanly-83-scanf/main.c 57 | 58 | Produces the file a.out in the current directory. 59 | 60 | $ ./a.out 61 | Enter 8 numbers separated by blanks or s 62 | > 63 | 64 | 65 | * TECHNICAL DETAILS: 66 | ----------------- 67 | 68 | Vacietis uses the memory model of Common Lisp as is, so sizeof of the 69 | primitive data types (char, int, float etc.) is all 1. This shouldn't 70 | be a problem for most C code, but some C programs claim to be portable 71 | while making assumptions that things can be cast into an array of 72 | chars to be manipulated. These programs won't work under Vacietis. 73 | 74 | The basic idea for the Vacietis runtime and memory model comes from 75 | Scott L. Burson's Zeta-C compiler for Lisp Machines: 76 | http://www.bitsavers.org/bits/TI/Explorer/zeta-c/ 77 | 78 | The technique for representing pointers to arbitrary C lvalues as 79 | closures was first demonstrated by Oleg Kiselyov: 80 | http://okmij.org/ftp/Scheme/pointer-as-closure.txt 81 | 82 | The idea for a combined single-pass preprocessor/tokenizer/parser 83 | comes from Fabrice Bellard's TCC: http://bellard.org/tcc/ 84 | 85 | 86 | * OBTAINING CODE AND HELP: 87 | ----------------------- 88 | 89 | The official Vacietis repository is at: 90 | https://github.com/vsedach/vacietis 91 | 92 | There is a Vacietis mailing list on the web: 93 | http://groups.google.com/group/vacietis 94 | 95 | Bug reports can be sent to the mailing list: 96 | http://groups.google.com/group/vacietis 97 | the github issue tracker: 98 | https://github.com/vsedach/vacietis 99 | or directly to the author: 100 | vsedach@gmail.com 101 | 102 | 103 | * UNIT TESTS: 104 | ---------- 105 | 106 | (ql:quickload "vacietis.test") 107 | (vacietis.test:run-tests) 108 | (eos:run! 'vacietis.test.reader::preprocessor-nested) ; individual test case 109 | 110 | The Vacietis test suite includes a variety of code that tests the 111 | compiler and libc. 112 | 113 | 114 | * TODO: 115 | ---- 116 | - pointer scaling 117 | - enums: assignment of arbitrary values to enum labels 118 | - struct call by value 119 | - pass arguments to main() 120 | - implement overloading class scope correctly (see H&S p. 147) 121 | - libc stdio: binary streams 122 | - libc stddef: offsetof 123 | - libc signal 124 | - libc stdlib: div/ldiv, srand, exit cleanup, bsearch, qsort 125 | - libc time 126 | - libc setjmp 127 | 128 | 129 | * THINGS THAT PROBABLY WON'T BE SUPPORTED: 130 | --------------------------------------- 131 | - trying to cast arrays of chars to other types (mmap) 132 | - any kind of GCC extension 133 | 134 | 135 | * LICENSING INFORMATION 136 | --------------------- 137 | 138 | Vacietis is authored by Vladimir Sedach ; the 139 | latest copyright year is 2012. 140 | 141 | Vacietis is licensed under the LLGPL (see the file LICENSE included 142 | with the distribution for details). 143 | 144 | Portions of the Vacietis libc may be derived from Zeta-C (released 145 | into the public domain by its author, Scott L. Burson) and Erik 146 | Andersen's LGPL-licensed uClibc 147 | (http://www.uclibc.org/) 148 | -------------------------------------------------------------------------------- /compiler/implementation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis) 2 | (in-readtable vacietis) 3 | 4 | (declaim (optimize (debug 3))) 5 | 6 | ;;; unary operators 7 | 8 | (defmacro def-unary-op (c lisp) 9 | (let ((x (gensym))) 10 | `(defmacro ,c (,x) 11 | `(,',lisp ,,x)))) 12 | 13 | ;;; binary arithmetic 14 | 15 | (defmacro define-binary-op-mapping-definer (name &body body) 16 | `(defmacro ,name (&rest map) 17 | `(progn ,@(loop for (vacietis cl) on map by #'cddr collect 18 | (let ((op (find-symbol (symbol-name vacietis) '#:vacietis.c))) 19 | ,@body))))) 20 | 21 | (define-binary-op-mapping-definer define-binary-ops 22 | `(progn (declaim (inline ,op)) 23 | (defun ,op (x y) 24 | (,cl x y)))) 25 | 26 | (define-binary-ops 27 | |\|| logior 28 | ^ logxor 29 | & logand 30 | * * 31 | / (lambda (x y) 32 | (if (and (integerp x) (integerp y)) 33 | (truncate x y) 34 | (/ x y))) 35 | % rem 36 | << ash 37 | >> (lambda (int count) (ash int (- count)))) 38 | 39 | (def-unary-op vacietis.c:~ lognot) 40 | 41 | ;;; pointers, storage units and allocation 42 | 43 | (defstruct memptr 44 | mem 45 | (ptr 0)) 46 | 47 | (defun string-to-char* (string) 48 | (make-memptr 49 | :mem (let ((unicode (babel:string-to-octets string :encoding :utf-8))) 50 | (adjust-array unicode (1+ (length unicode)) :initial-element 0)))) 51 | 52 | (defun char*-to-string (char*) 53 | (let* ((mem (memptr-mem char*)) 54 | (start (memptr-ptr char*)) 55 | (end (position 0 mem :start start)) 56 | (byte-array (make-array (- end start) :element-type '(unsigned-byte 8)))) 57 | (replace byte-array mem :start2 start :end2 end) 58 | (babel:octets-to-string byte-array :encoding :utf-8))) 59 | 60 | (defun allocate-memory (size) 61 | (make-memptr :mem (make-array size :adjustable t :initial-element 0))) 62 | 63 | (defstruct place-ptr 64 | closure) 65 | 66 | (defmacro vacietis.c:mkptr& (place) ;; need to deal w/function pointers 67 | (let ((new-value (gensym)) 68 | (place (macroexpand place))) 69 | (if (and (consp place) (eq 'vacietis.c:deref* (elt place 0))) 70 | (elt place 1) 71 | `(make-place-ptr :closure (lambda (&optional ,new-value) 72 | (if ,new-value 73 | (setf ,place ,new-value) 74 | ,place)))))) 75 | 76 | (defun vacietis.c:deref* (ptr) 77 | (etypecase ptr 78 | (memptr (aref (memptr-mem ptr) (memptr-ptr ptr))) 79 | (place-ptr (funcall (place-ptr-closure ptr))))) 80 | 81 | (defun (setf vacietis.c:deref*) (new-value ptr) 82 | (etypecase ptr 83 | (memptr (setf (aref (memptr-mem ptr) (memptr-ptr ptr)) new-value)) 84 | (place-ptr (funcall (place-ptr-closure ptr) new-value)))) 85 | 86 | (defmacro vacietis.c:[] (a i) 87 | `(vacietis.c:deref* (vacietis.c:+ ,a ,i))) 88 | 89 | (defmacro vacietis.c:|.| (x i) 90 | (if (and (consp x) (eq 'vacietis.c:|.| (elt x 0))) 91 | `(vacietis.c:|.| ,(elt x 1) ,(+ (elt x 2) i)) 92 | `(aref ,x ,i))) 93 | 94 | ;;; arithmetic 95 | 96 | ;; things that operate on pointers: + - < > <= >= == != ++ -- ! 97 | 98 | ;; may want to make these methods into cases in inlineable functions 99 | 100 | (defmethod vacietis.c:+ ((x number) (y number)) 101 | (+ x y)) 102 | 103 | (defmethod vacietis.c:+ ((ptr memptr) (x integer)) 104 | (make-memptr :mem (memptr-mem ptr) :ptr (+ x (memptr-ptr ptr)))) 105 | 106 | (defmethod vacietis.c:+ ((x integer) (ptr memptr)) 107 | (vacietis.c:+ ptr x)) 108 | 109 | (defmethod vacietis.c:- ((x number) (y number)) 110 | (- x y)) 111 | 112 | (defmethod vacietis.c:- ((ptr memptr) (x integer)) 113 | (make-memptr :mem (memptr-mem ptr) :ptr (- (memptr-ptr ptr) x))) 114 | 115 | (defmethod vacietis.c:- ((ptr1 memptr) (ptr2 memptr)) 116 | (assert (eq (memptr-mem ptr1) (memptr-mem ptr2)) () 117 | "Trying to subtract pointers from two different memory segments") 118 | (- (memptr-ptr ptr1) (memptr-ptr ptr2))) 119 | 120 | ;;; comparison operators 121 | 122 | (define-binary-op-mapping-definer define-comparison-ops 123 | `(progn (defmethod ,op ((x memptr) (y memptr)) 124 | (if (and (eq (memptr-mem x) (memptr-mem y)) 125 | (,cl (memptr-ptr x) (memptr-ptr y))) 126 | 1 127 | 0)) 128 | (defmethod ,op ((x number) (y number)) 129 | (if (,cl x y) 1 0)))) 130 | 131 | (define-comparison-ops 132 | == = 133 | < < 134 | > > 135 | <= <= 136 | >= >=) 137 | 138 | (defmethod vacietis.c:== (x y) 139 | (declare (ignore x y)) 140 | 0) 141 | 142 | ;;; boolean algebra 143 | 144 | (declaim (inline vacietis.c:!)) 145 | (defun vacietis.c:! (x) 146 | (if (eql x 0) 1 0)) 147 | 148 | (declaim (inline vacietis.c:!=)) 149 | (defun vacietis.c:!= (x y) 150 | (vacietis.c:! (vacietis.c:== x y))) 151 | 152 | (defmacro vacietis.c:&& (a b) 153 | `(if (or (eql ,a 0) (eql ,b 0)) 0 1)) 154 | 155 | (defmacro vacietis.c:|\|\|| (a b) 156 | `(if (or (not (eql ,a 0)) (not (eql ,b 0))) 1 0)) 157 | 158 | ;;; assignment 159 | 160 | (defmacro vacietis.c:= (lvalue rvalue) 161 | `(setf ,lvalue ,rvalue)) 162 | 163 | (defmacro unroll-assignment-ops (&rest ops) 164 | `(progn 165 | ,@(loop for op in ops collect 166 | `(defmacro ,(find-symbol (symbol-name op) '#:vacietis.c) 167 | (lvalue rvalue) 168 | `(setf ,lvalue 169 | (,',(find-symbol 170 | (reverse (subseq (reverse (symbol-name op)) 1)) 171 | '#:vacietis.c) 172 | ,lvalue 173 | ,rvalue)))))) 174 | 175 | (unroll-assignment-ops += -= *= /= %= <<= >>= &= ^= |\|=|) 176 | 177 | ;;; iteration 178 | 179 | (defmacro vacietis.c:for ((bindings initialization test increment) body) 180 | `(let ,bindings 181 | (tagbody ,@(awhen initialization (list it)) 182 | loop 183 | (when (eql 0 ,test) 184 | (go vacietis.c:break)) 185 | ,body 186 | vacietis.c:continue 187 | ,@(awhen increment (list it)) 188 | (go loop) 189 | vacietis.c:break))) 190 | 191 | (defmacro vacietis.c:do (body test) 192 | `(tagbody loop 193 | ,body 194 | vacietis.c:continue 195 | (if (eql 0 ,test) 196 | (go vacietis.c:break) 197 | (go loop)) 198 | vacietis.c:break)) 199 | 200 | ;;; switch 201 | 202 | (defmacro vacietis.c:switch (exp cases body) 203 | `(tagbody 204 | (case ,exp 205 | ,@(mapcar (lambda (x) `(,x (go ,x))) cases) 206 | (t (go ,(if (find 'vacietis.c:default body) 207 | 'vacietis.c:default 208 | 'vacietis.c:break)))) 209 | ,@body 210 | vacietis.c:break)) 211 | -------------------------------------------------------------------------------- /compiler/libc-support.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis) 2 | (in-readtable vacietis) 3 | 4 | (defun pp-defines (pkg) 5 | (intern "*PREPROCESSOR-DEFINES*" pkg)) 6 | 7 | (defmacro define (name value &rest docstring) 8 | "Like a #define but also visible to Lisp code." 9 | `(progn 10 | (eval-when (:compile-toplevel :load-toplevel :execute) 11 | (defvar ,(pp-defines *package*) (make-hash-table)) 12 | (setf (gethash ',name ,(pp-defines *package*)) ,(prin1-to-string value))) 13 | (defparameter ,name ,value ,@docstring))) 14 | 15 | (defmacro defun/1 (name arglist &body body) 16 | "Lisp-1 defun; makes function pointers work." 17 | `(progn 18 | (defun ,name ,arglist 19 | (declare (optimize (speed 0) (debug 3) 20 | ;; FIXME: Why do minor warnings result in load errors? 21 | #+sbcl (sb-ext:inhibit-warnings 3))) 22 | 23 | ,@body) 24 | (defparameter ,name (vacietis.c:mkptr& (symbol-function ',name))))) 25 | 26 | (defun include-libc-file (include-file) 27 | (let ((libc-package (find-package (format nil "VACIETIS.LIBC.~:@(~A~)" 28 | include-file)))) 29 | (unless libc-package 30 | (error "Can't find libc include file ~a" include-file)) 31 | (use-package libc-package) 32 | (awhen (and (boundp (pp-defines libc-package)) 33 | (symbol-value (pp-defines libc-package))) 34 | (maphash (lambda (name expansion) 35 | (setf (gethash (intern (symbol-name name) *package*) 36 | (compiler-state-pp *compiler-state*)) 37 | expansion)) 38 | it)) 39 | (awhen (probe-file 40 | (merge-pathnames 41 | (format nil "../libc/~a" include-file) 42 | #.(or *compile-file-truename* *load-truename*))) 43 | (%load-c-file it *compiler-state*)))) 44 | 45 | (defmacro libc-dir () 46 | (directory-namestring (or *compile-file-truename* *load-truename*))) 47 | 48 | (defmacro load-libc-file (file libc-dir) 49 | `(eval-when (:compile-toplevel :load-toplevel) 50 | (load-c-file 51 | (merge-pathnames ,file ,libc-dir)))) 52 | -------------------------------------------------------------------------------- /compiler/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl) 2 | 3 | (defpackage #:vacietis 4 | (:use #:cl #:named-readtables #:anaphora) 5 | (:export 6 | ;; readtables 7 | #:vacietis 8 | #:c-readtable 9 | 10 | ;; memory stuff 11 | #:size-of 12 | #:allocate-memory 13 | #:memptr-mem 14 | #:memptr-ptr 15 | #:copy-memptr 16 | 17 | ;; utilities 18 | #:string-to-char* 19 | #:char*-to-string 20 | 21 | ;; runtime 22 | #:*compiler-state* 23 | #:make-compiler-state 24 | #:load-c-file 25 | #:run-c-program 26 | )) 27 | 28 | (in-package #:vacietis) 29 | 30 | (eval-when (:compile-toplevel :load-toplevel :execute) 31 | (defreadtable vacietis ;; defreadtable isn't eval-whened, grrr 32 | (:merge :standard) 33 | (:case :invert))) 34 | 35 | (in-readtable vacietis) 36 | 37 | (defpackage #:vacietis.c 38 | (:use) 39 | (:export 40 | ;; operators 41 | #:= 42 | #:+= 43 | #:-= 44 | #:*= 45 | #:/= 46 | #:%= 47 | #:<<= 48 | #:>>= 49 | #:&= 50 | #:^= 51 | #:|\|=| 52 | #:? 53 | #:|:| 54 | #:|\|\|| 55 | #:&& 56 | #:|\|| 57 | #:^ 58 | #:& 59 | #:== 60 | #:!= 61 | #:< 62 | #:> 63 | #:<= 64 | #:>= 65 | #:<< 66 | #:>> 67 | #:++ 68 | #:-- 69 | #:+ 70 | #:- 71 | #:* 72 | #:/ 73 | #:% 74 | #:! 75 | #:~ 76 | #:-> 77 | #:|.| 78 | #:? 79 | #:|:| 80 | #:|,| 81 | 82 | ;; keywords 83 | #:auto 84 | #:break 85 | #:case 86 | #:char 87 | #:const 88 | #:continue 89 | #:default 90 | #:do 91 | #:double 92 | #:else 93 | #:enum 94 | #:extern 95 | #:float 96 | #:for 97 | #:goto 98 | #:if 99 | #:inline 100 | #:int 101 | #:long 102 | #:register 103 | #:restrict 104 | #:return 105 | #:short 106 | #:signed 107 | #:sizeof 108 | #:static 109 | #:struct 110 | #:switch 111 | #:typedef 112 | #:union 113 | #:unsigned 114 | #:void 115 | #:volatile 116 | #:while 117 | #:_Bool 118 | #:_Complex 119 | #:_Imaginary 120 | 121 | ;; preprocessor 122 | #:define 123 | #:undef 124 | #:include 125 | #:if 126 | #:ifdef 127 | #:ifndef 128 | #:else 129 | #:endif 130 | #:line 131 | #:elif 132 | #:pragma 133 | #:error 134 | 135 | ;; stuff we define 136 | #:deref* 137 | #:mkptr& 138 | #:post-- 139 | #:post++ 140 | #:[] 141 | #:|...| 142 | )) 143 | -------------------------------------------------------------------------------- /compiler/reader.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis) 2 | (in-readtable vacietis) 3 | 4 | (declaim (optimize (debug 3))) 5 | 6 | (in-package #:vacietis.c) 7 | 8 | (cl:defparameter vacietis::*type-qualifiers* 9 | #(static const signed unsigned extern auto register volatile)) 10 | 11 | (cl:defparameter vacietis::*ops* 12 | #(= += -= *= /= %= <<= >>= &= ^= |\|=| ? |:| |\|\|| && |\|| ^ & == != < > <= >= << >> ++ -- + - * / % ! ~ -> |.| |,|)) 13 | 14 | (cl:defparameter vacietis::*possible-prefix-ops* 15 | #(! ~ sizeof - + & * ++ --)) 16 | 17 | (cl:defparameter vacietis::*ambiguous-ops* 18 | #(- + & *)) 19 | 20 | (cl:defparameter vacietis::*assignment-ops* 21 | #(= += -= *= /= %= <<= >>= &= ^= |\|=|)) 22 | 23 | (cl:defparameter vacietis::*binary-ops-table* 24 | #((|\|\||) ; or 25 | (&&) ; and 26 | (|\||) ; logior 27 | (^) ; logxor 28 | (&) ; logand 29 | (== !=) 30 | (< > <= >=) 31 | (<< >>) ; ash 32 | (+ -) 33 | (* / %))) 34 | 35 | (cl:in-package #:vacietis) 36 | 37 | (defvar %in) 38 | (defvar *c-file* nil) 39 | (defvar *line-number* nil) 40 | 41 | ;;; a C macro can expand to several statements; READ should return all of them 42 | 43 | (defvar *macro-stream*) 44 | 45 | ;;; error reporting 46 | 47 | (define-condition c-reader-error (reader-error) ;; SBCL hates simple-conditions? 48 | ((c-file :reader c-file :initform *c-file*) 49 | (line-number :reader line-number :initform *line-number*) 50 | (msg :reader msg :initarg :msg)) 51 | (:report (lambda (condition stream) 52 | (write-string (msg condition) stream)))) 53 | 54 | (defun read-error (msg &rest args) 55 | (error 56 | (make-condition 57 | 'c-reader-error 58 | :stream %in 59 | :msg (format nil 60 | "Error reading C stream~@[ from file ~A~]~@[ at line ~A~]: ~?" 61 | *c-file* *line-number* msg args)))) 62 | 63 | ;;; basic stream stuff 64 | 65 | (defun c-read-char () 66 | (let ((c (read-char %in nil))) 67 | (when (and (eql c #\Newline) *line-number*) 68 | (incf *line-number*)) 69 | c)) 70 | 71 | (defun c-unread-char (c) 72 | (when (and (eql c #\Newline) *line-number*) 73 | (decf *line-number*)) 74 | (unread-char c %in)) 75 | 76 | (defmacro loop-reading (&body body) 77 | `(loop with c do (setf c (c-read-char)) 78 | ,@body)) 79 | 80 | (defun at-end-of-line () 81 | (let ((*readtable* (copy-readtable))) 82 | (set-syntax-from-char #\Newline #\a) 83 | (char-equal (peek-char t %in) #\Newline))) 84 | 85 | (defun next-char (&optional (eof-error? t) 86 | (skip-space-tab? t) (skip-newlines? t)) 87 | "Returns the next character, skipping over comments" 88 | (let ((backslash-seen nil)) 89 | (loop-reading 90 | while (case c 91 | ((nil) (when eof-error? 92 | (read-error "Unexpected end of file"))) 93 | ((#\/) (%maybe-read-comment)) 94 | ((#\Space #\Tab) skip-space-tab?) 95 | ((#\\) (if (at-end-of-line) 96 | (setf backslash-seen t) 97 | nil)) 98 | ((#\Newline) (if backslash-seen 99 | (progn (setf backslash-seen nil) t) 100 | skip-newlines?))) 101 | finally (return c)))) 102 | 103 | (defun make-buffer (&optional (element-type t)) 104 | (make-array 10 :adjustable t :fill-pointer 0 :element-type element-type)) 105 | 106 | (defun slurp-while (predicate) 107 | (let ((string-buffer (make-buffer 'character))) 108 | (loop-reading 109 | while (and c (funcall predicate c)) 110 | do (unless (or (char= c #\\) (char= c #\Newline)) 111 | (vector-push-extend c string-buffer)) 112 | finally (when c (c-unread-char c))) 113 | string-buffer)) 114 | 115 | (defun pp-read-line () 116 | (let ((string-buffer (make-buffer 'character))) 117 | (loop with c do (setf c (next-char nil nil nil)) 118 | while (and c (not (char-equal c #\Newline))) 119 | do (vector-push-extend c string-buffer)) 120 | string-buffer)) 121 | 122 | (defun %maybe-read-comment () 123 | (case (peek-char nil %in) 124 | (#\/ (when *line-number* (incf *line-number*)) 125 | (read-line %in)) 126 | (#\* (slurp-while (let ((previous-char (code-char 0))) 127 | (lambda (c) 128 | (prog1 (not (and (char= previous-char #\*) 129 | (char= c #\/))) 130 | (setf previous-char c))))) 131 | (c-read-char)))) 132 | 133 | (defun read-c-comment (%in slash) 134 | (declare (ignore slash)) 135 | (%maybe-read-comment) 136 | (values)) 137 | 138 | ;;; numbers 139 | 140 | (defun read-octal () 141 | (parse-integer (slurp-while (lambda (c) (char<= #\0 c #\7))) 142 | :radix 8)) 143 | 144 | (defun read-hex () 145 | (parse-integer 146 | (slurp-while (lambda (c) 147 | (or (char<= #\0 c #\9) (char-not-greaterp #\A c #\F)))) 148 | :radix 16)) 149 | 150 | (defun read-float (prefix separator) 151 | (let ((*readtable* (find-readtable :common-lisp))) 152 | (read-from-string 153 | (format nil "~d~a~a" prefix separator 154 | (slurp-while (lambda (c) (find c "0123456789+-eE" :test #'char=))))))) 155 | 156 | (defun read-decimal (c0) ;; c0 must be #\1 to #\9 157 | (labels ((digit-value (c) (- (char-code c) 48))) 158 | (let ((value (digit-value c0))) 159 | (loop-reading 160 | (cond ((null c) 161 | (return value)) 162 | ((char<= #\0 c #\9) 163 | (setf value (+ (* 10 value) (digit-value c)))) 164 | ((or (char-equal c #\E) (char= c #\.)) 165 | (return (read-float value c))) 166 | ((char-equal c #\L) 167 | (return value)) 168 | (t 169 | (c-unread-char c) 170 | (return value))))))) 171 | 172 | (defun read-c-number (c) 173 | (prog1 (if (char= c #\0) 174 | (let ((next (peek-char nil %in nil))) 175 | (if next 176 | (if (digit-char-p next 8) 177 | (read-octal) 178 | (case next 179 | ((#\X #\x) (c-read-char) (read-hex)) 180 | (#\. (c-read-char) (read-float 0 #\.)) 181 | (otherwise 0))) 182 | 0)) 183 | (read-decimal c)) 184 | (loop repeat 2 do (when (find (peek-char nil %in nil nil) "ulf" :test #'eql) 185 | (c-read-char))))) 186 | 187 | ;;; string and chars (caller has to remember to discard leading #\L!!!) 188 | 189 | (defun read-char-literal (c) 190 | (if (char= c #\\) 191 | (let ((c (c-read-char))) 192 | (code-char (case c 193 | (#\a 7) 194 | (#\f 12) 195 | (#\n 10) 196 | (#\r 13) 197 | (#\t 9) 198 | (#\v 11) 199 | (#\x (read-hex)) 200 | (otherwise (if (char<= #\0 c #\7) 201 | (progn (c-unread-char c) (read-octal)) 202 | (char-code c)))))) 203 | c)) 204 | 205 | (defun read-character-constant (%in single-quote) 206 | (declare (ignore single-quote)) 207 | (prog1 (char-code (read-char-literal (c-read-char))) 208 | (unless (char= (c-read-char) #\') 209 | (read-error "Junk in character constant")))) 210 | 211 | (defun read-c-string (%in double-quotes) 212 | (declare (ignore double-quotes)) 213 | (let ((string (make-buffer 'character))) 214 | (loop-reading 215 | (if (char= c #\") ;; c requires concatenation of adjacent string literals 216 | (progn (setf c (next-char nil)) 217 | (unless (eql c #\") 218 | (when c (c-unread-char c)) 219 | (return `(string-to-char* ,string)))) 220 | (vector-push-extend (read-char-literal c) string))))) 221 | 222 | ;;; preprocessor 223 | 224 | (defvar preprocessor-if-stack ()) 225 | (defvar *preprocessing* nil) 226 | 227 | (defmacro lookup-define () 228 | `(gethash (read-c-identifier (next-char)) 229 | (compiler-state-pp *compiler-state*))) 230 | 231 | (defun preprocessor-skip-branch () 232 | (let ((if-nest-depth 1)) 233 | (loop for line = (pp-read-line) do 234 | (cond ((ppcre:scan "# *if" line) 235 | (incf if-nest-depth)) 236 | ((ppcre:scan "# *ifdef" line) 237 | (incf if-nest-depth)) 238 | ((ppcre:scan "# *ifndef" line) 239 | (incf if-nest-depth)) 240 | ((and (ppcre:scan "# *else" line) 241 | (= 1 if-nest-depth)) 242 | (return)) 243 | ((and (ppcre:scan "# *endif" line) 244 | (= 0 (decf if-nest-depth))) 245 | (pop preprocessor-if-stack) 246 | (return)) 247 | ((and (ppcre:scan "# *elif" line) 248 | (= 1 if-nest-depth)) 249 | (case (car preprocessor-if-stack) 250 | ( if (when (preprocessor-test 251 | (subseq line (multiple-value-bind (_ end) 252 | (ppcre:scan "# *elif" line) 253 | (declare (ignore _)) end))) 254 | (setf (car preprocessor-if-stack) 'elif) 255 | (return))) 256 | (elif nil) 257 | (else (read-error "Misplaced #elif")))))))) 258 | 259 | (defun preprocessor-test (line) 260 | (let ((*preprocessing* t)) 261 | (let ((exp (with-input-from-string (%in line) 262 | (read-infix-exp (read-c-exp (next-char)))))) 263 | (not (eql 0 (eval `(symbol-macrolet 264 | ,(let ((x)) 265 | (maphash (lambda (k v) 266 | ;; Do not use special 267 | ;; variables -- e.g., as 268 | ;; set by (define EXIT_SUCCESS 0) 269 | ;; -- in this symbol-macrolet. 270 | (unless k 271 | (push (list k v) x))) 272 | (compiler-state-pp *compiler-state*)) 273 | x) 274 | ,exp))))))) 275 | 276 | (defun fill-in-template (args template subs) 277 | (ppcre:regex-replace-all 278 | (format nil "([^a-zA-Z])?(~{~a~^|~})([^a-zA-Z0-9])?" args) 279 | ;; This works, but is more permissive than GCC. See reader-test 280 | ;; preprocessor-no-concatenation. 281 | (ppcre:regex-replace-all "##" template "") 282 | (lambda (match r1 arg r2) 283 | (declare (ignore match)) 284 | (format nil "~A~A~A" 285 | (or r1 "") 286 | (elt subs (position arg args :test #'string=)) 287 | (or r2 ""))) 288 | :simple-calls t)) 289 | 290 | (defun c-read-delimited-strings (&optional skip-spaces?) 291 | (next-char) ;; skip opening paren 292 | (let ((paren-depth 0) 293 | (acc (make-buffer))) 294 | (with-output-to-string (sink) 295 | (loop for c = (c-read-char) 296 | until (and (= paren-depth 0) (eql #\) c)) do 297 | (case c 298 | (#\Space (unless skip-spaces? (princ c sink))) 299 | (#\( (incf paren-depth) (princ c sink)) 300 | (#\) (decf paren-depth) (princ c sink)) 301 | (#\, (vector-push-extend (get-output-stream-string sink) acc)) 302 | (otherwise (princ c sink))) 303 | finally (let ((last (get-output-stream-string sink))) 304 | (unless (string= last "") 305 | (vector-push-extend last acc))))) 306 | (map 'list #'identity acc))) 307 | 308 | (defun find-include (include-file) 309 | (dolist (path (compiler-state-include-paths *compiler-state*)) 310 | (let ((include (merge-pathnames 311 | (merge-pathnames include-file path) 312 | (or *load-truename* *compile-file-truename* 313 | *default-pathname-defaults*)))) 314 | (when (cl-fad:file-exists-p include) (return include))))) 315 | 316 | (defun read-c-macro (%in sharp) 317 | (declare (ignore sharp)) 318 | ;; preprocessor directives need to be read in a separate namespace 319 | (let ((pp-directive (read-c-identifier (next-char)))) 320 | (case pp-directive 321 | (vacietis.c:define 322 | (setf (lookup-define) 323 | (if (eql #\( (peek-char nil %in)) 324 | (let ((args (c-read-delimited-strings t)) 325 | (template (string-trim '(#\Space #\Tab) (pp-read-line)))) 326 | (lambda (substitutions) 327 | (if args 328 | (fill-in-template args template substitutions) 329 | template))) 330 | (pp-read-line)))) 331 | (vacietis.c:undef 332 | (remhash (read-c-identifier (next-char)) 333 | (compiler-state-pp *compiler-state*)) 334 | (pp-read-line)) 335 | (vacietis.c:include 336 | (let* ((delimiter 337 | (case (next-char) 338 | (#\" #\") (#\< #\>) 339 | (otherwise (read-error "Error reading include path: ~A" 340 | (pp-read-line))))) 341 | (include-file 342 | (slurp-while (lambda (c) (char/= c delimiter))))) 343 | (next-char) 344 | (if (char= delimiter #\") 345 | (%load-c-file (merge-pathnames 346 | include-file 347 | (directory-namestring 348 | (or *load-truename* *compile-file-truename* 349 | *default-pathname-defaults*))) 350 | *compiler-state*) 351 | (let ((non-system-include-file (find-include include-file))) 352 | (if non-system-include-file 353 | (%load-c-file non-system-include-file *compiler-state*) 354 | (include-libc-file include-file)))))) 355 | (vacietis.c:if 356 | (push 'if preprocessor-if-stack) 357 | (unless (preprocessor-test (pp-read-line)) 358 | (preprocessor-skip-branch))) 359 | (vacietis.c:ifdef 360 | (push 'if preprocessor-if-stack) 361 | (unless (lookup-define) 362 | (preprocessor-skip-branch))) 363 | (vacietis.c:ifndef 364 | (push 'if preprocessor-if-stack) 365 | (when (lookup-define) 366 | (preprocessor-skip-branch))) 367 | (vacietis.c:else ;; skip this branch 368 | (if preprocessor-if-stack 369 | (progn (setf (car preprocessor-if-stack) 'else) 370 | (preprocessor-skip-branch)) 371 | (read-error "Misplaced #else"))) 372 | (vacietis.c:endif 373 | (if preprocessor-if-stack 374 | (pop preprocessor-if-stack) 375 | (read-error "Misplaced #endif"))) 376 | (vacietis.c:elif 377 | (if preprocessor-if-stack 378 | (preprocessor-skip-branch) 379 | (read-error "Misplaced #elif"))) 380 | (otherwise ;; line, pragma, error ignored for now 381 | (pp-read-line)))) 382 | (values)) 383 | 384 | ;;; types and size-of 385 | 386 | (defun type-qualifier? (x) 387 | (find x *type-qualifiers*)) 388 | 389 | (defun basic-type? (x) 390 | (find x *basic-c-types*)) 391 | 392 | (defun c-type? (identifier) 393 | ;; and also do checks for struct, union, enum and typedef types 394 | (or (type-qualifier? identifier) 395 | (basic-type? identifier) 396 | (find identifier #(vacietis.c:struct vacietis.c:enum)) 397 | (gethash identifier (compiler-state-typedefs *compiler-state*)))) 398 | 399 | (defvar *local-var-types* nil) 400 | 401 | (defun size-of (x) 402 | (or (type-size x) 403 | (type-size (gethash x (or *local-var-types* 404 | (compiler-state-var-types *compiler-state*)))))) 405 | 406 | ;;; infix 407 | 408 | (defun parse-infix (exp &optional (start 0) (end (when (vectorp exp) (length exp)))) 409 | (if (vectorp exp) 410 | (block nil 411 | (when (= 0 (length exp)) 412 | (return)) 413 | (when (= 1 (- end start)) 414 | (return (parse-infix (aref exp start)))) 415 | (labels ((cast? (x) 416 | (and (vectorp x) (some #'c-type? x))) 417 | (match-binary-ops (table &key (lassoc t)) 418 | (position-if (lambda (x) (find x table)) 419 | exp :start (1+ start) :end (1- end) 420 | :from-end lassoc)) 421 | (parse-binary (i &optional op) 422 | (list (or op (aref exp i)) 423 | (parse-infix exp start i) 424 | (parse-infix exp (1+ i) end)))) 425 | ;; in order of weakest to strongest precedence 426 | ;; comma 427 | (awhen (match-binary-ops '(vacietis.c:|,|)) 428 | (return (parse-binary it 'progn))) 429 | ;; assignment 430 | (awhen (match-binary-ops *assignment-ops* :lassoc nil) 431 | (return (parse-binary it))) 432 | ;; elvis 433 | (awhen (position 'vacietis.c:? exp :start start :end end) 434 | (let ((?pos it)) 435 | (return 436 | `(if (not (eql 0 ,(parse-infix exp start ?pos))) 437 | ,@(aif (position 'vacietis.c:|:| exp :start ?pos :end end) 438 | (list (parse-infix exp (1+ ?pos) it) 439 | (parse-infix exp (1+ it) end)) 440 | (read-error "Error parsing ?: trinary operator in: ~A" 441 | (subseq exp start end))))))) 442 | ;; various binary operators 443 | (loop for table across *binary-ops-table* do 444 | (awhen (match-binary-ops table) 445 | (if (and (find (elt exp it) *ambiguous-ops*) 446 | (let ((prev (elt exp (1- it)))) 447 | (or (find prev *ops*) (cast? prev)))) 448 | (awhen (position-if (lambda (x) 449 | (not (or (find x *ops*) 450 | (cast? x)))) 451 | exp 452 | :start start 453 | :end it 454 | :from-end t) 455 | (return-from parse-infix (parse-binary (1+ it)))) 456 | (return-from parse-infix (parse-binary it))))) 457 | ;; unary operators 458 | (flet ((parse-rest (i) 459 | (parse-infix exp (1+ i) end))) 460 | (loop for i from start below end for x = (aref exp i) do 461 | (cond ((cast? x) ;; cast 462 | (return-from parse-infix (parse-rest i))) 463 | ((find x #(vacietis.c:++ vacietis.c:--)) ;; inc/dec 464 | (return-from parse-infix 465 | (let* ((postfix? (< start i)) 466 | (place (if postfix? 467 | (parse-infix exp start i) 468 | (parse-infix exp (1+ i) end))) 469 | (set-exp `(vacietis.c:= 470 | ,place 471 | (,(if (eq x 'vacietis.c:++) 472 | 'vacietis.c:+ 473 | 'vacietis.c:-) 474 | ,place 1)))) 475 | (if postfix? 476 | `(prog1 ,place ,set-exp) 477 | set-exp)))) 478 | ((find x *possible-prefix-ops*) ;; prefix op 479 | (return-from parse-infix 480 | (if (eq x 'vacietis.c:sizeof) 481 | (let ((type-exp (aref exp (1+ i)))) 482 | (when (vectorp type-exp) ;; fixme 483 | (setf type-exp (aref type-exp 0))) 484 | (or (size-of type-exp) 485 | (read-error "Don't know sizeof ~A" type-exp))) 486 | (list (case x 487 | (vacietis.c:- '-) 488 | (vacietis.c:* 'vacietis.c:deref*) 489 | (vacietis.c:& 'vacietis.c:mkptr&) 490 | (otherwise x)) 491 | (parse-rest i)))))))) 492 | ;; funcall, aref, and struct access 493 | (loop for i from (1- end) downto (1+ start) for x = (aref exp i) do 494 | (cond 495 | ((find x #(vacietis.c:|.| vacietis.c:->)) 496 | (let ((exp (parse-binary i))) 497 | (return-from parse-infix 498 | `(vacietis.c:|.| 499 | ,(if (eq x 'vacietis.c:->) 500 | `(vacietis.c:deref* ,(elt exp 1)) 501 | (elt exp 1)) 502 | ,(gethash (elt exp 2) 503 | (compiler-state-accessors *compiler-state*)))))) 504 | ((listp x) ;; aref 505 | (return-from parse-infix 506 | (if (eq (car x) 'vacietis.c:[]) 507 | `(vacietis.c:[] ,(parse-infix exp start i) 508 | ,(parse-infix (second x))) 509 | (read-error "Unexpected list when parsing ~A" exp)))) 510 | ((vectorp x) ;; funcall 511 | (return-from parse-infix 512 | (let ((fun-exp (parse-infix exp start i))) 513 | (append 514 | (if (symbolp fun-exp) 515 | (list fun-exp) 516 | (list 'funcall fun-exp)) 517 | (loop with xstart = 0 518 | for next = (position 'vacietis.c:|,| x :start xstart) 519 | when (< 0 (length x)) 520 | collect (parse-infix x xstart (or next (length x))) 521 | while next do (setf xstart (1+ next))))))))) 522 | (read-error "Error parsing expression: ~A" (subseq exp start end)))) 523 | exp)) 524 | 525 | ;;; statements 526 | 527 | (defun read-c-block (c) 528 | (if (eql c #\{) 529 | (loop for c = (next-char) 530 | until (eql c #\}) append (reverse 531 | (multiple-value-list 532 | (read-c-statement c)))) 533 | (read-error "Expected opening brace '{' but found '~A'" c))) 534 | 535 | (defun next-exp () 536 | (read-c-exp (next-char))) 537 | 538 | (defvar *variable-declarations*) 539 | (defvar *cases*) 540 | 541 | (defun read-exps-until (predicate) 542 | (let ((exps (make-buffer))) 543 | (loop for c = (next-char) 544 | until (funcall predicate c) 545 | do (vector-push-extend (read-c-exp c) exps)) 546 | exps)) 547 | 548 | (defun c-read-delimited-list (open-delimiter separator) 549 | (let ((close-delimiter (ecase open-delimiter (#\( #\)) (#\{ #\}) (#\; #\;))) 550 | (list (make-buffer)) 551 | done?) 552 | (loop until done? do 553 | (vector-push-extend 554 | (read-exps-until (lambda (c) 555 | (cond ((eql c close-delimiter) (setf done? t)) 556 | ((eql c separator) t)))) 557 | list)) 558 | list)) 559 | 560 | (defun read-control-flow-statement (statement) 561 | (flet ((read-block-or-statement () 562 | (let ((next-char (next-char))) 563 | (if (eql next-char #\{) 564 | (cons 'tagbody (read-c-block next-char)) 565 | (read-c-statement next-char))))) 566 | (if (eq statement 'vacietis.c:if) 567 | (let* ((test (parse-infix (next-exp))) 568 | (then (read-block-or-statement)) 569 | (next-char (next-char nil)) 570 | (next-token (case next-char 571 | (#\e (read-c-exp #\e)) 572 | ((nil)) 573 | (t (c-unread-char next-char) nil))) 574 | (if-exp `(if (eql 0 ,test) 575 | ,(when (eq next-token 'vacietis.c:else) 576 | (read-block-or-statement)) 577 | ,then))) 578 | (if (or (not next-token) (eq next-token 'vacietis.c:else)) 579 | if-exp 580 | `(progn ,if-exp ,(%read-c-statement next-token)))) 581 | (case statement 582 | ((vacietis.c:break vacietis.c:continue) 583 | `(go ,statement)) 584 | (vacietis.c:goto 585 | `(go ,(read-c-statement (next-char)))) 586 | (vacietis.c:return 587 | `(return ,(or (read-c-statement (next-char)) 0))) 588 | (vacietis.c:case 589 | (prog1 (car (push 590 | (eval (parse-infix (next-exp))) ;; must be constant int 591 | *cases*)) 592 | (unless (eql #\: (next-char)) 593 | (read-error "Error parsing case statement")))) 594 | (vacietis.c:switch 595 | (let* ((exp (parse-infix (next-exp))) 596 | (*cases* ()) 597 | (body (read-c-block (next-char)))) 598 | `(vacietis.c:switch ,exp ,*cases* ,body))) 599 | (vacietis.c:while 600 | `(vacietis.c:for (nil nil ,(parse-infix (next-exp)) nil) 601 | ,(read-block-or-statement))) 602 | (vacietis.c:do 603 | (let ((body (read-block-or-statement))) 604 | (if (eql (next-exp) 'vacietis.c:while) 605 | (prog1 `(vacietis.c:do ,body ,(parse-infix (next-exp))) 606 | (read-c-statement (next-char))) ;; semicolon 607 | (read-error "No 'while' following a 'do'")))) 608 | (vacietis.c:for 609 | `(vacietis.c:for 610 | ,(let* ((*local-var-types* (make-hash-table)) 611 | (*variable-declarations* ()) ;; c99, I think? 612 | (initializations (progn 613 | (next-char) 614 | (read-c-statement 615 | (next-char))))) 616 | (list* *variable-declarations* 617 | initializations 618 | (map 'list 619 | #'parse-infix 620 | (c-read-delimited-list #\( #\;)))) 621 | ,(read-block-or-statement))))))) 622 | 623 | (defun read-function (name result-type) 624 | (declare (ignore result-type)) 625 | (let (arglist) 626 | (block done-arglist 627 | (loop for param across (c-read-delimited-list (next-char) #\,) do 628 | (block done-arg 629 | (labels ((strip-type (x) 630 | (cond ((symbolp x) 631 | (push x arglist) 632 | (return-from done-arg)) 633 | ((vectorp x) 634 | (loop for x1 across x do 635 | (when (not (or (c-type? x1) 636 | (eq 'vacietis.c:* x1))) 637 | (strip-type x1)))) 638 | (t 639 | (read-error 640 | "Junk in argument list: ~A" x))))) 641 | (loop for x across param do 642 | (cond 643 | ((eq x 'vacietis.c:|.|) 644 | (progn (push '&rest arglist) 645 | (push 'vacietis.c:|...| arglist) 646 | (return-from done-arglist))) 647 | ((not (or (c-type? x) (eq 'vacietis.c:* x))) 648 | (strip-type x)))))))) 649 | (if (eql (peek-char nil %in) #\;) 650 | (prog1 t (c-read-char)) ;; forward declaration 651 | `(defun/1 ,name ,(reverse arglist) 652 | ,(let* ((*variable-declarations* ()) 653 | (*local-var-types* (make-hash-table)) 654 | (body (read-c-block (next-char)))) 655 | `(prog* ,*variable-declarations* 656 | ,@body)))))) 657 | 658 | (defun process-variable-declaration (spec base-type) 659 | (let (name (type base-type) initial-value init-size) 660 | (labels ((init-object (value) 661 | (if (vector-literal-p value) 662 | (let ((els (cons 'vector (vector-literal-elements value)))) 663 | (if (struct-type-p type) 664 | els 665 | (progn (setf init-size (length els)) 666 | `(vacietis::make-memptr :mem ,els)))) 667 | (progn 668 | (when (and (listp value) (eq 'string-to-char* (car value))) 669 | (setf init-size (length (second value)))) 670 | value))) 671 | (parse-declaration (x) 672 | (if (symbolp x) 673 | (setf name x) 674 | (destructuring-bind (qualifier name1 &optional val/size) 675 | x 676 | (setf name name1) 677 | (case qualifier 678 | (vacietis.c:= 679 | (setf initial-value (init-object val/size)) 680 | (parse-declaration name1)) 681 | (vacietis.c:[] 682 | (setf type 683 | (make-array-type 684 | :element-type type 685 | :dimensions (awhen (or val/size init-size) 686 | (list it)))) 687 | (parse-declaration name)) 688 | (vacietis.c:deref* 689 | (setf type (make-pointer-to :type type)) 690 | (parse-declaration name)) 691 | (t (read-error "Unknown thing in declaration ~A" x))))))) 692 | (parse-declaration spec) 693 | (values name type initial-value)))) 694 | 695 | (defun read-variable-declarations (spec-so-far base-type) 696 | (let ((decls (c-read-delimited-list #\; #\,)) 697 | (decl-code ())) 698 | (setf (aref decls 0) (concatenate 'vector spec-so-far (aref decls 0))) 699 | (loop for x across decls do 700 | (multiple-value-bind (name type initial-value) 701 | (process-variable-declaration (parse-infix x) base-type) 702 | (setf (gethash name (or *local-var-types* 703 | (compiler-state-var-types *compiler-state*))) 704 | type) 705 | (if (boundp '*variable-declarations*) 706 | (progn (push (list name (preallocated-value-exp-for type)) 707 | *variable-declarations*) 708 | (when initial-value 709 | (push `(vacietis.c:= ,name ,initial-value) 710 | decl-code))) 711 | (push `(defparameter ,name 712 | ,(or initial-value 713 | (preallocated-value-exp-for type))) 714 | decl-code)))) 715 | (if decl-code 716 | (cons 'progn (reverse decl-code)) 717 | t))) 718 | 719 | (defun read-var-or-function-declaration (base-type) 720 | "Reads a variable(s) or function declaration" 721 | (let ((type base-type) 722 | name 723 | (spec-so-far (make-buffer))) 724 | (loop for c = (next-char) do 725 | (cond ((eql c #\*) 726 | (setf type (make-pointer-to :type type)) 727 | (vector-push-extend 'vacietis.c:* spec-so-far)) 728 | ((or (eql c #\_) (alpha-char-p c)) 729 | (setf name (read-c-identifier c)) 730 | (vector-push-extend name spec-so-far) 731 | (return)) 732 | (t 733 | (c-unread-char c) 734 | (return)))) 735 | (let ((next (next-char))) 736 | (c-unread-char next) 737 | (if (and name (eql #\( next)) 738 | (read-function name type) 739 | (read-variable-declarations spec-so-far base-type))))) 740 | 741 | (defun read-typedef (base-type) 742 | (multiple-value-bind (name type) 743 | (process-variable-declaration (read-infix-exp (next-exp)) base-type) 744 | (setf (gethash name (compiler-state-typedefs *compiler-state*)) type) 745 | t)) 746 | 747 | (defun read-enum-decl () 748 | (when (eql #\{ (peek-char t %in)) 749 | (next-char) 750 | (let ((enums (c-read-delimited-list #\{ #\,))) 751 | ;; fixme: assigned values to enum names 752 | (loop for name across enums for i from 0 do 753 | (setf (gethash (elt name 0) (compiler-state-enums *compiler-state*)) 754 | i)))) 755 | (if (eql #\; (peek-char t %in)) 756 | (progn (next-char) t) 757 | (read-variable-declarations #() 'vacietis.c:int))) 758 | 759 | (defun read-base-type (token) 760 | (loop while (type-qualifier? token) 761 | do (setf token (next-exp))) 762 | (awhen (gethash token (compiler-state-typedefs *compiler-state*)) 763 | (setf token it)) 764 | (cond ((eq token 'vacietis.c:enum) 765 | (make-enum-type :name (next-exp))) 766 | ((eq token 'vacietis.c:struct) 767 | (if (eql #\{ (peek-char t %in)) 768 | (progn 769 | (c-read-char) 770 | (read-struct-decl-body (make-struct-type))) 771 | (let ((name (next-exp))) 772 | (or (gethash name (compiler-state-structs *compiler-state*)) 773 | (make-struct-type :name name))))) 774 | ((or (basic-type? token) (c-type-p token)) 775 | token) 776 | (t 777 | (read-error "Unexpected parser error: unknown type ~A" token)))) 778 | 779 | (defun read-struct-decl-body (struct-type) 780 | (let ((i 0)) 781 | (loop for c = (next-char) until (eql #\} c) do 782 | (multiple-value-bind (slot-name slot-type) 783 | (let ((base-type (read-base-type (read-c-exp c)))) 784 | (process-variable-declaration (read-infix-exp (next-exp)) 785 | base-type)) 786 | (setf (gethash slot-name 787 | (compiler-state-accessors *compiler-state*)) 788 | i 789 | (struct-type-slots struct-type) 790 | (append (struct-type-slots struct-type) (list slot-type))) 791 | (incf i (size-of slot-type)))))) 792 | 793 | (defun read-struct (struct-type) 794 | (acase (next-char) 795 | (#\{ (read-struct-decl-body struct-type) 796 | (awhen (struct-type-name struct-type) 797 | (setf (gethash it (compiler-state-structs *compiler-state*)) 798 | struct-type)) 799 | (let ((c (next-char))) 800 | (if (eql #\; c) 801 | t 802 | (progn (c-unread-char c) 803 | (read-variable-declarations #() struct-type))))) 804 | (#\; t) ;; forward declaration 805 | (t (read-variable-declarations (vector (read-c-exp it)) 806 | struct-type)))) 807 | 808 | (defun read-declaration (token) 809 | (cond ((eq 'vacietis.c:typedef token) 810 | (read-typedef (read-base-type (next-exp)))) 811 | ((c-type? token) 812 | (let ((base-type (read-base-type token))) 813 | (cond ((struct-type-p base-type) 814 | (read-struct base-type)) 815 | ((enum-type-p base-type) 816 | (read-enum-decl)) 817 | (t 818 | (read-var-or-function-declaration base-type))))))) 819 | 820 | (defun read-labeled-statement (token) 821 | (when (eql #\: (peek-char t %in)) 822 | (next-char) 823 | (values (read-c-statement (next-char)) token))) 824 | 825 | (defun read-infix-exp (next-token) 826 | (let ((exp (make-buffer))) 827 | (vector-push-extend next-token exp) 828 | (loop for c = (next-char nil) 829 | until (or (eql c #\;) (null c)) 830 | do (vector-push-extend (read-c-exp c) exp)) 831 | (parse-infix exp))) 832 | 833 | (defun %read-c-statement (token) 834 | (multiple-value-bind (statement label) (read-labeled-statement token) 835 | (acond (label (values statement label)) 836 | ((read-declaration token) (if (eq t it) (values) it)) 837 | (t (or (read-control-flow-statement token) 838 | (read-infix-exp token)))))) 839 | 840 | (defun read-c-statement (c) 841 | (case c 842 | (#\# (read-c-macro %in c)) 843 | (#\; (values)) 844 | (t (let ((expression (read-c-exp c))) 845 | (if expression 846 | (%read-c-statement expression) 847 | ;; Allow for an empty macro on a line by itself. 848 | (values)))))) 849 | 850 | (defun read-c-identifier (c) 851 | ;; assume inverted readtable (need to fix for case-preserving lisps) 852 | (let* ((raw-name (concatenate 853 | 'string (string c) 854 | (slurp-while (lambda (c) 855 | (or (eql c #\_) (alphanumericp c)))))) 856 | (raw-name-alphas (remove-if-not #'alpha-char-p raw-name)) 857 | (identifier-name 858 | (format nil 859 | (cond ((every #'upper-case-p raw-name-alphas) "~(~A~)") 860 | ((every #'lower-case-p raw-name-alphas) "~:@(~A~)") 861 | (t "~A")) 862 | raw-name))) 863 | (or (find-symbol identifier-name '#:vacietis.c) (intern identifier-name)))) 864 | 865 | (defun match-longest-op (one) 866 | (flet ((seq-match (&rest chars) 867 | (find (make-array (length chars) 868 | :element-type 'character 869 | :initial-contents chars) 870 | *ops* :test #'string= :key #'symbol-name))) 871 | (let ((one-match (seq-match one)) 872 | (two (c-read-char))) 873 | (acond ((null two) 874 | one-match) 875 | ((seq-match one two) 876 | (let ((three-match (seq-match one two (peek-char nil %in)))) 877 | (if three-match 878 | (progn (c-read-char) three-match) 879 | it))) 880 | (t (c-unread-char two) one-match))))) 881 | 882 | (defstruct vector-literal 883 | elements) 884 | 885 | (defun read-vector-literal () 886 | (make-vector-literal 887 | :elements (map 'list #'parse-infix (c-read-delimited-list #\{ #\,)))) 888 | 889 | (defun read-c-exp (c) 890 | (or (match-longest-op c) 891 | (cond ((digit-char-p c) (read-c-number c)) 892 | ((or (eql c #\_) (alpha-char-p c)) 893 | (let ((symbol (read-c-identifier c))) 894 | (acond 895 | ((gethash symbol (compiler-state-pp *compiler-state*)) 896 | (setf *macro-stream* 897 | (make-string-input-stream 898 | (etypecase it 899 | (string 900 | it) 901 | (function 902 | (funcall it (c-read-delimited-strings t))))) 903 | %in 904 | (make-concatenated-stream *macro-stream* %in)) 905 | ;; Peek to next Newline. 906 | (if (at-end-of-line) 907 | ;; Macro on a line by itself. 908 | (values) 909 | (read-c-exp (next-char)))) 910 | ((gethash symbol (compiler-state-enums *compiler-state*)) 911 | it) 912 | (t 913 | (if *preprocessing* 914 | (if (string-equal symbol "defined") 915 | (if (lookup-define) 1 0) 916 | (if (gethash symbol 917 | (compiler-state-pp *compiler-state*)) 918 | symbol 919 | 0)) 920 | symbol))))) 921 | (t 922 | (case c 923 | (#\" (read-c-string %in c)) 924 | (#\' (read-character-constant %in c)) 925 | (#\( (read-exps-until (lambda (c) (eql #\) c)))) 926 | (#\{ (read-vector-literal)) ;; decl only 927 | (#\[ (list 'vacietis.c:[] 928 | (read-exps-until (lambda (c) (eql #\] c)))))))))) 929 | 930 | ;;; readtable 931 | 932 | (defun read-c-toplevel (%in c) 933 | (let* ((*macro-stream* nil) 934 | (exp1 (read-c-statement c))) 935 | (if (and *macro-stream* (peek-char t *macro-stream* nil)) 936 | (list* 'progn 937 | exp1 938 | (loop while (peek-char t *macro-stream* nil) 939 | collect (read-c-statement (next-char)))) 940 | (or exp1 (values))))) 941 | 942 | (defun read-c-newline (%in c) 943 | (when *line-number* (incf *line-number*)) 944 | (values)) 945 | 946 | (macrolet 947 | ((def-c-readtable () 948 | `(defreadtable c-readtable 949 | (:case :invert) 950 | 951 | ;; unary and prefix operators 952 | ,@(loop for i in '(#\+ #\- #\~ #\! #\( #\& #\*) 953 | collect `(:macro-char ,i 'read-c-toplevel nil)) 954 | 955 | (:macro-char #\Newline 'read-c-newline nil) 956 | 957 | (:macro-char #\# 'read-c-macro nil) 958 | 959 | (:macro-char #\/ 'read-c-comment nil) 960 | 961 | (:macro-char #\" 'read-c-string nil) 962 | (:macro-char #\' 'read-character-constant nil) 963 | 964 | ;; numbers (should this be here?) 965 | ,@(loop for i from 0 upto 9 966 | collect `(:macro-char ,(digit-char i) 'read-c-toplevel nil)) 967 | 968 | ;; identifiers 969 | (:macro-char #\_ 'read-c-toplevel nil) 970 | ,@(loop for i from (char-code #\a) upto (char-code #\z) 971 | collect `(:macro-char ,(code-char i) 'read-c-toplevel nil)) 972 | ,@(loop for i from (char-code #\A) upto (char-code #\Z) 973 | collect `(:macro-char ,(code-char i) 'read-c-toplevel nil)) 974 | ))) 975 | (def-c-readtable)) 976 | 977 | (defvar c-readtable (find-readtable 'c-readtable)) 978 | 979 | ;;; reader 980 | 981 | (defun cstr (str) 982 | (with-input-from-string (s str) 983 | (let ((*compiler-state* (make-compiler-state)) 984 | (*readtable* c-readtable)) 985 | (cons 'progn (loop for it = (read s nil 'eof) 986 | while (not (eq it 'eof)) collect it))))) 987 | 988 | (defun %load-c-file (*c-file* *compiler-state*) 989 | (let ((*readtable* c-readtable) 990 | (*line-number* 1)) 991 | (prog1 (load *c-file*) 992 | (when *load-verbose* 993 | #+sbcl (let ((sb-fasl::*load-depth* (1+ sb-fasl::*load-depth*))) 994 | (sb-fasl::load-fresh-line)) 995 | (format t "done ~s~%" *c-file*))))) 996 | 997 | (defun load-c-file (file &key include-paths) 998 | (%load-c-file file (make-compiler-state :include-paths include-paths))) 999 | -------------------------------------------------------------------------------- /compiler/state.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis) 2 | (in-readtable vacietis) 3 | 4 | (defvar *compiler-state*) 5 | 6 | (defstruct compiler-state 7 | (pp (make-hash-table)) 8 | (typedefs (make-hash-table)) 9 | (structs (make-hash-table)) 10 | (accessors (make-hash-table)) 11 | (enums (make-hash-table)) 12 | (var-types (make-hash-table)) 13 | (include-paths '())) 14 | -------------------------------------------------------------------------------- /compiler/type.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis) 2 | (in-readtable vacietis) 3 | 4 | (in-package #:vacietis.c) 5 | 6 | (cl:defparameter vacietis::*basic-c-types* 7 | #(int void short long float double char _Bool)) 8 | 9 | (cl:in-package #:vacietis) 10 | 11 | (defstruct c-type) 12 | 13 | (defstruct (pointer-to (:include c-type)) 14 | type) 15 | 16 | (defstruct (enum-type (:include c-type)) 17 | name) 18 | 19 | (defstruct (struct-type (:include c-type)) 20 | name 21 | slots) 22 | 23 | (defstruct (array-type (:include c-type)) 24 | element-type 25 | dimensions) 26 | 27 | (defun type-size (type) 28 | (cond 29 | ((find type *basic-c-types*) 1) 30 | ((enum-type-p type) 1) 31 | ((pointer-to-p type) 1) 32 | ((and (listp type) (eq 'string-to-char* (car type))) (length (second type))) 33 | ((struct-type-p type) (reduce #'+ (map 'list #'type-size 34 | (struct-type-slots type)))) 35 | ((array-type-p type) (if (array-type-dimensions type) 36 | (apply #'* 37 | (type-size 38 | (array-type-element-type type)) 39 | (array-type-dimensions type)) 40 | (error 41 | "Array has no dimensions specified"))))) 42 | 43 | (defun preallocated-value-exp-for (type) 44 | (cond 45 | ((struct-type-p type) `(make-array ,(size-of type) :initial-element 0)) 46 | ((array-type-p type) `(allocate-memory ,(size-of type))) 47 | (t 0))) 48 | -------------------------------------------------------------------------------- /contributors: -------------------------------------------------------------------------------- 1 | Vladimir Sedach 2 | Brit Butler 3 | 4 | -------------------------------------------------------------------------------- /libc/ctype.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.libc.ctype.h) 2 | (in-readtable vacietis:vacietis) 3 | 4 | (defmacro chartest (cname exp) 5 | `(defun/1 ,cname (code) 6 | (if (<= 0 code) 7 | (let ((c (code-char code))) 8 | (declare (ignorable c)) 9 | (if ,exp 1 0)) 10 | 0))) 11 | 12 | (defun space? (c) 13 | (member c '(#\Space #\Newline #\Return #\Tab))) ;; vertical tab 14 | 15 | (chartest isspace (space? c)) 16 | (chartest isalnum (alphanumericp c)) 17 | (chartest isalpha (alpha-char-p c)) 18 | (chartest iscntrl (or (<= 0 code #x1F) (eql code 127))) ;; assume ASCII ctrl codes 19 | (chartest isdigit (digit-char-p c)) 20 | (chartest isgraph (and (graphic-char-p c) (not (space? c)))) 21 | (chartest islower (lower-case-p c)) 22 | (chartest isprint (graphic-char-p c)) 23 | (chartest ispunct (and (graphic-char-p c) 24 | (not (space? c)) 25 | (not (alphanumericp c)))) 26 | (chartest isupper (upper-case-p c)) 27 | (chartest isxdigit (digit-char-p c 16)) 28 | 29 | (defun/1 toupper (c) 30 | (char-upcase (code-char c))) 31 | 32 | (defun/1 tolower (c) 33 | (char-downcase (code-char c))) 34 | -------------------------------------------------------------------------------- /libc/errno.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.libc.errno.h) 2 | (in-readtable vacietis:vacietis) 3 | 4 | (defvar errno-strings (make-array 35)) 5 | 6 | (defmacro deferr (name number msg) 7 | `(progn 8 | (setf (aref errno-strings ,number) (string-to-char* ,msg)) 9 | (define ,name ,number ,msg))) 10 | 11 | (deferr EPERM 1 "Operation not permitted (POSIX.1)") 12 | (deferr ENOENT 2 "No such file or directory (POSIX.1)") 13 | (deferr ESRCH 3 "No such process (POSIX.1)") 14 | (deferr EINTR 4 "Interrupted function call (POSIX.1)") 15 | (deferr EIO 5 "Input/output error") 16 | (deferr ENXIO 6 "No such device or address (POSIX.1)") 17 | (deferr E2BIG 7 "Argument list too long (POSIX.1)") 18 | (deferr ENOEXEC 8 "Exec format error (POSIX.1)") 19 | (deferr EBADF 9 "Bad file descriptor (POSIX.1)") 20 | (deferr ECHILD 10 "No child processes (POSIX.1)") 21 | (deferr EAGAIN 11 "Resource temporarily unavailable (POSIX.1)") 22 | (deferr ENOMEM 12 "Not enough space (POSIX.1)") 23 | (deferr EACCES 13 "Permission denied (POSIX.1)") 24 | (deferr EFAULT 14 "Bad address (POSIX.1)") 25 | (deferr ENOTBLK 15 "Block device required") 26 | (deferr EBUSY 16 "Device or resource busy (POSIX.1)") 27 | (deferr EEXIST 17 "File exists (POSIX.1)") 28 | (deferr EXDEV 18 "Improper link (POSIX.1)") 29 | (deferr ENODEV 19 "No such device (POSIX.1)") 30 | (deferr ENOTDIR 20 "Not a directory (POSIX.1)") 31 | (deferr EISDIR 21 "Is a directory (POSIX.1)") 32 | (deferr EINVAL 22 "Invalid argument (POSIX.1)") 33 | (deferr ENFILE 23 "Too many open files in system (POSIX.1)") 34 | (deferr EMFILE 24 "Too many open files (POSIX.1)") 35 | (deferr ENOTTY 25 "Inappropriate I/O control operation (POSIX.1)") 36 | (deferr ETXTBSY 26 "Text file busy (POSIX.1)") 37 | (deferr EFBIG 27 "File too large (POSIX.1)") 38 | (deferr ENOSPC 28 "No space left on device (POSIX.1)") 39 | (deferr ESPIPE 29 "Invalid seek (POSIX.1)") 40 | (deferr EROFS 30 "Read-only file system (POSIX.1)") 41 | (deferr EMLINK 31 "Too many links (POSIX.1)") 42 | (deferr EPIPE 32 "Broken pipe (POSIX.1)") 43 | (deferr EDOM 33 "Mathematics argument out of domain of function (POSIX.1, C99)") 44 | (deferr ERANGE 34 "Result too large (POSIX.1, C99)") 45 | 46 | (defvar errno 0) 47 | -------------------------------------------------------------------------------- /libc/fcntl.h: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vsedach/Vacietis/808914a75ea52539a124cc9df729a5296fb37ad4/libc/fcntl.h -------------------------------------------------------------------------------- /libc/include/Sys/stat.h: -------------------------------------------------------------------------------- 1 | /* 2 | STAT.H for ZETA-C: declarations for stat(), and fstat(); 3 | To be done soon?? 4 | 5 | Note this file does not have a package specification, as it will be 6 | read into (potentially) many different packages. */ 7 | 8 | 9 | 10 | /* Getting the status of a file. */ 11 | 12 | struct stat 13 | { 14 | dev_t st_dev; 15 | ino_t st_ino; 16 | unsigned short st_mode; /* Make this an int? */ 17 | short st_nlink; 18 | short st_uid; 19 | short st_gid; 20 | dev_t st_rdev; 21 | off_t st_size; 22 | time_t st_atime; 23 | time_t st_mtime; 24 | time_t st_ctime; 25 | }; 26 | 27 | void stat(); 28 | void fstat(); 29 | -------------------------------------------------------------------------------- /libc/include/Sys/time.h: -------------------------------------------------------------------------------- 1 | /* 2 | STAT.H for ZETA-C: declarations for stat(), and fstat(); 3 | To be done soon?? 4 | 5 | Note this file does not have a package specification, as it will be 6 | read into (potentially) many different packages. */ 7 | 8 | 9 | /* 10 | * Structure returned by gettimeofday(2) system call, 11 | * and used in other calls. 12 | */ 13 | struct timeval { 14 | long tv_sec; /* seconds */ 15 | long tv_usec; /* and microseconds */ 16 | }; 17 | 18 | struct timezone { 19 | int tz_minuteswest; /* minutes west of Greenwich */ 20 | int tz_dsttime; /* type of dst correction */ 21 | }; 22 | #define DST_NONE 0 /* not on dst */ 23 | #define DST_USA 1 /* USA style dst */ 24 | #define DST_AUST 2 /* Australian style dst */ 25 | #define DST_WET 3 /* Western European dst */ 26 | #define DST_MET 4 /* Middle European dst */ 27 | #define DST_EET 5 /* Eastern European dst */ 28 | 29 | /* 30 | * Operations on timevals. 31 | * 32 | * NB: timercmp does not work for >= or <=. 33 | */ 34 | #define timerisset(tvp) ((tvp)->tv_sec || (tvp)->tv_usec) 35 | #define timercmp(tvp, uvp, cmp) \ 36 | ((tvp)->tv_sec cmp (uvp)->tv_sec || \ 37 | (tvp)->tv_sec == (uvp)->tv_sec && (tvp)->tv_usec cmp (uvp)->tv_usec) 38 | #define timerclear(tvp) (tvp)->tv_sec = (tvp)->tv_usec = 0 39 | 40 | /* 41 | * Names of the interval timers, and structure 42 | * defining a timer setting. 43 | */ 44 | #define ITIMER_REAL 0 45 | #define ITIMER_VIRTUAL 1 46 | #define ITIMER_PROF 2 47 | 48 | struct itimerval { 49 | struct timeval it_interval; /* timer interval */ 50 | struct timeval it_value; /* current value */ 51 | }; 52 | 53 | /* 54 | * Structure returned by gmtime and localtime calls (see ctime(3)). 55 | */ 56 | struct tm { 57 | int tm_sec; 58 | int tm_min; 59 | int tm_hour; 60 | int tm_mday; 61 | int tm_mon; 62 | int tm_year; 63 | int tm_wday; 64 | int tm_yday; 65 | int tm_isdst; 66 | }; 67 | 68 | #ifndef KERNEL 69 | extern struct tm *gmtime(), *localtime(); 70 | extern char *asctime(), *ctime(); 71 | #endif 72 | -------------------------------------------------------------------------------- /libc/include/Sys/times.h: -------------------------------------------------------------------------------- 1 | /* 2 | TIMES.H for ZETA-C: declarations for times() call. 3 | Note this file does not have a package specification, as it will be 4 | read into (potentially) many different packages. */ 5 | 6 | /* #include first */ 7 | 8 | /* Only tms_utime is returned, and it has nothing to do with the current 9 | * process, but is global time; the others are zero */ 10 | 11 | struct tms { 12 | time_t tms_utime, /* user time */ 13 | tms_stime, /* system time (always zero) */ 14 | tms_cutime, /* user time, children (always zero) */ 15 | tms_cstime; /* system time, children (always zero) */ 16 | }; 17 | 18 | /* End of TIMES.H */ 19 | -------------------------------------------------------------------------------- /libc/include/Sys/types.h: -------------------------------------------------------------------------------- 1 | /* 2 | TYPES.H for ZETA-C: declarations of system types. 3 | Note this file does not have a package specification, as it will be 4 | read into (potentially) many different packages. */ 5 | 6 | typedef int time_t; /* A time */ 7 | typedef int dev_t; 8 | typedef int ino_t; 9 | typedef int off_t; 10 | 11 | /* typedef int */ 12 | 13 | 14 | /* End of TYPES.H */ 15 | -------------------------------------------------------------------------------- /libc/include/float.h: -------------------------------------------------------------------------------- 1 | /* Borrowed from TCC (LGPL) */ 2 | 3 | #ifndef _FLOAT_H_ 4 | #define _FLOAT_H_ 5 | 6 | #define FLT_RADIX 2 7 | 8 | /* IEEE float */ 9 | #define FLT_MANT_DIG 24 10 | #define FLT_DIG 6 11 | #define FLT_ROUNDS 1 12 | #define FLT_EPSILON 1.19209290e-07F 13 | #define FLT_MIN_EXP (-125) 14 | #define FLT_MIN 1.17549435e-38F 15 | #define FLT_MIN_10_EXP (-37) 16 | #define FLT_MAX_EXP 128 17 | #define FLT_MAX 3.40282347e+38F 18 | #define FLT_MAX_10_EXP 38 19 | 20 | /* IEEE double */ 21 | #define DBL_MANT_DIG 53 22 | #define DBL_DIG 15 23 | #define DBL_EPSILON 2.2204460492503131e-16 24 | #define DBL_MIN_EXP (-1021) 25 | #define DBL_MIN 2.2250738585072014e-308 26 | #define DBL_MIN_10_EXP (-307) 27 | #define DBL_MAX_EXP 1024 28 | #define DBL_MAX 1.7976931348623157e+308 29 | #define DBL_MAX_10_EXP 308 30 | 31 | #endif /* _FLOAT_H_ */ 32 | -------------------------------------------------------------------------------- /libc/include/setjmp.h: -------------------------------------------------------------------------------- 1 | /* 2 | SETJMP.H for ZETA-C: declarations for SETJMP and LONGJMP. 3 | Note this file does not have a package specification, as it will be 4 | read into (potentially) many different packages. */ 5 | 6 | typedef lispval jmp_buf; 7 | 8 | /* End of SETJMP.H */ 9 | -------------------------------------------------------------------------------- /libc/include/signal.h: -------------------------------------------------------------------------------- 1 | /* 2 | SIGNAL.H for ZETA-C: declarations for signal(), raise(), and assorted 3 | signals. Modeled after UNIX and ANSI. 4 | 5 | Note this file does not have a package specification, as it will be 6 | read into (potentially) many different packages. */ 7 | 8 | /* Have to do sig_atomic_t */ 9 | 10 | 11 | #define SIG_DFL ((int (*)()) 0) 12 | #define SIG_ERR ((int (*)()) -1) 13 | #define SIG_IGN ((int (*)()) 1) 14 | 15 | /* These are UNIX v7 standard. Of course, few are meaningful here. */ 16 | #define SIGHUP 1 17 | #define SIGINT 2 18 | #define SIGQUIT 3 19 | #define SIGILL 4 20 | #define SIGTRAP 5 21 | #define SIGIOT 6 22 | #define SIGEMT 7 23 | #define SIGFPE 8 24 | #define SIGKILL 9 25 | #define SIGBUS 10 26 | #define SIGSEGV 11 27 | #define SIGSYS 12 28 | #define SIGPIPE 13 29 | #define SIGALRM 14 30 | #define SIGTERM 15 31 | 32 | /* This is specified by the ANSI spec. */ 33 | #define SIGABRT SIGQUIT 34 | 35 | void (*signal())(); 36 | int raise(); 37 | 38 | 39 | /* End of SIGNAL.H */ 40 | -------------------------------------------------------------------------------- /libc/include/stddef.h: -------------------------------------------------------------------------------- 1 | typedef T ptrdiff_t; 2 | typedef int size_t; 3 | typedef wchar_t; FIXME 4 | -------------------------------------------------------------------------------- /libc/include/unistd.h: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vsedach/Vacietis/808914a75ea52539a124cc9df729a5296fb37ad4/libc/include/unistd.h -------------------------------------------------------------------------------- /libc/math.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.libc.math.h) 2 | (in-readtable vacietis) 3 | 4 | (define HUGE_VAL most-positive-double-float) 5 | 6 | (defun/1 atan2 (x y) 7 | (atan x y)) 8 | 9 | (defun/1 pow (x y) 10 | (expt x y)) 11 | 12 | (defun/1 log10 (x) 13 | (log x 10)) 14 | 15 | (defun/1 fabs (x) 16 | (abs x)) 17 | 18 | (defun/1 ceil (x) 19 | (ceiling x)) 20 | 21 | (defun/1 fmod (x y) 22 | (mod x y)) 23 | 24 | (defun/1 modf (x ptr) 25 | (multiple-value-bind (whole part) 26 | (fround x) 27 | (setf (deref* ptr) whole) 28 | part)) 29 | 30 | (defun/1 ldexp (x n) 31 | (* x (expt 2 n))) 32 | 33 | (defun/1 frexp (x nptr) 34 | (let ((n (ceiling (log (abs x) 2)))) 35 | (setf (deref* nptr) n) 36 | (/ x (expt 2 n)))) 37 | -------------------------------------------------------------------------------- /libc/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis) 2 | (named-readtables:in-readtable vacietis:vacietis) 3 | 4 | (defpackage #:vacietis.libc.errno.h 5 | (:use #:cl #:named-readtables #:vacietis) 6 | (:import-from #:vacietis #:define) 7 | (:export 8 | #:errno 9 | #:EPERM 10 | #:ENOENT 11 | #:ESRCH 12 | #:EINTR 13 | #:EIO 14 | #:ENXIO 15 | #:E2BIG 16 | #:ENOEXEC 17 | #:EBADF 18 | #:ECHILD 19 | #:EAGAIN 20 | #:ENOMEM 21 | #:EACCES 22 | #:EFAULT 23 | #:ENOTBLK 24 | #:EBUSY 25 | #:EEXIST 26 | #:EXDEV 27 | #:ENODEV 28 | #:ENOTDIR 29 | #:EISDIR 30 | #:EINVAL 31 | #:ENFILE 32 | #:EMFILE 33 | #:ENOTTY 34 | #:ETXTBSY 35 | #:EFBIG 36 | #:ENOSPC 37 | #:ESPIPE 38 | #:EROFS 39 | #:EMLINK 40 | #:EPIPE 41 | #:EDOM 42 | #:ERANGE 43 | )) 44 | 45 | (defpackage #:vacietis.libc.stddef.h 46 | (:use #:cl #:named-readtables #:vacietis) 47 | (:import-from #:vacietis #:define) 48 | (:export 49 | #:NULL 50 | #:offsetof)) 51 | 52 | (defmacro deflibcpkg (name &rest other-opts) 53 | `(defpackage ,name 54 | (:use #:cl #:named-readtables #:vacietis 55 | #:vacietis.libc.errno.h #:vacietis.libc.stddef.h) 56 | (:import-from #:vacietis #:define #:defun/1 #:libc-dir #:load-libc-file) 57 | (:import-from #:vacietis.c #:deref* #:mkptr&) 58 | ,@other-opts)) 59 | 60 | (deflibcpkg #:vacietis.libc.math.h 61 | (:export 62 | #:HUGE_VAL 63 | #:sin 64 | #:cos 65 | #:tan 66 | #:asin 67 | #:acos 68 | #:atan 69 | #:atan2 70 | #:sinh 71 | #:cosh 72 | #:tanh 73 | #:sqrt 74 | #:exp 75 | #:pow 76 | #:log 77 | #:log10 78 | #:fabs 79 | #:floor 80 | #:ceil 81 | #:fmod 82 | #:ldexp 83 | #:frexp 84 | #:modf)) 85 | 86 | (deflibcpkg #:vacietis.libc.ctype.h 87 | (:export 88 | #:isspace 89 | #:isalnum 90 | #:isalpha 91 | #:iscntrl 92 | #:isdigit 93 | #:isgraph 94 | #:islower 95 | #:isprint 96 | #:ispunct 97 | #:isupper 98 | #:isxdigit 99 | #:toupper 100 | #:tolower)) 101 | 102 | (deflibcpkg #:vacietis.libc.string.h 103 | (:export 104 | #:strerror 105 | #:strrchr 106 | #:strspn 107 | #:strpbrk 108 | #:strstr 109 | #:strtok 110 | #:strtok_r 111 | #:strcpy 112 | #:strncpy 113 | #:strcat 114 | #:strncat 115 | #:strchr 116 | #:strcmp 117 | #:strncmp 118 | #:strlen 119 | #:strcspn 120 | #:memcpy 121 | #:memmove 122 | #:memset 123 | #:memchr 124 | #:memcmp)) 125 | 126 | (deflibcpkg #:vacietis.libc.stdbool.h) 127 | 128 | (deflibcpkg #:vacietis.libc.fcntl.h) 129 | 130 | (deflibcpkg #:vacietis.libc.sys/types.h) 131 | 132 | (deflibcpkg #:vacietis.libc.sys/stat.h) 133 | 134 | (deflibcpkg #:vacietis.libc.unistd.h) 135 | 136 | (deflibcpkg #:vacietis.libc.limits.h) 137 | 138 | (deflibcpkg #:vacietis.libc.float.h) 139 | 140 | (deflibcpkg #:vacietis.libc.stdarg.h 141 | (:export 142 | #:va_list 143 | #:va_start 144 | #:__va_arg 145 | #:va_end 146 | #:va_copy)) 147 | 148 | (deflibcpkg #:vacietis.libc.stdlib.h 149 | (:shadow #:abort) 150 | (:export 151 | #:malloc 152 | #:calloc 153 | #:realloc 154 | #:free 155 | #:RAND_MAX 156 | #:rand 157 | #:srand 158 | #:atoi 159 | #:atol 160 | #:atoll 161 | #:atof 162 | #:strtod 163 | #:strtof 164 | #:strtol 165 | #:strtoll 166 | #:strtoul 167 | #:strtoull 168 | #:EXIT_SUCCESS 169 | #:EXIT_FAILURE 170 | #:abort 171 | #:exit 172 | #:atexit 173 | #:getenv 174 | #:setenv 175 | #:system 176 | #:abs 177 | #:labs 178 | #:llabs 179 | #:div 180 | #:ldiv 181 | #:bsearch 182 | #:qsort 183 | )) 184 | 185 | (deflibcpkg #:vacietis.libc.stdio.h 186 | (:shadow #:remove) 187 | (:import-from #:vacietis.libc.string.h #:strerror) 188 | (:shadowing-import-from #:vacietis.libc.stdlib.h #:abort) 189 | (:export 190 | #:EOF 191 | #:stdin 192 | #:stdout 193 | #:stderr 194 | #:clearerr 195 | #:feof 196 | #:ferror 197 | #:perror 198 | #:fopen 199 | #:fflush 200 | #:fclose 201 | #:freopen 202 | #:remove 203 | #:rename 204 | #:tmpfile 205 | #:tmpnam 206 | #:setbuf 207 | #:setvbuf 208 | #:fgetc 209 | #:getc 210 | #:getchar 211 | #:fputc 212 | #:putc 213 | #:putchar 214 | #:fgets 215 | #:gets 216 | #:fputs 217 | #:puts 218 | #:ungetc 219 | #:fread 220 | #:fwrite 221 | #:SEEK_SET 222 | #:SEEK_CUR 223 | #:SEEK_END 224 | #:fseek 225 | #:ftell 226 | #:rewind 227 | #:fgetpos 228 | #:fsetpos 229 | #:fprintf 230 | #:printf 231 | #:sprintf 232 | #:scanf 233 | #:fscanf 234 | #:sscanf 235 | )) 236 | 237 | 238 | -------------------------------------------------------------------------------- /libc/scanf.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | // adapted from ZetaC 8 | 9 | #define __initrest(pointers) va_list pointers; va_start(pointers, -1) 10 | 11 | 12 | int scanf (char *fmt, ...) { 13 | __initrest(places); 14 | return _scnf ((int (*)())NULL, ungetc, stdin, fmt, places); 15 | } 16 | 17 | int _sgetc(char **strp) { 18 | char c; 19 | c = *(*strp)++; 20 | return c ? c : EOF; 21 | } 22 | 23 | int sscanf (char *str, char *fmt, ...) { 24 | __initrest(places); 25 | return _scnf (_sgetc, (int (*)())NULL, (FILE *)&str, fmt, places); 26 | } 27 | 28 | int fscanf (FILE *stream, char *fmt, ...) { 29 | __initrest(places); 30 | return _scnf (fgetc, ungetc, stream, fmt, places); 31 | } 32 | 33 | 34 | int 35 | _scnf (int (*getfn)(), int (*ungetfn)(), FILE *stream, char *fmt, va_list pointers) 36 | { 37 | int nchars = -1, ires = 0, noassign, fieldwidth, ival; 38 | int idecp, ifldig, complement, i; 39 | char fmtc, argsize, sign, expsign, *cp, flbuf[128], scanset[256]; 40 | 41 | #define _scnfin() (++nchars, getfn ? (*getfn) (stream) : getchar()) 42 | #define DEFAULT_FIELD_WIDTH 8388607 43 | #define TRUE 1 44 | #define FALSE 0 45 | 46 | int ic = _scnfin(); 47 | 48 | while ((fmtc = *fmt++)) { 49 | if (ic == EOF) return ires ? ires : EOF; 50 | 51 | if (isspace(fmtc)) { 52 | while (isspace(ic)) ic = _scnfin(); 53 | } 54 | 55 | else if (fmtc != '%') { 56 | if (ic == fmtc) ic = _scnfin(); 57 | else { 58 | if (ungetfn) (*ungetfn) (ic, stream); 59 | return ires; 60 | } 61 | } 62 | 63 | else { /* we have a % */ 64 | noassign = FALSE; 65 | 66 | fieldwidth = DEFAULT_FIELD_WIDTH; 67 | argsize = NULL; 68 | if ((fmtc = *fmt++) == '*') { 69 | noassign = TRUE; 70 | fmtc = *fmt++; 71 | } 72 | 73 | if (isdigit(fmtc)) { 74 | fieldwidth = fmtc - '0'; 75 | while (isdigit(fmtc = *fmt++)) 76 | fieldwidth = 10*fieldwidth + fmtc - '0'; 77 | if (fieldwidth == 0) ++fieldwidth; 78 | } 79 | 80 | if (fmtc == 'h' || fmtc == 'l' || fmtc == 'L') { 81 | argsize = fmtc; 82 | fmtc = *fmt++; 83 | } 84 | 85 | switch (fmtc) { 86 | case 'i': 87 | while (isspace(ic)) ic = _scnfin(); 88 | if (ic == EOF) break; 89 | if (ic == '0') { 90 | ic = _scnfin(); 91 | if (ic == 'x' || ic == 'X') { 92 | ic = _scnfin(); 93 | goto hex; 94 | } 95 | else goto octal; 96 | } 97 | fmtc = 'd'; /* and fall through to decimal: */ 98 | case 'd': 99 | case 'u': 100 | decimal: 101 | sign = '+'; 102 | ival = 0; 103 | while (isspace(ic)) ic = _scnfin(); 104 | if (ic == EOF) { noassign = TRUE; break; } 105 | if (fmtc == 'd' && (ic == '+' || ic == '-')) { 106 | sign = ic; 107 | ic = _scnfin(); 108 | --fieldwidth; 109 | } 110 | while (fieldwidth-- > 0 && isdigit(ic)) { 111 | ival = 10*ival + ic - '0'; 112 | ic = _scnfin(); 113 | } 114 | if (sign == '-') ival = -ival; 115 | break; 116 | case 'o': 117 | octal: 118 | ival = 0; 119 | while (isspace(ic)) ic = _scnfin(); 120 | if (ic == EOF) { noassign = TRUE; break; } 121 | while (fieldwidth-- > 0 && isdigit(ic) /* && ic < '8' */) { 122 | ival = 8*ival + ic - '0'; 123 | ic = _scnfin(); 124 | } 125 | break; 126 | case 'x': case 'X': 127 | hex: 128 | ival = 0; 129 | while (isspace(ic)) ic = _scnfin(); 130 | if (ic == EOF) { noassign = TRUE; break; } 131 | if (ic == '0') { 132 | ic = _scnfin(); 133 | if (ic == 'x' || ic == 'X') ic = _scnfin(); 134 | } 135 | while (fieldwidth-- > 0 && isxdigit(ic)) { 136 | ival = 16*ival + ((ic <= '9') ? ic - '0' 137 | : (ic & 0x5f) - 'A' + 10); 138 | ic = _scnfin(); 139 | } 140 | break; 141 | case 'e': 142 | case 'f': case 'F': 143 | case 'g': case 'G': 144 | ifldig = idecp = 0; 145 | expsign = NULL; 146 | while (isspace(ic)) ic = _scnfin(); 147 | if (ic == EOF) { noassign = TRUE; break; } 148 | if (ic == '+' || ic == '-') { 149 | flbuf[ifldig++] = ic; 150 | ic = _scnfin(); 151 | --fieldwidth; 152 | } 153 | while (fieldwidth-- > 0) { 154 | if (isdigit(ic)) ; 155 | else if (!idecp && !expsign && ic == '.') ++idecp; 156 | else if (!expsign && (ic == 'e' || ic == 'E')) { 157 | flbuf[ifldig++] = ic; 158 | ic = _scnfin(); 159 | --fieldwidth; 160 | if (ic == '+' || ic == '-') { 161 | flbuf[ifldig++] = ic; 162 | ic = _scnfin(); 163 | --fieldwidth; 164 | } 165 | else expsign = '+'; 166 | } 167 | else break; 168 | flbuf[ifldig++] = ic; 169 | ic = _scnfin(); 170 | --fieldwidth; 171 | } 172 | if (!idecp && !expsign) flbuf[ifldig++] = '.'; /* reader needs . */ 173 | if (!noassign) { 174 | flbuf[ifldig] = '\0'; 175 | *va_arg(pointers, double) = atof(flbuf); 176 | ires++; 177 | noassign = TRUE; 178 | } 179 | break; 180 | case 'c': 181 | if (fieldwidth == DEFAULT_FIELD_WIDTH) fieldwidth = 1; 182 | cp = (char *)va_arg(pointers, (char *)); 183 | while (fieldwidth-- > 0 && ic != EOF) { 184 | if (!noassign) *cp++ = ic; 185 | ic = _scnfin(); 186 | } 187 | if (!noassign && fieldwidth == -1) ++ires; /* success */ 188 | noassign = TRUE; 189 | break; 190 | case 's': 191 | cp = (char *)va_arg(pointers, (char *)); 192 | while (isspace(ic)) ic = _scnfin(); 193 | if (ic == EOF) { noassign = TRUE; break; } 194 | while (fieldwidth-- > 0 && ic != EOF && !isspace(ic)) { 195 | if (!noassign) *cp++ = ic; 196 | ic = _scnfin(); 197 | } 198 | if (!noassign) { *cp = NULL; ++ires; } 199 | noassign = TRUE; 200 | break; 201 | case '[': 202 | complement = FALSE; 203 | if ((fmtc = *fmt++) == '^') { 204 | if (fmtc) fmtc = *fmt++; 205 | complement = TRUE; 206 | } 207 | for (i = 0; i < 256; ++i) scanset[i] = complement; 208 | while (fmtc && fmtc != ']') { 209 | scanset[fmtc] = !complement; 210 | fmtc = *fmt++; 211 | } 212 | cp = (char *)va_arg(pointers, (char *)); 213 | ires++; 214 | while (fieldwidth-- > 0 && ic != EOF && scanset[ic]) { 215 | if (!noassign) *cp++ = ic; 216 | ic = _scnfin(); 217 | } 218 | if (!noassign) *cp = NULL; 219 | noassign = TRUE; 220 | break; 221 | case 'n': /* ANSI extension: number of chars read */ 222 | ival = nchars; 223 | break; 224 | case 'p': /* read a pointer back in, not supported */ 225 | errno = EINVAL; 226 | return -1; 227 | } 228 | 229 | if (!noassign) { 230 | *va_arg(pointers, int) = ival; 231 | ires++; 232 | } 233 | } 234 | } 235 | return ires; 236 | } 237 | -------------------------------------------------------------------------------- /libc/stdarg.h: -------------------------------------------------------------------------------- 1 | typedef void *va_list; 2 | 3 | #define va_arg(list, type) __va_arg(list) 4 | -------------------------------------------------------------------------------- /libc/stdarg.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.libc.stdarg.h) 2 | (in-readtable vacietis) 3 | 4 | (defmacro va_start (va-list-var last-fixed-parameter-name) 5 | (declare (ignore last-fixed-parameter-name)) 6 | `(setf ,va-list-var (mkptr& vacietis.c:|...|))) 7 | 8 | (defun/1 va_end (va-list) ;; does nothing 9 | (declare (ignore va-list))) 10 | 11 | (defun __va_arg (va-list) 12 | (or (pop (deref* va-list)) 13 | (error "va_arg just corrupted the stack"))) 14 | 15 | (defun/1 va_copy (dest src) 16 | (setf (deref* dest) (deref* src))) 17 | -------------------------------------------------------------------------------- /libc/stdbool.h: -------------------------------------------------------------------------------- 1 | #define bool _Bool 2 | -------------------------------------------------------------------------------- /libc/stddef.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.libc.stddef.h) 2 | (in-readtable vacietis) 3 | 4 | (defconstant NULL 0) 5 | 6 | (defmacro offsetof (struct_type field) 7 | ;; find offset of field in struct_type 8 | ;; todo 9 | (error "OFFSETOF NOT IMPLEMENTED YET") 10 | ) 11 | -------------------------------------------------------------------------------- /libc/stdio.h: -------------------------------------------------------------------------------- 1 | typedef void *FILE; 2 | -------------------------------------------------------------------------------- /libc/stdio.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.libc.stdio.h) 2 | (in-readtable vacietis) 3 | 4 | (define EOF -1) 5 | 6 | ;;; FILEs/streams 7 | 8 | (defclass FILE () 9 | ((stream :initarg :stream :accessor fd-stream) 10 | (feof :initform 0 :accessor feof) 11 | (ferror :initform 0 :accessor ferror) 12 | (tmp-file :initform nil :accessor tmp-file))) 13 | 14 | (defvar stdin (make-instance 'FILE :stream *standard-input*)) 15 | (defvar stdout (make-instance 'FILE :stream *standard-output*)) 16 | (defvar stderr (make-instance 'FILE :stream *error-output*)) 17 | 18 | (defun/1 clearerr (fd) 19 | (setf (feof fd) 0 20 | (ferror fd) 0)) 21 | 22 | ;;; file operations 23 | 24 | ;; have to do something about EEXIST 25 | (defun open-stream (filename mode) 26 | (let* ((m (char*-to-string mode)) 27 | (opts (cond ((string= m "r") '(:direction :input)) 28 | ((string= m "w") '(:direction :output :if-exists :overwrite 29 | :if-does-not-exist :create)) 30 | ((string= m "a") '(:direction :output :if-exists :append 31 | :if-does-not-exist :create)) 32 | ((string= m "r+") '(:direction :io)) 33 | ((string= m "w+") '(:direction :io :if-exists :overwrite 34 | :if-does-not-exist :create)) 35 | ((string= m "a+") '(:direction :io :if-exists :append 36 | :if-does-not-exist :create))))) 37 | (apply #'open (char*-to-string filename) opts))) 38 | 39 | (defun/1 fopen (filename mode) 40 | (handler-case (make-instance 'FILE :stream (open-stream filename mode)) 41 | (file-error () 42 | (setf errno ENOENT) 43 | NULL) 44 | (error () 45 | NULL))) 46 | 47 | (defun/1 fflush (fd) 48 | (unless (eql fd NULL) 49 | (finish-output (fd-stream fd))) 50 | 0) 51 | 52 | (defun/1 fclose (fd) 53 | (close (fd-stream fd)) 54 | (when (tmp-file fd) 55 | (delete-file (tmp-file fd)) 56 | (setf (tmp-file fd) nil)) 57 | 0) 58 | 59 | (defun/1 freopen (filename mode fd) 60 | (handler-case (progn (fclose fd) 61 | (clearerr fd) 62 | (setf (fd-stream fd) (open-stream filename mode))) 63 | (error () 64 | (setf errno EIO) 65 | NULL))) 66 | 67 | (defun/1 remove (filename) 68 | (handler-case (progn (delete-file (char*-to-string filename)) 69 | 0) 70 | (file-error () 1))) 71 | 72 | (defun/1 rename (oldname newname) 73 | (handler-case (progn (rename-file oldname newname) 74 | 0) 75 | (file-error () 1))) 76 | 77 | (defun/1 tmpfile () 78 | (let ((path (merge-pathnames (symbol-name (gensym "vac_tmp_c_file")) 79 | "/tmp/"))) 80 | (if (open path :direction :probe) 81 | (tmpfile) ;; try again 82 | (let ((fd (fopen (string-to-char* (namestring path)) 83 | (string-to-char* "w+")))) ;; should be wb+ 84 | (unless (eql fd NULL) 85 | (setf (tmp-file fd) path)) 86 | ;; also need to make sure tmp files are deleted on exit 87 | ;; good idea to attach finalizers to the tmp files' streams too 88 | fd)))) 89 | 90 | (defun/1 tmpnam (str) 91 | (let ((newname (string-to-char* (symbol-name (gensym))))) 92 | (if (eql str NULL) 93 | newname 94 | (progn (replace str newname :end1 (length newname)) 95 | str)))) 96 | 97 | ;;; character I/O 98 | 99 | (defun/1 fgetc (fd) 100 | (handler-case (char-code (read-char (fd-stream fd))) 101 | (end-of-file () 102 | (setf (feof fd) 1) 103 | EOF) 104 | (error () 105 | (setf (ferror fd) EIO) 106 | EOF))) 107 | 108 | (defun/1 getc (fd) 109 | (fgetc fd)) 110 | 111 | (defun/1 getchar () 112 | (getc stdin)) 113 | 114 | (defun/1 fputc (c fd) 115 | (handler-case (progn (write-char (code-char c) (fd-stream fd)) 116 | c) 117 | (error () 118 | (setf (ferror fd) EIO) 119 | EOF))) 120 | 121 | (defun/1 putc (c fd) 122 | (fputc c fd)) 123 | 124 | (defun/1 putchar (c) 125 | (fputc c stdout)) 126 | 127 | (defun fgets-is-dumb (str n fd replace-newline?) 128 | (handler-case 129 | (let ((stream (fd-stream fd))) 130 | (loop for i from 0 below (1- n) 131 | for x = (read-char stream) 132 | do (progn (setf (aref str i) (char-code x)) 133 | (when (eql x #\Newline) 134 | (unless replace-newline? (incf i)) 135 | (loop-finish))) 136 | finally (setf (aref str i) 0)) 137 | str) 138 | (end-of-file () 139 | (setf (feof fd) 1) 140 | NULL) 141 | (error () 142 | (setf (ferror fd) EIO) 143 | NULL))) 144 | 145 | (defun/1 fgets (str n fd) 146 | (fgets-is-dumb str n fd nil)) 147 | 148 | (defun/1 gets (str) 149 | (fgets-is-dumb str most-positive-fixnum stdin t)) 150 | 151 | (defun/1 fputs (str fd) 152 | (handler-case (progn (write-string (char*-to-string str) (fd-stream fd)) 153 | 0) 154 | (error () 155 | (setf (ferror fd) EIO) 156 | EOF))) 157 | 158 | (defun/1 puts (str) 159 | (when (eql EOF (fputs str stdout)) 160 | (return-from puts EOF)) 161 | (when (eql EOF (fputc #\Newline stdout)) 162 | (return-from puts EOF)) 163 | 0) 164 | 165 | (defun/1 ungetc (c fd) 166 | (handler-case (progn (unread-char (code-char c) (fd-stream fd)) 167 | c) 168 | (error () 169 | (setf (ferror fd) EIO) 170 | EOF))) 171 | 172 | ;;; fread/fwrite, only work for byte arrays for now 173 | 174 | (defun/1 fread (mem element_size count fd) 175 | (handler-case 176 | (let* ((start (memptr-ptr mem)) 177 | (end (+ start (* element_size count))) 178 | (position (read-sequence (memptr-mem mem) (fd-stream fd) 179 | :start start :end end))) 180 | (when (< position end) 181 | (setf (feof fd) 1)) 182 | (- position start)) 183 | (error () 184 | (setf (ferror fd) EIO) 185 | 0))) 186 | 187 | (defun/1 fwrite (mem element_size count fd) 188 | (handler-case 189 | (let ((start (memptr-ptr mem))) 190 | (write-sequence (memptr-mem mem) (fd-stream fd) 191 | :start start :end (+ start (* element_size count))) 192 | count) 193 | (error () 194 | (setf (ferror fd) EIO) 195 | 0))) 196 | 197 | ;;; file positioning 198 | 199 | (define SEEK_SET 0) 200 | (define SEEK_CUR 1) 201 | (define SEEK_END 2) 202 | 203 | (defun/1 fseek (fd offset origin) ;; dumbest function in stdio 204 | (handler-case 205 | (let ((stream (fd-stream fd))) 206 | (file-position stream (case origin 207 | (0 offset) 208 | (1 (+ offset (file-position stream))) 209 | (2 (+ offset (file-length stream))))) 210 | (setf (feof fd) 0) 211 | 0) 212 | (error () 213 | (setf (ferror fd) ESPIPE) ;; is this the right error code? 214 | 1))) 215 | 216 | (defun/1 ftell (fd) 217 | (or (file-position (fd-stream fd)) -1)) 218 | 219 | (defun/1 rewind (fd) 220 | (fseek fd 0 0) 221 | (clearerr fd)) 222 | 223 | (defun/1 fgetpos (fd pos_ptr) 224 | (let ((pos (file-position (fd-stream fd)))) 225 | (if pos 226 | (progn (setf (deref* pos_ptr) pos) 227 | 0) 228 | (progn (setf errno ENOTTY) 229 | 1)))) 230 | 231 | (defun/1 fsetpos (fd pos_ptr) 232 | (handler-case (progn (if (file-position (fd-stream fd) (deref* pos_ptr)) 233 | 0 234 | (progn (setf errno ESPIPE) 235 | 1))) 236 | (error () 237 | (setf errno ESPIPE) ;; is this the right code? 238 | 1))) 239 | 240 | ;;; printf 241 | 242 | ;; adapted from ZetaC 243 | (defmacro with-padding (count &body body) ;; variable capture ahoy 244 | `(progn 245 | (when right-justify? 246 | (loop repeat ,count do (write-char pad-char stream))) 247 | ,@body 248 | (unless right-justify? 249 | (loop repeat ,count do (write-char pad-char stream))))) 250 | 251 | (defun zclib>read-decimal-from-string (str idx) 252 | "Reads a decimal value out of a string, stopping at the first 253 | non-digit. Returns the value read and the next index in the 254 | string." 255 | (let ((positive (case (code-char (aref str idx)) 256 | (#\+ (incf idx) t) 257 | (#\- (incf idx) nil) 258 | (t t)))) 259 | (do ((ch (aref str idx) (aref str (incf idx))) 260 | (val 0 (+ (* val 10.) (- ch (char-code #\0))))) 261 | ((not (and (>= ch (char-code #\0)) (<= ch (char-code #\9)))) 262 | (values (if positive val (- val)) idx))))) 263 | 264 | (defun zclib>print-integer (val width precision pad-char right-justify? 265 | alternate-form? uppercase-hex? always+- spacep pbase 266 | stream) 267 | (unless (and (zerop val) (zerop precision)) ; If PRECISION=0, don't print '0' 268 | (let* ((sign (cond ((minusp val) (setf val (- val)) "-") 269 | (always+- "+") 270 | (spacep " ") 271 | (t ""))) 272 | (buffer (format nil "~A~VR" 273 | (cond ((and alternate-form? (= pbase 8)) 274 | "0") 275 | ((and alternate-form? (= pbase 16)) 276 | (if uppercase-hex? "0X" "0x")) 277 | (t "")) 278 | pbase val)) 279 | (val-len (+ (length buffer) (length sign))) 280 | (leading-0s (max 0 (- precision val-len)))) 281 | (unless uppercase-hex? 282 | (string-downcase buffer)) 283 | (with-padding (- width (+ val-len leading-0s)) 284 | (write-string sign stream) 285 | (loop repeat leading-0s ; This is how ANSI says to do this 286 | do (write-char #\0 stream)) 287 | (write-string buffer stream))))) 288 | 289 | (defun zclib>print-flonum-1 (val precision uppercase-E-format? e-format) 290 | "Returns the printed flonum as a string. VAL is assumed to be non-negative." 291 | (if (or (eql e-format #\e) ; We must go to Exx format. 292 | (and (eql e-format #\g) 293 | ;; PRECISION tells %g when to use Exx format. 294 | (or (> val (expt 10 (1+ precision))) 295 | (< val 1.0e-4)))) 296 | (format nil 297 | (format nil "~~,~d,2,,,,'~cE" 298 | precision (if uppercase-E-format? #\E #\e)) 299 | val) 300 | (format nil (format nil "~~,~dF" precision) val))) 301 | 302 | (defun zclib>print-flonum (val width precision pad-char right-justify? 303 | uppercase-E-format? always+- spacep 304 | conv-char stream) 305 | "CONV-CHAR should be one of #\e, #\f, #\g" 306 | (let* ((negative? (minusp val)) 307 | (buffer (zclib>print-flonum-1 (abs val) precision 308 | uppercase-E-format? conv-char)) 309 | (val-len (+ (length buffer) 310 | (if (or negative? always+- spacep) 1 0)))) 311 | (with-padding (- width val-len) 312 | (cond (negative? (write-char #\- stream)) 313 | (always+- (write-char #\+ stream)) 314 | (spacep (write-char #\Space stream))) 315 | (write-string buffer stream)))) 316 | 317 | (defun/1 fprintf (fd fmt &rest args) 318 | "Prints ARGS to FD according to FMT. 319 | Characters in FMT are just copied to the output, except for %, which introduces 320 | a directive. A directive has the following syntax: 321 | %[-][0][][.][l] 322 | can be one of the following: 323 | d o x The integer is printed in decimal, octal, or hex respectively. 324 | f The float or double is printed in the style `[-]ddd.ddd' with 325 | digits after the decimal point (default 6). 326 | e The float or double is printed in the style `[-]d.ddddde[-]dd' 327 | with digits after the decimal point (default 6). 328 | g The float or double is printed in f or e style, as appropriate 329 | for its magnitude. 330 | s The string is printed; if is specified, it is the 331 | maximum number of characters to print. 332 | c The character is printed. NULs are ignored. 333 | If a minus sign appears before , the value is left justified in the 334 | field; if a zero appears before , padding will be done with zeros instead 335 | of blanks. An `l' before is ignored, as is the case of ." 336 | (let ((fmt-array (memptr-mem fmt)) 337 | (stream (fd-stream fd))) 338 | (do ((fmt-index (memptr-ptr fmt) (1+ fmt-index))) 339 | ((= (aref fmt-array fmt-index) 0) 0) 340 | (let ((ch (aref fmt-array fmt-index))) 341 | (if (eql ch (char-code #\%)) 342 | (let ((next-idx (incf fmt-index)) 343 | right-justify? pad-char always+- space-flag alternate-form 344 | width precision uppercase) 345 | 346 | ;; First we look for flags, assuming their order if present 347 | (if (= (char-code #\-) (aref fmt-array next-idx)) 348 | (incf next-idx) ; Skip '-' 349 | (setf right-justify? t)) 350 | (if (= (char-code #\0) (aref fmt-array next-idx)) 351 | ;; Here is where UNIX and H&S expect the '0' flag. See ** below. 352 | (progn (setq pad-char #\0) (incf next-idx)) ; Skip '0' 353 | (setq pad-char #\Space)) 354 | (when (= (char-code #\+) (aref fmt-array next-idx)) 355 | (setf always+- t) (incf next-idx)) ; Skip '+' 356 | (when (= (char-code #\Space) (aref fmt-array next-idx)) 357 | (setf space-flag #\Space) (incf next-idx)) ; Skip ' ' 358 | (when (= (char-code #\#) (aref fmt-array next-idx)) 359 | (setf alternate-form t) (incf next-idx)) ; Skip '#' 360 | 361 | ;; Get width, if present 362 | (if (= (char-code #\*) (aref fmt-array next-idx)) 363 | (progn 364 | (incf next-idx) ; Skip over the '*' 365 | (setq width (pop args))) ; Consume an arg for the width 366 | (progn 367 | (when (= (char-code #\0) (aref fmt-array next-idx)) 368 | ;; Here is where ANSI expects the '0' flag. See ** above. 369 | (incf next-idx) (setq pad-char #\0)) ; Skip '0' 370 | (multiple-value-setq (width next-idx) 371 | ;; If width is absent, 0 is 1st value returned 372 | (zclib>read-decimal-from-string fmt-array next-idx)))) 373 | 374 | (when (minusp width) 375 | (setf right-justify? nil ; Per ANSI spec 376 | width (abs width))) 377 | 378 | ;; Get precision, if present 379 | (when (= (char-code #\.) (aref fmt-array next-idx)) 380 | (incf next-idx) ; Skip over '.' 381 | (if (= (char-code #\*) (aref fmt-array next-idx)) 382 | (progn 383 | (incf next-idx) ; Skip over '*' 384 | (setf precision (pop args))) ; get arg for the precision 385 | (multiple-value-setq (precision next-idx) 386 | ;; If width is absent, 0 is 1st value returned 387 | (zclib>read-decimal-from-string fmt-array next-idx)))) 388 | 389 | (when (and precision (minusp precision)) 390 | (setf precision nil)) ; Per ANSI spec 391 | (when (find (code-char (aref fmt-array next-idx)) "lLh") 392 | (incf next-idx)) ; Discard long/short info 393 | 394 | (let ((char (code-char (aref fmt-array next-idx)))) 395 | (setf fmt-index next-idx) 396 | 397 | (when (upper-case-p char) 398 | (setq uppercase t 399 | ;; No int/long distinction - let uppercase %D, %U, etc. thru 400 | char (char-downcase char))) 401 | 402 | (case char 403 | ((#\d #\i #\o #\x #\u) 404 | (assert (integerp (car args))) 405 | (zclib>print-integer (pop args) 406 | (or width 0) 407 | (or precision 1) 408 | pad-char 409 | right-justify? 410 | alternate-form 411 | uppercase 412 | always+- 413 | space-flag 414 | (case char 415 | ((#\d #\i #\u) 10) 416 | (#\o 8) 417 | (#\x 16)) 418 | stream)) 419 | ((#\e #\f #\g) 420 | (zclib>print-flonum (float (pop args)) 421 | (or width 0) 422 | (or precision 6) 423 | pad-char 424 | right-justify? 425 | uppercase 426 | always+- 427 | space-flag 428 | ch 429 | stream)) 430 | (#\c 431 | (with-padding (1- width) 432 | (unless (zerop (car args)) 433 | (write-char (code-char (pop args)) stream)))) 434 | (#\s 435 | (let* ((string (pop args)) 436 | (length (min (or precision most-positive-fixnum) 437 | (vacietis.libc.string.h:strlen string)))) 438 | (with-padding (- width length) 439 | (let ((str (memptr-mem string)) 440 | (start (memptr-ptr string))) 441 | (loop for i from start below (+ start length) do 442 | (write-char (code-char (aref str i)) stream)))))) 443 | (otherwise 444 | (write-char char stream))))) 445 | (write-char (code-char ch) stream)))))) 446 | 447 | (defun/1 printf (fmt &rest args) 448 | (apply #'fprintf stdout fmt args)) 449 | 450 | (defun/1 sprintf (str fmt &rest args) 451 | (replace 452 | (memptr-mem str) 453 | (memptr-mem 454 | (string-to-char* 455 | (with-output-to-string (out) 456 | (apply #'fprintf (make-instance 'FILE :stream out) fmt args)))) 457 | :start1 (memptr-ptr str)) 458 | str) 459 | 460 | (defun/1 snprintf (string max-length fmt &rest args) 461 | (error "NOT IMPLEMENTED YET")) 462 | 463 | (defun/1 perror (str) 464 | (if (or (eql NULL str) 465 | (eql 0 (aref (memptr-mem str) (memptr-ptr str)))) 466 | (fprintf stderr (string-to-char* "%s\\n") (strerror errno)) 467 | (fprintf stderr (string-to-char* "%s: %s\\n") str (strerror errno)))) 468 | 469 | ;;; scanf 470 | 471 | (load-libc-file "scanf.c" #.(libc-dir)) 472 | 473 | ;;; things that have no effect 474 | 475 | (defun/1 setvbuf (fd buf mode size) 476 | (declare (ignore fd buf mode size)) 477 | 0) 478 | 479 | (defun/1 setbuf (fd buf) 480 | (declare (ignore fd buf)) 481 | 0) 482 | 483 | (define FILENAME_MAX 1024) 484 | (define FOPEN_MAX 1024) 485 | (define BUFSIZ 512) 486 | (define L_tmpnam 16) 487 | (define TMP_MAX 1024) 488 | (define _IOFBF 1) 489 | (define _IOLBF 2) 490 | (define _IONBF 3) 491 | -------------------------------------------------------------------------------- /libc/stdlib.h: -------------------------------------------------------------------------------- 1 | typedef struct { 2 | int quot; 3 | int rem; 4 | } div_t; 5 | 6 | typedef struct { 7 | long quot; 8 | long rem; 9 | } ldiv_t; 10 | 11 | /* typedef struct { */ 12 | /* long long int quot; */ 13 | /* long long int rem; */ 14 | /* } lldiv_t; */ 15 | -------------------------------------------------------------------------------- /libc/stdlib.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.libc.stdlib.h) 2 | (in-readtable vacietis) 3 | 4 | ;;; allocation 5 | 6 | (defun/1 malloc (size) 7 | (if (= size 0) 8 | NULL 9 | (allocate-memory size))) 10 | 11 | (defun/1 calloc (count size) 12 | (malloc (* count size))) 13 | 14 | (defun/1 realloc (memory size) 15 | (cond ((eql memory NULL) 16 | (malloc size)) 17 | ((= size 0) 18 | (free memory) 19 | NULL) 20 | (t 21 | (adjust-array (memptr-mem memory) size :initial-element 0) 22 | memory))) 23 | 24 | (defun/1 free (memory) 25 | (unless (eql NULL memory) 26 | (setf (memptr-mem memory) 'FREED_BY_FREE))) 27 | 28 | ;;; random numbers 29 | 30 | (defconstant RAND_MAX most-positive-fixnum) 31 | 32 | (defun/1 rand () 33 | (random RAND_MAX)) 34 | 35 | (defun/1 srand (state) ;; todo 36 | (error "FIGURE OUT WHAT TO DO W/RANDOM STATES") 37 | (setf *random-state* state)) 38 | 39 | ;;; numeric conversion 40 | 41 | (defun/1 atoi (str) 42 | (parse-integer (char*-to-string str) :junk-allowed t)) 43 | 44 | (defun/1 atol (str) 45 | (atoi str)) 46 | 47 | (defun/1 atoll (str) 48 | (atoi str)) 49 | 50 | (defun/1 atof (str) 51 | (let* ((str (char*-to-string str)) 52 | (start (position-if (lambda (c) 53 | (not (find c '(#\Space #\Tab #\Newline)))) 54 | str))) 55 | (read-from-string 56 | str 57 | nil 58 | nil 59 | :start start 60 | :end (position-if (lambda (c) 61 | (not (find c ".0123456789+-eE"))) 62 | str 63 | :start start)))) 64 | 65 | (defun/1 strtod (str end-ptr) 66 | (multiple-value-bind (number end) 67 | (read-from-string (char*-to-string str)) 68 | (if (numberp number) 69 | (progn 70 | (unless (eql end-ptr NULL) 71 | (setf (deref* end-ptr) (vacietis.c:+ str end))) 72 | number) 73 | (progn 74 | (setf (deref* end-ptr) str 75 | errno ERANGE) 76 | 0)))) 77 | 78 | (defun/1 strtof (a b) 79 | (strtod a b)) 80 | 81 | (defun/1 strtold (a b) 82 | (strtod a b)) 83 | 84 | (defun/1 strtol (str end-ptr base) 85 | (multiple-value-bind (number end) 86 | ;; fixme for octals 87 | (parse-integer (char*-to-string str) 88 | :radix (if (= base 0) 89 | 10 ;; should be auto 90 | base) 91 | :junk-allowed t) 92 | (if (integerp number) 93 | (progn 94 | (unless (eql end-ptr NULL) 95 | (setf (deref* end-ptr) (vacietis.c:+ str end))) 96 | number) 97 | (progn 98 | (setf (deref* end-ptr) str 99 | errno ERANGE) 100 | 0)))) 101 | 102 | (defun/1 strtoll (a b c) 103 | (strtol a b c)) 104 | 105 | (defun/1 strtoul (a b c) 106 | (strtol a b c)) 107 | 108 | (defun/1 strtoull (a b c) 109 | (strtol a b c)) 110 | 111 | ;;; program environment 112 | 113 | (define EXIT_SUCCESS 0) 114 | (define EXIT_FAILURE 1) 115 | 116 | (defun/1 abort () 117 | (throw 'vacietis::c-exit EXIT_FAILURE)) 118 | 119 | (defvar *exit-functions* ()) 120 | 121 | (defun/1 exit (status) 122 | (dolist (f *exit-functions*) 123 | (funcall f)) 124 | ;; close streams 125 | ;; delete tmpfiles 126 | (throw 'vacietis::c-exit status)) 127 | 128 | (defun/1 atexit (f) 129 | (push f *exit-functions*)) 130 | 131 | (defvar vacietis::*environment* nil) 132 | 133 | (defun/1 getenv (name) 134 | (gethash name vacietis::*environment* NULL)) 135 | 136 | (defun/1 setenv (name value) 137 | (setf (gethash name vacietis::*environment*) value)) 138 | 139 | (defun/1 system (command) ;; this could be eval 140 | (declare (ignore command)) 141 | 0) 142 | 143 | ;;; math functions 144 | 145 | (defun/1 labs (x) 146 | (abs x)) 147 | 148 | (defun/1 llabs (x) 149 | (abs x)) 150 | 151 | (defun/1 div (n d) 152 | ) 153 | 154 | (defun/1 ldiv (n d) 155 | (div n d)) 156 | 157 | (defun/1 lldiv (n d) 158 | (div n d)) 159 | 160 | ;;; search and sort 161 | ;;; TODO 162 | -------------------------------------------------------------------------------- /libc/string.c: -------------------------------------------------------------------------------- 1 | // From uClibc http://www.uclibc.org/ by Erik Andersen 2 | // LGPL 2.1 license 3 | 4 | #define size_t int 5 | 6 | char *strrchr( const char *s, int c) 7 | { 8 | const char *p; 9 | 10 | p = NULL; 11 | do { 12 | if (*s == (char) c) { 13 | p = s; 14 | } 15 | } while (*s++); 16 | 17 | return (char *) p; /* silence the warning */ 18 | } 19 | 20 | size_t strspn(const char *s1, const char *s2) 21 | { 22 | const char *s = s1; 23 | const char *p = s2; 24 | 25 | while (*p) { 26 | if (*p++ == *s) { 27 | ++s; 28 | p = s2; 29 | } 30 | } 31 | return s - s1; 32 | } 33 | 34 | char *strpbrk(const char *s1, const char *s2) 35 | { 36 | const char *s; 37 | const char *p; 38 | 39 | for ( s=s1 ; *s ; s++ ) { 40 | for ( p=s2 ; *p ; p++ ) { 41 | if (*p == *s) return (char *) s; /* silence the warning */ 42 | } 43 | } 44 | return NULL; 45 | } 46 | 47 | char *strstr(const char *s1, const char *s2) 48 | { 49 | const char *s = s1; 50 | const char *p = s2; 51 | 52 | do { 53 | if (!*p) { 54 | return (char *) s1;; 55 | } 56 | if (*p == *s) { 57 | ++p; 58 | ++s; 59 | } else { 60 | p = s2; 61 | if (!*s) { 62 | return NULL; 63 | } 64 | s = ++s1; 65 | } 66 | } while (1); 67 | } 68 | 69 | char *strtok(char * s1, const char * s2) { 70 | static char *next_start; /* Initialized to 0 since in bss. */ 71 | return strtok_r(s1, s2, &next_start); 72 | } 73 | 74 | char *strtok_r(char * s1, const char * s2, char ** next_start) { 75 | char *s; 76 | char *p; 77 | 78 | if (((s = s1) != NULL) || ((s = *next_start) != NULL)) { 79 | if (*(s += strspn(s, s2))) { 80 | if ((p = strpbrk(s, s2)) != NULL) { 81 | *p++ = 0; 82 | } 83 | } else { 84 | p = s = NULL; 85 | } 86 | *next_start = p; 87 | } 88 | return s; 89 | } 90 | 91 | // The following functions are from ZetaC 92 | 93 | // str functions 94 | 95 | char *strcpy (char *s1, char *s2) { 96 | char *s1temp = s1; 97 | 98 | do *s1++ = *s2; while (*s2++); 99 | return s1temp; 100 | } 101 | 102 | char *strncpy (char *s1, char *s2, int n) { 103 | char *s1temp = s1; 104 | 105 | while (--n >= 0) *s1++ = *s2 ? *s2++ : NULL; 106 | return s1temp; 107 | } 108 | 109 | char *strcat (char *s1, char *s2) { 110 | strcpy (s1 + strlen (s1), s2); 111 | return s1; 112 | } 113 | 114 | char *strncat (char *s1, char *s2, int n) { 115 | char *s1tmp; 116 | 117 | s1tmp = s1 + strlen (s1); /* Remember where the original string ended */ 118 | strncpy (s1tmp, s2, n); /* The real work happens here */ 119 | s1tmp[n] = 0; /* Must guarantee that result ends in NUL */ 120 | return s1; 121 | } 122 | 123 | char *strchr (char *s, char *c) { 124 | do if (*s == c) return s; while (*s++); 125 | return NULL; 126 | } 127 | 128 | 129 | int strcmp (char *s1, char *s2) { 130 | char c1, c2; 131 | 132 | while (*s1 || *s2) { 133 | c1 = *s1++; 134 | c2 = *s2++; 135 | if (c1 < c2) return -1; 136 | if (c1 > c2) return 1; 137 | } 138 | return 0; 139 | } 140 | 141 | int strncmp (char *s1, char *s2, int n) { 142 | char c1, c2; 143 | 144 | while (n-- > 0 && (*s1 || *s2)) { /* Just like strcmp, but for < n chars */ 145 | c1 = *s1++; 146 | c2 = *s2++; 147 | if (c1 < c2) return -1; 148 | if (c1 > c2) return 1; 149 | } 150 | return 0; 151 | } 152 | 153 | int strlen (char *s) { 154 | char *s0 = s; 155 | 156 | while (*s) s++; 157 | return s - s0; 158 | } 159 | 160 | int strcspn (char *s1, char *s2) { 161 | int n = 0; 162 | 163 | while (s1[n] && /* WHILE not at the end of S1, and */ 164 | !strchr(s2, s1[n])) /* not not at one of S2s chars */ 165 | n++; 166 | return n; 167 | } 168 | 169 | // mem functions 170 | 171 | char *memcpy (char *dest, char *src, int nbytes) { 172 | void *tdest = dest; 173 | while (nbytes-- > 0) *dest++ = *src++; 174 | return tdest; 175 | } 176 | 177 | char *memmove (char *dest, char *src, int nbytes) { 178 | void *tdest = dest; 179 | 180 | if (src > dest) while (nbytes-- > 0) *dest++ = *src++; 181 | else { 182 | src += nbytes; 183 | dest += nbytes; 184 | while (nbytes-- > 0) *--dest = *--src; 185 | } 186 | return tdest; 187 | } 188 | 189 | char *memset (char *dest, char c, int nbytes) { 190 | while (nbytes-- > 0) *dest++ = c; 191 | return dest; 192 | } 193 | 194 | void *memchr (char *s, char c, int nbytes) { 195 | while (nbytes-- > 0) if (*s++ == c) return (void *)(s - 1); 196 | return (void *)NULL; 197 | } 198 | 199 | int memcmp (char *m1, char *m2, int nbytes) { 200 | char c1, c2; 201 | 202 | while (nbytes-- > 0) { 203 | c1 = *m1++; 204 | c2 = *m2++; 205 | if (c1 < c2) return -1; 206 | if (c1 > c2) return 1; 207 | } 208 | return 0; 209 | } 210 | -------------------------------------------------------------------------------- /libc/string.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.libc.string.h) 2 | (in-readtable vacietis) 3 | 4 | (defun/1 strerror (errnum) 5 | (aref vacietis.libc.errno.h::errno-strings errnum)) 6 | 7 | (load-libc-file "string.c" #.(libc-dir)) 8 | -------------------------------------------------------------------------------- /runtime/program.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis) 2 | (in-readtable vacietis) 3 | 4 | (defvar *environment* (make-hash-table :test 'equal)) 5 | 6 | (defun run-c-program (program-package &key 7 | (stdin *standard-input*) 8 | (stdout *standard-output*) 9 | (stderr *error-output*)) 10 | (flet ((make-c-stream (x) (make-instance 'vacietis.libc.stdio.h::FILE :stream x))) 11 | (let ((vacietis.libc.stdio.h:stdin (make-c-stream stdin)) 12 | (vacietis.libc.stdio.h:stdout (make-c-stream stdout)) 13 | (vacietis.libc.stdio.h:stderr (make-c-stream stderr)) 14 | (*environment* (make-hash-table :test 'equal))) 15 | (catch 'c-exit 16 | (funcall (find-symbol "MAIN" program-package)))))) 17 | -------------------------------------------------------------------------------- /test/basic-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.test.basic) 2 | (in-readtable vacietis:vacietis) 3 | 4 | (in-suite vacietis.test::basic-tests) 5 | 6 | (eval-test addition0 7 | "1 + 2;" 8 | 3) 9 | 10 | (eval-test subtraction0 11 | "3-2;" 12 | 1) 13 | 14 | (eval-test global-var 15 | "int foobar = 10; 16 | foobar;" 17 | 10) 18 | 19 | ;; (eval-test for-loop0 20 | ;; "int foobar; 21 | ;; for (int x = 0, foobar = 0; x <= 10; x++) foobar += x; 22 | ;; foobar;" 23 | ;; 55) ;; comes out to 0 because of foobar scope, bug or feature? 24 | 25 | (eval-test for-loop1 26 | "int foobar = 0; 27 | for (int x = 0; x <= 10; x++) foobar += x; 28 | foobar;" 29 | 55) 30 | 31 | (eval-test string-literal 32 | "char foobar[] = \"foobar\"; 33 | foobar;" 34 | "foobar") 35 | 36 | (eval-test h&s-while-string-copy 37 | "char source_array[] = \"foobar\", dest_array[7]; 38 | char *source_pointer = source_array, *dest_pointer = dest_array; 39 | while ( *dest_pointer++ = *source_pointer++ ); 40 | dest_pointer - 7;" 41 | "foobar") 42 | 43 | (eval-test define-foo 44 | "#define FOO 1 45 | int x = FOO; 46 | x;" 47 | 1) 48 | 49 | (eval-test define-foo1 50 | "#define foo 2 51 | int baz = foo * 2; 52 | baz;" 53 | 4) 54 | 55 | (eval-test define-foo2 56 | "#define foo 1 + 4 57 | int baz = foo * 2; 58 | baz;" 59 | 9) 60 | 61 | (eval-test preprocessor-if-1 62 | "#if 2 < 1 63 | int baz = 5; 64 | baz; 65 | #endif" 66 | nil) 67 | 68 | (eval-test preprocessor-if-2 69 | "int baz = 123; 70 | #if 2 >= 1 71 | baz = 456; 72 | #endif 73 | baz;" 74 | 456) 75 | 76 | (eval-test preprocessor-ifdef 77 | "#define FOOMAX 78 | int baz = 1; 79 | #ifdef FOOMAX 80 | int baz = 2; 81 | #endif 82 | baz;" 83 | 2) 84 | 85 | (eval-test preprocessor-define-template 86 | "#define foo(x, y) x+y 87 | foo(1,2);" 88 | 3) 89 | 90 | (eval-test sizeof-static-array 91 | "static char buf[10]; 92 | sizeof buf;" 93 | 10) 94 | 95 | (eval-test sizeof-int 96 | "int foo; 97 | sizeof foo;" 98 | 1) 99 | 100 | (eval-test sizeof-int1 101 | "int foo1 = 120; 102 | sizeof foo1;" 103 | 1) 104 | 105 | (eval-test sizeof0 106 | "char foobar; 107 | sizeof (foobar);" 108 | 1) 109 | 110 | (eval-test sizeof1 111 | "long foobar; 112 | 1 + sizeof (foobar);" 113 | 2) 114 | 115 | (eval-test sizeof2 116 | "sizeof int;" 117 | 1) 118 | 119 | (eval-test sizeof3 120 | "sizeof (int);" 121 | 1) 122 | 123 | (eval-test if-then-else1 124 | "int baz; 125 | if (2 < 1) { 126 | baz = 2; 127 | } else { 128 | baz = 3; 129 | } 130 | baz;" 131 | 3) 132 | 133 | (eval-test if-then-none 134 | "int baz = 0; 135 | if (2 < 1) { 136 | baz = 2; 137 | } 138 | baz;" 139 | 0) 140 | 141 | (eval-test do-while1 142 | "int foo = 0; 143 | do foo++; while (foo < 1); 144 | foo;" 145 | 1) 146 | 147 | (eval-test setf-aref 148 | "int foo[3]; 149 | foo[0] = 123; 150 | foo[0];" 151 | 123) 152 | 153 | (eval-test strlength1 154 | "#include 155 | strlen(\"foobar\");" 156 | 6) 157 | 158 | (eval-test reverse 159 | "void reverse(char *str) { 160 | char * end = str; 161 | char tmp; 162 | 163 | if (str) { 164 | while (*end) { 165 | ++end; 166 | } 167 | 168 | --end; 169 | 170 | while (str < end) { 171 | tmp = *str; 172 | *str++ = *end; 173 | *end-- = tmp; 174 | } 175 | } 176 | } 177 | 178 | char *foo = \"foobar\"; 179 | reverse(foo); 180 | foo;" 181 | "raboof") 182 | 183 | (eval-test sprintf-padchar 184 | "#include 185 | char *foo[6]; 186 | sprintf(foo, \"%-5c\", 'X');" 187 | "X ") 188 | 189 | (eval-test typedef-bool 190 | "#include 191 | typedef bool bool_bf; 192 | bool_bf on = 1; 193 | on;" 194 | 1) 195 | 196 | (eval-test typedef 197 | "typedef int Baz; 198 | Baz baz = 4; 199 | baz;" 200 | 4) 201 | 202 | (eval-test define-define 203 | "#define FOO 1 204 | #define BAR FOO 205 | BAR;" 206 | 1) 207 | 208 | (eval-test define-define1 209 | "#define fo0(x, y) x >> y 210 | #define Bar fo0 211 | Bar(0xFFF, 2);" 212 | 1023) 213 | 214 | (eval-test function-pointer1 215 | "int add(int *x, int *y) { 216 | return *x + *y; 217 | } 218 | 219 | int apply(int ((*fun))(int *, int *), int x, int y) { 220 | return (*fun)(&x, &y); 221 | } 222 | 223 | apply((int (*)(int *, int *)) add, 2, 3);" 224 | 5) 225 | 226 | (eval-test simple-function1 227 | "void foo(int a, int b) { 228 | return a + b; 229 | } 230 | foo(11, 13);" 231 | 24) 232 | 233 | (eval-test function0 234 | "int max(int a, int b) 235 | { 236 | return a > b ? a : b; 237 | } 238 | max(-3, 10);" 239 | 10) 240 | 241 | (eval-test function1 242 | "extern int max(int a, int b) 243 | { 244 | return a > b ? a : b; 245 | } 246 | max(234, 0);" 247 | 234) 248 | 249 | (eval-test no-arg-function 250 | "int a = -4, b = 7; 251 | void foo() { 252 | return a + b; 253 | } 254 | foo();" 255 | 3) 256 | 257 | (eval-test labeled-statement1 258 | "void foo() { 259 | int a = 2, b = 5; 260 | int c = 3; 261 | goto baz; 262 | c = 7; 263 | baz: 264 | return a + b + c; 265 | } 266 | foo();" 267 | 10) 268 | 269 | (eval-test h&s-while1 270 | "int pow(int base, int exponent) 271 | { 272 | int result = 1; 273 | while (exponent > 0) { 274 | if ( exponent % 2 ) result *= base; 275 | base *= base; 276 | exponent /= 2; 277 | } 278 | return result; 279 | } 280 | pow(3, 4);" 281 | 81) 282 | 283 | (eval-test enums 284 | "enum foo { bar, baz }; 285 | enum foo x = bar; 286 | enum foo y = baz; 287 | int A = 0; 288 | 289 | if (x == bar) A = 3; 290 | A;" 291 | 3) 292 | 293 | (eval-test enums1 294 | "enum foo { bar, baz } x = bar, y = baz; 295 | int A = 0; 296 | 297 | if (x == bar) A = 3; 298 | A;" 299 | 3) 300 | 301 | (eval-test struct1 302 | "struct point { 303 | int x; 304 | int y; 305 | }; 306 | 307 | struct point pt = { 7, 11 }; 308 | pt.x + pt.y;" 309 | 18) 310 | 311 | (eval-test structs2 312 | "struct point { 313 | int x; 314 | int y; 315 | }; 316 | 317 | struct rect { 318 | struct point pt1; 319 | struct point pt2; 320 | }; 321 | 322 | struct rect screen; 323 | 324 | screen.pt1.x = 3; 325 | screen.pt2.y = 5; 326 | 327 | screen.pt1.x + screen.pt2.y;" 328 | 8) 329 | 330 | (eval-test structs3 331 | "struct point { 332 | int x; 333 | int y; 334 | }; 335 | 336 | struct rect { 337 | struct point pt1; 338 | struct point pt2; 339 | }; 340 | 341 | struct rect r, *rp = &r; 342 | 343 | r.pt2.y = 3; 344 | 345 | r.pt2.y + rp->pt2.y + (r.pt2).y + (rp->pt2).y;" 346 | 12) 347 | 348 | (eval-test ptr-addr-decl1 349 | "int x, *y = &x; 350 | x = 3; 351 | x * *y;" 352 | 9) 353 | 354 | (eval-test struct-ptr-decl1 355 | "struct point { 356 | int x; 357 | int y; 358 | } *foo, bar; 359 | 360 | bar.x = 7; 361 | bar.y = 11; 362 | foo = &bar; 363 | foo->x * (*foo).y;" 364 | 77) 365 | 366 | (eval-test pointer-lvalue 367 | "int i = 1; 368 | int *j = &i; 369 | *j += 1; 370 | i;" 371 | 2) 372 | 373 | (eval-test pointer-lvalue1 374 | "int foo[3]; 375 | int *x = &foo[1]; 376 | 377 | foo[1] = 3; 378 | foo[2] = 5; 379 | 380 | *x;" 381 | 3) 382 | 383 | (eval-test pointer-lvalue2 384 | "int foo[3]; 385 | int *x = &foo[1]; 386 | 387 | foo[1] = 3; 388 | foo[2] = 5; 389 | 390 | *(x + 1);" 391 | 5) 392 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl) 2 | 3 | (defpackage #:vacietis.test 4 | (:use #:cl #:named-readtables #:eos #:vacietis) 5 | (:intern #:eval-test 6 | #:reader-test 7 | #:program-test) 8 | (:export #:run-tests)) 9 | 10 | (defpackage #:vacietis.test.reader 11 | (:use #:vacietis.c) 12 | (:import-from #:vacietis.test #:reader-test) 13 | (:import-from #:vacietis #:string-to-char*)) 14 | 15 | (defpackage #:vacietis.test.basic 16 | (:use #:cl #:named-readtables #:eos) 17 | (:import-from #:vacietis.test #:eval-test) 18 | (:import-from #:vacietis #:string-to-char*)) 19 | 20 | (defpackage #:vacietis.test.program 21 | (:use #:cl) 22 | (:import-from #:vacietis.test #:program-test)) 23 | -------------------------------------------------------------------------------- /test/program-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:vacietis.test.program) 2 | 3 | (eos:in-suite vacietis.test::program-tests) 4 | 5 | (program-test main-return :return-code 7) 6 | 7 | (program-test main-return-include :return-code 8) 8 | 9 | (program-test main-return-include1 :return-code 9) 10 | 11 | (program-test include-libc :return-code 64) 12 | 13 | (program-test define-function1 :return-code 2) 14 | 15 | (program-test if-then-else1 :return-code 21) 16 | 17 | (program-test if-then-else2 :return-code 5) 18 | 19 | (program-test different-comment-styles :return-code 9) 20 | 21 | (program-test hello-world0 :output "hello world") 22 | 23 | (program-test hello-world :output "hello world 24 | ") 25 | 26 | (program-test inc-deref-associativity :output "123") 27 | 28 | (program-test hardway-ex3 :output 29 | "I am 10 years old. 30 | I am 72 inches tall. 31 | ") 32 | 33 | (program-test kr-echo :input "foobar" :output "foobar") 34 | 35 | (program-test hanly-83 36 | :output 37 | "Enter 8 numbers separated by blanks or s 38 | > The mean is 2.00. 39 | The standard deviation is 21.75. 40 | 41 | Table of differences between data values and mean 42 | Index Item Difference 43 | 0 16.00 14.00 44 | 1 12.00 10.00 45 | 2 6.00 4.00 46 | 3 8.00 6.00 47 | 4 2.50 0.50 48 | 5 12.00 10.00 49 | 6 14.00 12.00 50 | 7 -54.50 -56.50 51 | ") 52 | 53 | (program-test varargs1 54 | :output "Sum is 15" 55 | :return-code 1) 56 | 57 | (program-test kr-pg12 58 | :output 59 | "0 -17 60 | 20 -6 61 | 40 4 62 | 60 15 63 | 80 26 64 | 100 37 65 | 120 48 66 | 140 60 67 | 160 71 68 | 180 82 69 | 200 93 70 | 220 104 71 | 240 115 72 | 260 126 73 | 280 137 74 | 300 148 75 | ") 76 | 77 | (program-test kr-pg16 78 | :output 79 | " 0 -17.8 80 | 20 -6.7 81 | 40 4.4 82 | 60 15.6 83 | 80 26.7 84 | 100 37.8 85 | 120 48.9 86 | 140 60.0 87 | 160 71.1 88 | 180 82.2 89 | 200 93.3 90 | 220 104.4 91 | 240 115.6 92 | 260 126.7 93 | 280 137.8 94 | 300 148.9 95 | ") 96 | 97 | (program-test hanly-113 98 | :input "200" 99 | :output "Enter the distance in miles> That equals 321.8 kilometers. 100 | ") 101 | 102 | (program-test hanly-83-scanf 103 | :input "16 12 6 8 2.5 12 14 -54.5" 104 | :output 105 | "Enter 8 numbers separated by blanks or s 106 | > The mean is 2.00. 107 | The standard deviation is 21.75. 108 | 109 | Table of differences between data values and mean 110 | Index Item Difference 111 | 0 16.00 14.00 112 | 1 12.00 10.00 113 | 2 6.00 4.00 114 | 3 8.00 6.00 115 | 4 2.50 0.50 116 | 5 12.00 10.00 117 | 6 14.00 12.00 118 | 7 -54.50 -56.50 119 | ") 120 | 121 | (program-test ptr-decl1 122 | :output "9 123 | ") 124 | 125 | (program-test hs-while-string-copy 126 | :output "foobar 127 | ") 128 | 129 | (program-test pointer-lvalue2 130 | :output "5 131 | ") 132 | -------------------------------------------------------------------------------- /test/programs/define-function1/main.c: -------------------------------------------------------------------------------- 1 | int foobar (int x) { 2 | return x + 1; 3 | } 4 | 5 | int main(void) { 6 | return foobar(1); 7 | } 8 | -------------------------------------------------------------------------------- /test/programs/different-comment-styles/foobar.h: -------------------------------------------------------------------------------- 1 | // Here we have some comments 2 | /* another comment type 3 | 4 | */ 5 | 6 | #define FOOBAR 8 /* defines something */ 7 | #define OTHER 1 // something else 8 | 9 | /* to finish up */ 10 | // nah 11 | -------------------------------------------------------------------------------- /test/programs/different-comment-styles/main.c: -------------------------------------------------------------------------------- 1 | /* This file has comments */ 2 | // This file has many comments 3 | 4 | #include "foobar.h" // lots of includes 5 | 6 | int main(void) { // main 7 | /* note */ return FOOBAR + OTHER; /* doing stuff */ 8 | // !!! important 9 | } 10 | 11 | /* end of file */ 12 | -------------------------------------------------------------------------------- /test/programs/hanly-113/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #define KMS_PER_MILE 1.609 3 | 4 | int 5 | main(void) 6 | { 7 | double miles, 8 | kms; 9 | 10 | printf("Enter the distance in miles> "); 11 | scanf("%lf", &miles); 12 | 13 | kms = KMS_PER_MILE * miles; 14 | 15 | printf("That equals %.1f kilometers.\n", kms); 16 | 17 | return (0); 18 | } 19 | -------------------------------------------------------------------------------- /test/programs/hanly-83-scanf/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #define MAX_ITEM 8 5 | 6 | int 7 | main(void) 8 | { 9 | double x[MAX_ITEM], 10 | mean, 11 | st_dev, 12 | sum, 13 | sum_sqr; 14 | int i; 15 | 16 | printf("Enter %d numbers separated by blanks or s\n> ", 17 | MAX_ITEM); 18 | for (i = 0; i < MAX_ITEM; ++i) 19 | scanf("%lf", &x[i]); 20 | 21 | sum = 0; 22 | sum_sqr = 0; 23 | for (i = 0; i < MAX_ITEM; ++i) { 24 | sum += x[i]; 25 | sum_sqr += x[i] * x[i]; 26 | } 27 | 28 | mean = sum / MAX_ITEM; 29 | st_dev = sqrt(sum_sqr / MAX_ITEM - mean * mean); 30 | printf("The mean is %.2f.\n", mean); 31 | printf("The standard deviation is %.2f.\n", st_dev); 32 | 33 | printf("\nTable of differences between data values and mean\n"); 34 | printf("Index Item Difference\n"); 35 | for (i = 0; i < MAX_ITEM; ++i) 36 | printf("%3d%4c%9.2f%5c%9.2f\n", i, ' ', x[i], ' ', x[i] - mean); 37 | 38 | return 0; 39 | } 40 | -------------------------------------------------------------------------------- /test/programs/hanly-83/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #define MAX_ITEM 8 5 | 6 | int 7 | main(void) 8 | { 9 | double x[MAX_ITEM] = { 16, 12, 6, 8, 2.5, 12, 14, -54.5 }, 10 | mean, 11 | st_dev, 12 | sum, 13 | sum_sqr; 14 | int i; 15 | 16 | printf("Enter %d numbers separated by blanks or s\n> ", 17 | MAX_ITEM); 18 | 19 | sum = 0; 20 | sum_sqr = 0; 21 | for (i = 0; i < MAX_ITEM; ++i) { 22 | sum += x[i]; 23 | sum_sqr += x[i] * x[i]; 24 | } 25 | 26 | mean = sum / MAX_ITEM; 27 | st_dev = sqrt(sum_sqr / MAX_ITEM - mean * mean); 28 | printf("The mean is %.2f.\n", mean); 29 | printf("The standard deviation is %.2f.\n", st_dev); 30 | 31 | printf("\nTable of differences between data values and mean\n"); 32 | printf("Index Item Difference\n"); 33 | for (i = 0; i < MAX_ITEM; ++i) 34 | printf("%3d%4c%9.2f%5c%9.2f\n", i, ' ', x[i], ' ', x[i] - mean); 35 | 36 | return 0; 37 | } 38 | -------------------------------------------------------------------------------- /test/programs/hardway-ex3/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main() 4 | { 5 | int age = 10; 6 | int height = 72; 7 | 8 | printf("I am %d years old.\n", age); 9 | printf("I am %d inches tall.\n", height); 10 | 11 | return 0; 12 | } 13 | -------------------------------------------------------------------------------- /test/programs/hello-world/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main(void) { 4 | printf("hello world\n"); 5 | } 6 | -------------------------------------------------------------------------------- /test/programs/hello-world0/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main(void) { 4 | puts("hello world"); 5 | } 6 | -------------------------------------------------------------------------------- /test/programs/hs-while-string-copy/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void main () { 4 | char source_array[] = "foobar", dest_array[7]; 5 | char *source_pointer = source_array, *dest_pointer = dest_array; 6 | while ( *dest_pointer++ = *source_pointer++ ); 7 | printf("%s\n", dest_pointer - 7); 8 | } 9 | -------------------------------------------------------------------------------- /test/programs/if-then-else1/main.c: -------------------------------------------------------------------------------- 1 | int foobar (int x) { 2 | if (x < 1) { 3 | return 1; 4 | } else if (x <= 1) { 5 | return 2; 6 | } else if (x > 1) { 7 | return 3; 8 | } 9 | } 10 | 11 | int foobaz (int x) { 12 | if (x < 1) return 4; 13 | else if (x <= 1) return 5; 14 | else return 6; 15 | } 16 | 17 | int main(void) { 18 | int bar = 0; 19 | for (int i = 0; i < 3; i++) { 20 | bar += foobar(i) + foobaz(i); 21 | } 22 | return bar; 23 | } 24 | -------------------------------------------------------------------------------- /test/programs/if-then-else2/main.c: -------------------------------------------------------------------------------- 1 | int max(int a, int b) 2 | { 3 | return a > b ? a : b; 4 | } 5 | 6 | int main(void) { 7 | return max(0, 1) + max(4, 3); 8 | } 9 | -------------------------------------------------------------------------------- /test/programs/inc-deref-associativity/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void main() { 4 | char *foo = "123"; 5 | putchar(*foo++); 6 | putchar(*foo); 7 | putchar(*++foo); 8 | } 9 | -------------------------------------------------------------------------------- /test/programs/include-libc/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main () { 4 | return pow(8, 2); 5 | } 6 | -------------------------------------------------------------------------------- /test/programs/kr-echo/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void main() 4 | { 5 | int c; 6 | c = getchar(); 7 | while (c != EOF) { 8 | putchar(c); 9 | c = getchar(); 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /test/programs/kr-pg12/main: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vsedach/Vacietis/808914a75ea52539a124cc9df729a5296fb37ad4/test/programs/kr-pg12/main -------------------------------------------------------------------------------- /test/programs/kr-pg12/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void main() 4 | { 5 | int fahr, celsius; 6 | int lower, upper, step; 7 | lower = 0; /* lower limit of temperature scale */ 8 | upper = 300; /* upper limit */ 9 | step = 20; /* step size */ 10 | 11 | fahr = lower; 12 | while (fahr <= upper) { 13 | celsius = 5 * (fahr-32) / 9; 14 | printf("%d\t%d\n", fahr, celsius); 15 | fahr = fahr + step; 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /test/programs/kr-pg16/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void main() 4 | { 5 | int fahr; 6 | for (fahr = 0; fahr <= 300; fahr = fahr + 20) 7 | printf("%3d %6.1f\n", fahr, (5.0/9.0)*(fahr-32)); 8 | } 9 | -------------------------------------------------------------------------------- /test/programs/main-return-include/foobar.h: -------------------------------------------------------------------------------- 1 | #define FOOBAR 8 2 | -------------------------------------------------------------------------------- /test/programs/main-return-include/main.c: -------------------------------------------------------------------------------- 1 | #include "foobar.h" 2 | 3 | int main(void) { 4 | return FOOBAR; 5 | } 6 | -------------------------------------------------------------------------------- /test/programs/main-return-include1/foobar.h: -------------------------------------------------------------------------------- 1 | #define FOOBAR 8 2 | -------------------------------------------------------------------------------- /test/programs/main-return-include1/main.c: -------------------------------------------------------------------------------- 1 | #include "foobar.h" 2 | 3 | int main(void) { 4 | return FOOBAR + 1; 5 | } 6 | -------------------------------------------------------------------------------- /test/programs/main-return/main.c: -------------------------------------------------------------------------------- 1 | int main(void) { 2 | return 7; 3 | } 4 | -------------------------------------------------------------------------------- /test/programs/pointer-lvalue2/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main() { 4 | int foo[3]; 5 | int *x = &foo[1]; 6 | 7 | foo[1] = 3; 8 | foo[2] = 5; 9 | 10 | printf("%d\n", *(x + 1)); 11 | } 12 | -------------------------------------------------------------------------------- /test/programs/ptr-decl1/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main () { 4 | int x, *y = &x; 5 | x = 3; 6 | printf("%d\n", x * *y); 7 | } 8 | -------------------------------------------------------------------------------- /test/programs/varargs1/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | int varsum(int num, ...) { 5 | int result = 0; 6 | va_list numbers; 7 | va_start(numbers, num); 8 | 9 | while (num--) { 10 | result += va_arg(numbers, int); 11 | } 12 | 13 | va_end(numbers); 14 | return result; 15 | } 16 | 17 | int main () { 18 | printf("Sum is %d", varsum(3, 3, 5, 7)); 19 | return varsum(0) + 1; 20 | } 21 | -------------------------------------------------------------------------------- /test/reader-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:vacietis.test.reader) 2 | (named-readtables:in-readtable vacietis:vacietis) 3 | 4 | (eos:in-suite vacietis.test::vacietis-reader) 5 | 6 | (reader-test decimal 7 | "1234567890;" 8 | 1234567890) 9 | 10 | (reader-test float 11 | "12323.0;" 12 | 12323.0) 13 | 14 | (reader-test zero 15 | "0;" 16 | 0) 17 | 18 | (reader-test zero-float 19 | "0.0;" 20 | 0.0) 21 | 22 | (reader-test string1 23 | "x = \"foo\";" 24 | (= x (string-to-char* "foo"))) 25 | 26 | (reader-test string2 27 | "b = \"foo\" \"bar\";" 28 | (= b (string-to-char* "foobar"))) 29 | 30 | (reader-test string-escape1 31 | "_FOO = \"foo\\nbar\";" 32 | ;; yup, \n is an escape and not a format string! 33 | (= _FOO (string-to-char* "foo 34 | bar"))) 35 | 36 | (reader-test identifier1 37 | "_foo;" 38 | _foo) 39 | 40 | (reader-test identifier2 41 | "bar_foo;" 42 | bar_foo) 43 | 44 | (reader-test identifier3 45 | "bar_foo99;" 46 | bar_foo99) 47 | 48 | (reader-test int-var1 49 | "int x;" 50 | (cl:progn (cl:defparameter x 0))) 51 | 52 | ;;; function calls 53 | 54 | (reader-test funcall-args0 55 | "random();" 56 | (random)) 57 | 58 | (reader-test funcall-args1 59 | "foo(1);" 60 | (foo 1)) 61 | 62 | (reader-test funcall-args2 63 | "foo(1,2);" 64 | (foo 1 2)) 65 | 66 | (reader-test funcall-args3 67 | "foo(1,2,3);" 68 | (foo 1 2 3)) 69 | 70 | (reader-test funcall-args4 71 | "foo(1,2,3,4);" 72 | (foo 1 2 3 4)) 73 | 74 | (reader-test function-call1 75 | "printf(\"hello, world\\n\");" 76 | (printf (string-to-char* "hello, world 77 | "))) 78 | 79 | (reader-test function-call2 80 | "check_gc_signals_unblocked_or_lose(0);" 81 | (check_gc_signals_unblocked_or_lose 0)) 82 | 83 | (reader-test function-call-assign0 84 | "result = general_alloc(bytes, page_type_flag);" 85 | (= result (general_alloc bytes page_type_flag))) 86 | 87 | ;;; expressions 88 | 89 | (reader-test number-plus 90 | "1 + 2;" 91 | (+ 1 2)) 92 | 93 | (reader-test foo-plus 94 | "foo + 2;" 95 | (+ foo 2)) 96 | 97 | (reader-test elvis0 98 | "a ? 1 : 2;" 99 | (cl:if (cl:not (cl:eql 0 a)) 1 2)) 100 | 101 | (reader-test elvis1 102 | "a > b ? a : b;" 103 | (cl:if (cl:not (cl:eql 0 (> a b))) a b)) 104 | 105 | (reader-test elvis-return 106 | "return a > b ? a : b;" 107 | (cl:return (cl:if (cl:not (cl:eql 0 (> a b))) a b))) 108 | 109 | (reader-test return1 110 | "return 1;" 111 | (cl:return 1)) 112 | 113 | (reader-test lognot1 114 | "foo = ~010;" 115 | (= foo (~ 8))) 116 | 117 | (reader-test nequal1 118 | "foo != 0x10;" 119 | (!= foo 16)) 120 | 121 | (reader-test inc1 122 | "++a;" 123 | (= a (+ a 1))) 124 | 125 | (reader-test inc2 126 | "a++;" 127 | (cl:prog1 a (= a (+ a 1)))) 128 | 129 | (reader-test dec1 130 | "--a;" 131 | (= a (- a 1))) 132 | 133 | (reader-test dec2 134 | "a--;" 135 | (cl:prog1 a (= a (- a 1)))) 136 | 137 | (reader-test dec3 138 | "--foo;" 139 | (= foo (- foo 1))) 140 | 141 | (reader-test op-precedence1 142 | "a + b + c;" 143 | (+ (+ a b) c)) 144 | 145 | (reader-test assign1 146 | "foo = 1;" 147 | (= foo 1)) 148 | 149 | (reader-test assign2 150 | "foo = 1 + 2;" 151 | (= foo (+ 1 2))) 152 | 153 | (reader-test assign3 154 | "foo = !2;" 155 | (= foo (! 2))) 156 | 157 | (reader-test assign4 158 | "foo = ~2;" 159 | (= foo (~ 2))) 160 | 161 | (reader-test multi-line-exp0 162 | "(SymbolValue(GC_PENDING,th) == NIL) && 163 | (SymbolValue(GC_INHIBIT,th) == NIL) && 164 | (random() < RAND_MAX/100);" 165 | (&& (&& (== (SymbolValue GC_PENDING th) NIL) 166 | (== (SymbolValue GC_INHIBIT th) NIL)) 167 | (< (random) (/ RAND_MAX 100)))) 168 | 169 | (reader-test funcall-compare 170 | "SymbolValue(GC_PENDING,th) == NIL;" 171 | (== (SymbolValue GC_PENDING th) NIL)) 172 | 173 | (reader-test funcall-compare-parethesized 174 | "(SymbolValue(GC_PENDING,th) == NIL);" 175 | (== (SymbolValue GC_PENDING th) NIL)) 176 | 177 | (reader-test funcall-lessthan 178 | "random() < RAND_MAX/100;" 179 | (< (random) (/ RAND_MAX 100))) 180 | 181 | (reader-test multi-exp0 182 | "(SymbolValue(GC_PENDING,th) == NIL) && 183 | (SymbolValue(GC_INHIBIT,th) == NIL);" 184 | (&& (== (SymbolValue GC_PENDING th) NIL) (== (SymbolValue GC_INHIBIT th) NIL))) 185 | 186 | ;;; conditionals 187 | 188 | (reader-test if-foo1 189 | "if foo { 1 + 2; }" 190 | (cl:if (cl:eql 0 foo) 191 | cl:nil 192 | (cl:tagbody (+ 1 2)))) 193 | 194 | (reader-test if-foo2 195 | "if foo 1 + 2;" 196 | (cl:if (cl:eql 0 foo) 197 | cl:nil 198 | (+ 1 2))) 199 | 200 | (reader-test big-if 201 | "if ((SymbolValue(GC_PENDING,th) == NIL) && 202 | (SymbolValue(GC_INHIBIT,th) == NIL) && 203 | (random() < RAND_MAX/100)) { 204 | SetSymbolValue(GC_PENDING,T,th); 205 | set_pseudo_atomic_interrupted(th); 206 | maybe_save_gc_mask_and_block_deferrables(NULL); 207 | }" 208 | (cl:if (cl:eql 0 209 | (&& (&& (== (SymbolValue GC_PENDING th) NIL) 210 | (== (SymbolValue GC_INHIBIT th) NIL)) 211 | (< (random) (/ RAND_MAX 100)))) 212 | cl:nil 213 | (cl:tagbody 214 | (SetSymbolValue GC_PENDING T th) 215 | (set_pseudo_atomic_interrupted th) 216 | (maybe_save_gc_mask_and_block_deferrables vacietis.test.reader::NULL)))) 217 | 218 | (reader-test smaller-if 219 | "if ((SymbolValue(GC_PENDING,th) == NIL) && 220 | (SymbolValue(GC_INHIBIT,th) == NIL) && 221 | (random() < RAND_MAX/100)) { 222 | 1; 223 | }" 224 | (cl:if (cl:eql 0 225 | (&& (&& (== (SymbolValue GC_PENDING th) NIL) 226 | (== (SymbolValue GC_INHIBIT th) NIL)) 227 | (< (random) (/ RAND_MAX 100)))) 228 | cl:nil 229 | (cl:tagbody 1))) 230 | 231 | ;;; casts and pointers 232 | 233 | (reader-test cast1 234 | "(int) foobar;" 235 | foobar) 236 | 237 | (reader-test deref-var 238 | "*foo;" 239 | (deref* foo)) 240 | 241 | (reader-test deref-funcall 242 | "*foo();" 243 | (deref* (foo))) 244 | 245 | (reader-test deref-assign-cast 246 | "*access_control_stack_pointer(th) = (int) result;" 247 | (= (deref* (access_control_stack_pointer th)) result)) 248 | 249 | (reader-test plus-eql 250 | "access_control_stack_pointer(th) += 1;" 251 | (+= (access_control_stack_pointer th) 1)) 252 | 253 | (reader-test pointer-pointer 254 | "result = (int *) *access_control_stack_pointer(th);" 255 | (= result (deref* (access_control_stack_pointer th)))) 256 | 257 | (reader-test cast-deref 258 | "(int) *foo();" 259 | (deref* (foo))) 260 | 261 | (reader-test declare-pointer0 262 | "int *result;" 263 | (cl:progn (cl:defparameter result 0))) 264 | 265 | (reader-test ptr-ptr-cast 266 | "(int *)((char *)result + bytes);" 267 | (+ result bytes)) 268 | 269 | (reader-test ptr-ptr-cast-assign 270 | "dynamic_space_free_pointer = (int *)((char *)result + bytes);" 271 | (= dynamic_space_free_pointer (+ result bytes))) 272 | 273 | (reader-test cast-ptr-subtract 274 | "(char *)dynamic_space_free_pointer 275 | - (char *)current_dynamic_space;" 276 | (- dynamic_space_free_pointer current_dynamic_space)) 277 | 278 | (reader-test funcall-arglist-op1 279 | "foo(1 - 2);" 280 | (foo (- 1 2))) 281 | 282 | (reader-test funcall-arglist-op2 283 | "foo(1 - 2, 3 - 4);" 284 | (foo (- 1 2) (- 3 4))) 285 | 286 | (reader-test funcall-arglist-op3 287 | "foo(1 - 2, 4);" 288 | (foo (- 1 2) 4)) 289 | 290 | (reader-test funcall-cast-ptr-subtract 291 | "set_auto_gc_trigger((char *)dynamic_space_free_pointer 292 | - (char *)current_dynamic_space);" 293 | (set_auto_gc_trigger (- dynamic_space_free_pointer current_dynamic_space))) 294 | 295 | (reader-test big-if1 296 | "if (current_auto_gc_trigger 297 | && dynamic_space_free_pointer > current_auto_gc_trigger) { 298 | clear_auto_gc_trigger(); 299 | set_auto_gc_trigger((char *)dynamic_space_free_pointer 300 | - (char *)current_dynamic_space); 301 | }" 302 | (cl:if (cl:eql 0 (&& current_auto_gc_trigger 303 | (> dynamic_space_free_pointer current_auto_gc_trigger))) 304 | cl:nil 305 | (cl:tagbody 306 | (clear_auto_gc_trigger) 307 | (set_auto_gc_trigger 308 | (- dynamic_space_free_pointer current_dynamic_space))))) 309 | 310 | (reader-test deref-increment 311 | "*x++;" 312 | (deref* (cl:prog1 x (= x (+ x 1))))) 313 | 314 | (reader-test sizeof-something 315 | "int lispobj[20]; 316 | result = pa_alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)), 317 | UNBOXED_PAGE_FLAG);" 318 | (cl:progn (cl:defparameter lispobj (vacietis:allocate-memory 20))) 319 | (= result 320 | (pa_alloc 321 | (ALIGNED_SIZE 322 | (* (+ 1 words) 20)) 323 | UNBOXED_PAGE_FLAG))) 324 | 325 | (reader-test deref-cast-shift 326 | "*result = (int) (words << N_WIDETAG_BITS) | type;" 327 | (= (deref* result) 328 | (|\|| (<< words N_WIDETAG_BITS) type))) 329 | 330 | (reader-test function-vars0 331 | "void main () { 332 | int x; 333 | }" 334 | (vacietis::defun/1 main () 335 | (cl:prog* ((x 0)))) 336 | ) 337 | 338 | (reader-test function-comments0 339 | "void main () { 340 | /* this is a comment */ 341 | int x; 342 | }" 343 | (vacietis::defun/1 main () 344 | (cl:prog* ((x 0)))) 345 | ) 346 | 347 | (reader-test function-comments1 348 | "void main () { 349 | /* this is a comment */ 350 | int x; 351 | // this is another comment 352 | }" 353 | (vacietis::defun/1 main () 354 | (cl:prog* ((x 0)))) 355 | ) 356 | 357 | (reader-test while0 358 | "while (fahr <= upper) { 359 | celsius = 5 * (fahr-32) / 9; 360 | printf(\"%d\\t%d\\n\", fahr, celsius); 361 | fahr = fahr + step; 362 | }" 363 | (for (cl:nil cl:nil (<= fahr upper) cl:nil) 364 | (cl:tagbody 365 | (= celsius (/ (* 5 (- fahr 32)) 9)) 366 | (printf (string-to-char* "%d %d 367 | ") fahr celsius) 368 | (= fahr (+ fahr step))))) 369 | 370 | (reader-test multiple-declaration0 371 | "int x, y;" 372 | (cl:progn (cl:defparameter x 0) (cl:defparameter y 0))) 373 | 374 | (reader-test k&r-pg9 375 | "void main() 376 | { 377 | printf(\"hello, world\\n\"); 378 | } 379 | " 380 | (vacietis::defun/1 main () 381 | (cl:prog* () 382 | (printf (string-to-char* "hello, world 383 | "))))) 384 | 385 | (reader-test c99-style-for-init 386 | "for (int x = 0; x < 10; x++) 387 | x++;" 388 | (for (((x 0)) (cl:progn (= x 0)) (< x 10) (cl:prog1 x (= x (+ x 1)))) 389 | (cl:prog1 x (= x (+ x 1))))) 390 | 391 | (reader-test c99-style-for1 392 | "for (int x = 0; x < 10; x++) foobar += x;" 393 | (for (((x 0)) 394 | (cl:progn (= x 0)) 395 | (< x 10) 396 | (cl:prog1 x (= x (+ x 1)))) 397 | (+= foobar x))) 398 | 399 | (reader-test var-declare-and-initialize0 400 | "int x = 1;" 401 | (cl:progn (cl:defparameter x 1))) 402 | 403 | (reader-test modulo0 404 | "1 % 2;" 405 | (% 1 2)) 406 | 407 | (reader-test empty-label 408 | "int main () { end:; }" 409 | (vacietis::defun/1 main () 410 | (cl:prog* () 411 | end 412 | cl:nil))) 413 | 414 | (reader-test h&s-while2 415 | "while ( *char_pointer++ );" 416 | (for (cl:nil 417 | cl:nil 418 | (deref* (cl:prog1 char_pointer 419 | (= char_pointer (+ char_pointer 1)))) 420 | cl:nil) 421 | cl:nil)) 422 | 423 | (reader-test h&s-while3 424 | "while ( *dest_pointer++ = *source_pointer++ );" 425 | (for (cl:nil 426 | cl:nil 427 | (= (deref* (cl:prog1 dest_pointer 428 | (= dest_pointer (+ dest_pointer 1)))) 429 | (deref* (cl:prog1 source_pointer 430 | (= source_pointer (+ source_pointer 1))))) 431 | cl:nil) 432 | cl:nil)) 433 | 434 | (reader-test just-return 435 | "return;" 436 | (cl:return 0)) 437 | 438 | 439 | (reader-test pointer-to-array-of-ints 440 | "int (*foobar)[];" ;; ok not to specify size of array here 441 | (cl:progn (cl:defparameter foobar 0))) 442 | 443 | (reader-test array-of-pointers-to-int1 444 | "int *foobar[5];" 445 | (cl:progn (cl:defparameter foobar (vacietis:allocate-memory 5)))) 446 | 447 | (reader-test array-of-ints1 448 | "int foobar[5];" 449 | (cl:progn (cl:defparameter foobar (vacietis:allocate-memory 5)))) 450 | 451 | (reader-test pointer-to-int0 452 | "int *x;" 453 | (cl:progn (cl:defparameter x 0))) 454 | 455 | (reader-test char-literal0 456 | "char foobar[] = \"Foobar\";" 457 | (cl:progn (cl:defparameter foobar (string-to-char* "Foobar")))) 458 | 459 | (reader-test declaration-initialization0 460 | "int x = 1 + 2;" 461 | (cl:progn (cl:defparameter x (+ 1 2)))) 462 | 463 | (reader-test declare-two-ints0 464 | "int x, y;" 465 | (cl:progn (cl:defparameter x 0) 466 | (cl:defparameter y 0))) 467 | 468 | (reader-test declare-two-ints-initialize0 469 | "int x = 1, y;" 470 | (cl:progn (cl:defparameter x 1) 471 | (cl:defparameter y 0))) 472 | 473 | (reader-test declare-two-ints-initialize1 474 | "int x, y = 1;" 475 | (cl:progn (cl:defparameter x 0) 476 | (cl:defparameter y 1))) 477 | 478 | (reader-test declare-two-ints-initialize2 479 | "int x = 1, y = 2;" 480 | (cl:progn (cl:defparameter x 1) 481 | (cl:defparameter y 2))) 482 | 483 | (reader-test declare-two-ints-initialize3 484 | "int x = 1 + 2, y;" 485 | (cl:progn (cl:defparameter x (+ 1 2)) 486 | (cl:defparameter y 0))) 487 | 488 | (reader-test declare-two-ints-initialize4 489 | "int x, y = 1 + 2;" 490 | (cl:progn (cl:defparameter x 0) 491 | (cl:defparameter y (+ 1 2)))) 492 | 493 | (reader-test declare-two-ints-initialize5 494 | "int x = 1 + 2, y = 3 + 4;" 495 | (cl:progn (cl:defparameter x (+ 1 2)) 496 | (cl:defparameter y (+ 3 4)))) 497 | 498 | (reader-test declare-two-ints-initialize6 499 | "int x = foo(), y;" 500 | (cl:progn (cl:defparameter x (foo)) 501 | (cl:defparameter y 0))) 502 | 503 | (reader-test declare-two-ints-initialize7 504 | "int x = foo(1 + 2), y;" 505 | (cl:progn (cl:defparameter x (foo (+ 1 2))) 506 | (cl:defparameter y 0))) 507 | 508 | (reader-test declare-two-ints-initialize8 509 | "int x, y = foo(1 + 2);" 510 | (cl:progn (cl:defparameter x 0) 511 | (cl:defparameter y (foo (+ 1 2))))) 512 | 513 | (reader-test declare-two-ints-initialize9 514 | "int x = 3 + 4, y = foo(1 + 2);" 515 | (cl:progn (cl:defparameter x (+ 3 4)) 516 | (cl:defparameter y (foo (+ 1 2))))) 517 | 518 | (reader-test declare-two-ints-initialize10 519 | "int x = bar(3 + 4), y = foo(1 + 2);" 520 | (cl:progn (cl:defparameter x (bar (+ 3 4))) 521 | (cl:defparameter y (foo (+ 1 2))))) 522 | 523 | (reader-test declare-array-of-pointers 524 | "int *x[10];" 525 | (cl:progn (cl:defparameter x (vacietis:allocate-memory 10)))) 526 | 527 | (reader-test declare-pointer-to-array 528 | "int (*x)[10];" ;; pointer to array of 10 integers 529 | (cl:progn (cl:defparameter x 0))) 530 | 531 | (reader-test declare-deref1 532 | "int *x[4], *y[] = { 7, 11 };" 533 | (cl:progn (cl:defparameter x (vacietis:allocate-memory 4)) 534 | (cl:defparameter y (vacietis::make-memptr :mem (cl:vector 7 11))))) 535 | 536 | (reader-test declare-deref2 537 | "int *x[2], *y = 4;" 538 | (cl:progn (cl:defparameter x (vacietis:allocate-memory 2)) 539 | (cl:defparameter y 4))) 540 | 541 | (reader-test declare-deref3 542 | "int *x[2], *y;" 543 | (cl:progn (cl:defparameter x (vacietis:allocate-memory 2)) 544 | (cl:defparameter y 0))) 545 | 546 | (reader-test declare-deref4 547 | "int *x[2], y;" 548 | (cl:progn (cl:defparameter x (vacietis:allocate-memory 2)) 549 | (cl:defparameter y 0))) 550 | 551 | (reader-test declare-deref5 552 | "int x[1234], y;" 553 | (cl:progn (cl:defparameter x (vacietis:allocate-memory 1234)) 554 | (cl:defparameter y 0))) 555 | 556 | (reader-test declare-two-chars-initialize0 557 | "char source_pointer[] = \"foobar\", dest_pointer[7];" 558 | (cl:progn 559 | (cl:defparameter source_pointer (string-to-char* "foobar")) 560 | (cl:defparameter dest_pointer (vacietis:allocate-memory 7)))) 561 | 562 | (reader-test aref0 563 | "x[5];" 564 | ([] x 5)) 565 | 566 | (reader-test aref1 567 | "x[1 + 2];" 568 | ([] x (+ 1 2))) 569 | 570 | (reader-test h&s-static-short 571 | "static short s;" 572 | (cl:progn (cl:defparameter s 0))) 573 | 574 | (reader-test h&s-declaration-multiple-initialization 575 | "void main() { 576 | static short s; 577 | auto short *sp = &s + 3, *msp = &s - 3; 578 | }" 579 | (vacietis::defun/1 main () 580 | (cl:prog* ((msp 0) (sp 0) (s 0)) 581 | (cl:progn 582 | (= sp (+ (mkptr& s) 3)) 583 | (= msp (- (mkptr& s) 3)))))) 584 | 585 | (reader-test deref-op-precedence 586 | "&p + 1;" 587 | (+ (mkptr& p) 1)) 588 | 589 | (reader-test mkptr-increment 590 | "&p++;" 591 | (mkptr& (cl:prog1 p (= p (+ p 1))))) 592 | 593 | (reader-test preprocessor-define-template-noargs 594 | "#define getchar() getc(stdin) 595 | getchar();" 596 | (getc stdin)) 597 | 598 | (reader-test function-returns-pointer 599 | "char *strrchr( const char *s, int c) 600 | { 601 | return 2; 602 | }" 603 | (vacietis::defun/1 strrchr (s c) 604 | (cl:prog* cl:nil 605 | (cl:return 2)))) 606 | 607 | (reader-test deref-exp 608 | "*(foo + 1)" 609 | (deref* (+ foo 1))) 610 | 611 | (reader-test deref-exp1 612 | "*(s += strspn(s, s2))" 613 | (deref* (+= s (strspn s s2)))) 614 | 615 | (reader-test negative-number 616 | "-1;" 617 | (cl:- 1)) 618 | 619 | (reader-test negative-exp 620 | "-(a * b);" 621 | (cl:- (* a b))) 622 | 623 | (reader-test not-funcall 624 | "!foo()" 625 | (! (foo))) 626 | 627 | (reader-test not-deref 628 | "!*p" 629 | (! (deref* p))) 630 | 631 | (reader-test notnot 632 | "!!p" 633 | (! (! p))) 634 | 635 | (reader-test notnotnot 636 | "!!!p" 637 | (! (! (! p)))) 638 | 639 | (reader-test notnotnotnot 640 | "!!!!p" 641 | (! (! (! (! p))))) 642 | 643 | (reader-test two-deref 644 | "**p" 645 | (deref* (deref* p))) 646 | 647 | (reader-test parenthezation 648 | "(2+3) * 6;" 649 | (* (+ 2 3) 6)) 650 | 651 | (reader-test compare-plusplus 652 | "*s++ == c;" 653 | (== (deref* (cl:prog1 s (= s (+ s 1)))) c)) 654 | 655 | (reader-test compare-plusplus1 656 | "*s++ == --c;" 657 | (== (deref* (cl:prog1 s (= s (+ s 1)))) 658 | (= c (- c 1)))) 659 | 660 | (reader-test compare-plusplus2 661 | "*s++ == *--c;" 662 | (== (deref* (cl:prog1 s (= s (+ s 1)))) 663 | (deref* (= c (- c 1))))) 664 | 665 | (reader-test compare-plusplus3 666 | "*s++ == **--c;" 667 | (== (deref* (cl:prog1 s (= s (+ s 1)))) 668 | (deref* (deref* (= c (- c 1)))))) 669 | 670 | (reader-test compare-plusplus4 671 | "*s++ == ~**--c;" 672 | (== (deref* (cl:prog1 s (= s (+ s 1)))) 673 | (~ (deref* (deref* (= c (- c 1))))))) 674 | 675 | (reader-test function-returning-pointer-to-int-forward-decl 676 | "int *foo(); 677 | 123;" 678 | 123) 679 | 680 | (reader-test x**y 681 | "x**y;" 682 | (* x (deref* y))) 683 | 684 | (reader-test x+*y 685 | "x+*y;" 686 | (+ x (deref* y))) 687 | 688 | (reader-test x-*y 689 | "x-*y;" 690 | (- x (deref* y))) 691 | 692 | (reader-test x-*y 693 | "x-**y;" 694 | (- x (deref* (deref* y)))) 695 | 696 | (reader-test x***y 697 | "x***y;" 698 | (* x (deref* (deref* y)))) 699 | 700 | (reader-test x*-y 701 | "x*-y;" 702 | (* x (cl:- y))) 703 | 704 | ;; (reader-test array-of-array-of-ints 705 | ;; "int foobar[5][5];") 706 | 707 | ;; (reader-test pointer-to-array-of-ints0 708 | ;; "int (*foobar)[];" 709 | ;; (cl:progn (cl:defparameter foobar 0))) 710 | 711 | ;; (reader-test pointer-to-array-of-ints1 712 | ;; "int (*foobar)[5];" 713 | ;; (cl:progn (cl:defparameter foobar 0))) 714 | 715 | ;; (reader-test unclosed-string 716 | ;; "\"foo") 717 | 718 | ;; Handle empty defines. 719 | (reader-test preprocessor-define-only 720 | "#define PREPROCESSOR_DEFINE_ONLY 721 | #ifdef PREPROCESSOR_DEFINE_ONLY 722 | int preprocessor_define_only = 1; 723 | #endif 724 | #ifndef PREPROCESSOR_DEFINE_ONLY 725 | int preprocessor_define_only = 2; 726 | #endif" 727 | (cl:progn (cl:defparameter preprocessor_define_only 1))) 728 | 729 | ;; Treat line continuation backslash as whitespace. 730 | (reader-test ignore-line-continuation-character 731 | "int \\ 732 | ignore_line_continuation_character = 3;" 733 | (cl:progn (cl:defparameter ignore_line_continuation_character 3))) 734 | 735 | ;; Fix parsing of decimal 0 736 | (reader-test parse-decimal-zero 737 | "#if 0 738 | int preprocessor_else = 1; 739 | #endif") 740 | 741 | ;; Handle #else, test 1. 742 | (reader-test preprocessor-else 743 | "#if 0 744 | int preprocessor_else = 1; 745 | #else 746 | int preprocessor_else = 2; 747 | #endif" 748 | (cl:progn (cl:defparameter preprocessor_else 2))) 749 | 750 | ;; Handle #else, test 2. 751 | (reader-test preprocessor-parentheses 752 | "#if (0 && 1) 753 | int preprocessor_parentheses = 1; 754 | #else 755 | int preprocessor_parentheses = 2; 756 | #endif" 757 | (cl:progn (cl:defparameter preprocessor_parentheses 2))) 758 | 759 | ;; Handle #else, test 3. 760 | (reader-test preprocessor-not 761 | "#if (!0 && 1) 762 | int preprocessor_not = 1; 763 | #else 764 | int preprocessor_not = 2; 765 | #endif" 766 | (cl:progn (cl:defparameter preprocessor_not 1))) 767 | 768 | ;; Handle defined operator, test 1. 769 | (reader-test preprocessor-defined-false 770 | "#if defined PREPROCESSOR_DEFINED_FALSE 771 | int preprocessor_defined_false = 1; 772 | #else 773 | int preprocessor_defined_false = 2; 774 | #endif" 775 | (cl:progn (cl:defparameter preprocessor_defined_false 2))) 776 | 777 | ;; Handle defined operator, test 2. 778 | (reader-test preprocessor-not-defined 779 | "#if ! defined PREPROCESSOR_NOT_DEFINED 780 | int preprocessor_not_defined = 1; 781 | #else 782 | int preprocessor_not_defined = 2; 783 | #endif" 784 | (cl:progn (cl:defparameter preprocessor_not_defined 1))) 785 | 786 | ;; Handle defined operator, test 3. 787 | (reader-test preprocessor-defined-true 788 | "#define PREPROCESSOR_DEFINED_TRUE 789 | #if defined PREPROCESSOR_DEFINED_TRUE 790 | int preprocessor_defined_true = 1; 791 | #else 792 | int preprocessor_defined_true = 2; 793 | #endif" 794 | (cl:progn (cl:defparameter preprocessor_defined_true 1))) 795 | 796 | ;; Handle defined operator, test 4. 797 | (reader-test preprocessor-defined-complex 798 | "#define SOMETHING 0 799 | #define PREPROCESSOR_DEFINED_COMPLEX 800 | #if (defined PREPROCESSOR_DEFINED_COMPLEX && ! defined NOT_DEFINED && SOMETHING) 801 | int preprocessor_defined_complex = 1; 802 | #else 803 | int preprocessor_defined_complex = 2; 804 | #endif" 805 | (cl:progn (cl:defparameter preprocessor_defined_complex 2))) 806 | 807 | ;; Handle line continuation in preprocessor. 808 | (reader-test preprocessor-defined-complex-wrapped 809 | "#define SOMETHING 3 810 | #define PREPROCESSOR_DEFINED_COMPLEX_WRAPPED 811 | #if (defined PREPROCESSOR_DEFINED_COMPLEX_WRAPPED \\ 812 | && ! defined NOT_DEFINED && SOMETHING) 813 | int preprocessor_defined_complex_wrapped = 1; 814 | #else 815 | int preprocessor_defined_complex_wrapped = 2; 816 | #endif" 817 | (cl:progn (cl:defparameter preprocessor_defined_complex_wrapped 1))) 818 | 819 | ;; Support using undefined macros as values. 820 | (reader-test preprocessor-use-undefined-macro 821 | "#if PREPROCESSOR_USE_UNDEFINED_MACRO 822 | int preprocessor_use_undefined_macro = 1; 823 | #else 824 | int preprocessor_use_undefined_macro = 2; 825 | #endif" 826 | (cl:progn (cl:defparameter preprocessor_use_undefined_macro 2))) 827 | 828 | ;; Macro with one argument. 829 | (reader-test preprocessor-macro-with-one-argument 830 | "#define test 3 831 | #define MACRO_WITH_ONE_ARGUMENT(argument) argument 832 | int preprocessor_macro_with_one_argument = MACRO_WITH_ONE_ARGUMENT(test);" 833 | (cl:progn (cl:defparameter preprocessor_macro_with_one_argument 3))) 834 | 835 | ;; Macro with no concatenation. 836 | ;; Note: gcc produces a failure for this fragment: 837 | ;; error: ‘__argument’ undeclared here (not in a function) 838 | (reader-test preprocessor-no-concatenation 839 | "#define __test 3 840 | #define MACRO_NO_CONCATENATION(argument) __argument 841 | int preprocessor_macro_no_concatenation = MACRO_NO_CONCATENATION(test);" 842 | (cl:progn (cl:defparameter preprocessor_macro_no_concatenation 3))) 843 | 844 | ;; Macro with concatenation. 845 | (reader-test preprocessor-macro-with-concatenation 846 | "#define __test 3 847 | #define MACRO_WITH_CONCATENATION(argument) __##argument 848 | int preprocessor_macro_with_concatenation = MACRO_WITH_CONCATENATION(test);" 849 | (cl:progn (cl:defparameter preprocessor_macro_with_concatenation 3))) 850 | 851 | ;; Macro with double concatenation. 852 | (reader-test preprocessor-double-concatenation 853 | "#define __test__ 4 854 | #define DOUBLE_CONCATENATION(argument) __##argument##__ 855 | int preprocessor_double_concatenation = DOUBLE_CONCATENATION(test);" 856 | (cl:progn (cl:defparameter preprocessor_double_concatenation 4))) 857 | 858 | ;; Macro with double concatenation argument trim. 859 | (reader-test preprocessor-double-concatenation-trim 860 | "#define __test__ 4 861 | #define DOUBLE_CONCATENATION_TRIM(argument) __##argument##__ 862 | int double_concatenation_trim = DOUBLE_CONCATENATION_TRIM ( test );" 863 | (cl:progn (cl:defparameter double_concatenation_trim 4))) 864 | 865 | ;; Preprocessor #elif. 866 | (reader-test preprocessor-elif 867 | "#if 0 868 | # define _GL_ATTRIBUTE_DEPRECATED 3 869 | #elif 3 870 | # define _GL_ATTRIBUTE_DEPRECATED 5 871 | #endif 872 | int preprocessor_elif = _GL_ATTRIBUTE_DEPRECATED;" 873 | (cl:progn (cl:defparameter preprocessor_elif 5))) 874 | 875 | ;; Preprocessor indentation after #. 876 | (reader-test preprocessor-indentation 877 | "# if 0 878 | # define _GL_ATTRIBUTE_DEPRECATED 3 879 | # elif 0 880 | # define _GL_ATTRIBUTE_DEPRECATED 5 881 | # else 882 | # define _GL_ATTRIBUTE_DEPRECATED 8 883 | # endif 884 | int preprocessor_indentation = _GL_ATTRIBUTE_DEPRECATED;" 885 | (cl:progn (cl:defparameter preprocessor_indentation 8))) 886 | 887 | (reader-test preprocessor-long 888 | "# define PREPROCESSOR_LONG 33L 889 | int preprocessor_long = PREPROCESSOR_LONG;" 890 | (cl:progn (cl:defparameter preprocessor_long 33))) 891 | 892 | (reader-test preprocessor-long-lowercase 893 | "# define PREPROCESSOR_LONG 33l 894 | int preprocessor_long = PREPROCESSOR_LONG;" 895 | (cl:progn (cl:defparameter preprocessor_long 33))) 896 | 897 | (reader-test preprocessor-nested 898 | "#define PREPROCESSOR_NESTED_DEFINED 899 | #if 0 900 | # if 0 901 | int preprocessor_nested = 1; 902 | # else 903 | # ifdef PREPROCESSOR_NESTED_DEFINED 904 | int preprocessor_nested = 4; 905 | # else 906 | int preprocessor_nested = 3; 907 | # endif 908 | # endif 909 | #else 910 | # ifndef PREPROCESSOR_NESTED_NOT_DEFINED 911 | # if 0 912 | int preprocessor_nested = 2; 913 | # else 914 | int preprocessor_nested = 9; 915 | # endif 916 | # else 917 | int preprocessor_nested = 8; 918 | # endif 919 | #endif" 920 | (cl:progn (cl:defparameter preprocessor_nested 9))) 921 | 922 | (reader-test preprocessor-defined-value 923 | "#define PREPROCESSOR_DEFINED_VALUE 1 924 | #if defined PREPROCESSOR_DEFINED_VALUE || defined PREPROCESSOR_UNDEFINED_VALUE 925 | int preprocessor_defined_value = 3; 926 | #else 927 | int preprocessor_defined_value = 4; 928 | #endif" 929 | (cl:progn (cl:defparameter preprocessor_defined_value 3))) 930 | 931 | (reader-test preprocessor-empty-define-only 932 | "#define PREPROCESSOR_EMPTY_DEFINE_ONLY 933 | ") 934 | 935 | (reader-test preprocessor-use-empty-define 936 | "#define PREPROCESSOR_USE_EMPTY_DEFINE 937 | PREPROCESSOR_USE_EMPTY_DEFINE 938 | ") 939 | 940 | (reader-test preprocessor-use-empty-define-own-line 941 | "#define PREPROCESSOR_USE_EMPTY_DEFINE_OWN_LINE 942 | int use_empty_define_own_line_1 = 8; 943 | PREPROCESSOR_USE_EMPTY_DEFINE_OWN_LINE 944 | #if 1 945 | int use_empty_define_own_line_2 = 3; 946 | #endif" 947 | (cl:progn (cl:defparameter use_empty_define_own_line_1 8)) 948 | (cl:progn (cl:defparameter use_empty_define_own_line_2 3))) 949 | 950 | (reader-test preprocessor-inline-comment 951 | "#define _GL_FLOAT_EXPONENT_STRLEN_BOUND(min, max) \\ 952 | ( -100 < (min) && (max) < 100 ? 3 \\ 953 | : -1000 < (min) && (max) < 1000 ? 4 \\ 954 | : -10000 < (min) && (max) < 10000 ? 5 \\ 955 | : -100000 < (min) && (max) < 100000 ? 6 \\ 956 | : -1000000 < (min) && (max) < 1000000 ? 7 \\ 957 | : 8 /* not a tight bound */) 958 | int preprocessor_inline_comment = 1;" 959 | (cl:progn (cl:defparameter preprocessor_inline_comment 1))) 960 | 961 | (reader-test preprocessor-character-backslash 962 | "#if ('\\\\' == 92) 963 | int preprocessor_character_backslash = 1; 964 | #endif" 965 | (cl:progn (cl:defparameter preprocessor_character_backslash 1))) 966 | 967 | (reader-test sizeof-string 968 | "char format[sizeof \"%-+ 0*.*Lg\"];" 969 | (cl:progn (cl:defparameter format (vacietis:allocate-memory 10)))) 970 | -------------------------------------------------------------------------------- /test/test.lisp: -------------------------------------------------------------------------------- 1 | ;;; The contents of this file are released into the public domain. 2 | 3 | (in-package #:vacietis.test) 4 | (in-readtable vacietis) 5 | 6 | (def-suite vacietis-reader) 7 | (def-suite basic-tests) 8 | (def-suite program-tests) 9 | 10 | (defun run-tests () 11 | (format t "Running reader tests:~&") 12 | (run! 'vacietis-reader) 13 | (format t "Running basic tests:~&") 14 | (run! 'basic-tests) 15 | (format t "Running program tests:~&") 16 | (run! 'program-tests)) 17 | 18 | (defmacro reader-test (name input &rest s-exps) 19 | `(test ,name 20 | (is (equalp '(progn ,@s-exps) 21 | (vacietis::cstr ,input))))) 22 | 23 | (defun do-with-temp-c-package (name thunk) 24 | (let ((test-package (make-package 25 | (gensym (format nil "VACIETIS.TEST.~A" name)) 26 | :use ()))) 27 | (unwind-protect 28 | (let ((*package* test-package)) 29 | (funcall thunk)) 30 | (delete-package test-package)))) 31 | 32 | (defmacro eval-test (name input result) 33 | `(test ,name 34 | (is (equalp ,(if (stringp result) 35 | `(string-to-char* ,result) 36 | result) 37 | (do-with-temp-c-package ',name 38 | (lambda () 39 | (eval (vacietis::cstr ,input)))))))) 40 | 41 | (defmacro program-test (name &key return-code input output) 42 | `(test ,name 43 | (do-with-temp-c-package ',name 44 | (lambda () 45 | (load-c-file 46 | (merge-pathnames 47 | (format nil "programs/~(~A~)/main.c" ',name) 48 | (directory-namestring #.(or *compile-file-truename* *load-truename*)))) 49 | (let* ((test-output-stream ,(when output 50 | `(make-string-output-stream))) 51 | (result (run-c-program 52 | *package* 53 | :stdin ,(when input 54 | `(make-string-input-stream ,input)) 55 | :stdout test-output-stream))) 56 | (declare (ignorable result)) 57 | (when ,return-code 58 | (is (equal ,return-code result))) 59 | (when ,output 60 | (is (equal ,output (get-output-stream-string 61 | test-output-stream))))))))) 62 | -------------------------------------------------------------------------------- /vacietis.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- lisp -*- 2 | 3 | (defsystem :vacietis 4 | :name "vacietis" 5 | :author "Vladimir Sedach " 6 | :description "C to Common Lisp compiler" 7 | :licence "LLGPL v3 or later" 8 | :components 9 | ((:static-file "vacietis.asd") 10 | (:static-file "vacietis.test.asd") 11 | (:module :compiler 12 | :serial t 13 | :components 14 | ((:file "package") 15 | (:file "state") 16 | (:file "implementation") 17 | (:file "libc-support") 18 | (:file "type") 19 | (:file "reader"))) 20 | (:module :libc 21 | :serial t 22 | :components 23 | ((:file "package") 24 | (:file "errno") 25 | (:file "stddef") 26 | (:file "stdarg") 27 | (:static-file "stdarg.h") 28 | (:static-file "stdbool.h") 29 | (:file "ctype") 30 | (:file "math") 31 | (:file "stdio") 32 | (:static-file "scanf.c") 33 | (:file "stdlib") 34 | (:file "string") 35 | (:static-file "string.c")) 36 | :depends-on (:compiler)) 37 | (:module :runtime 38 | :components 39 | ((:file "program")) 40 | :depends-on (:compiler :libc))) 41 | :depends-on (:named-readtables :anaphora :babel :cl-ppcre :cl-fad)) 42 | -------------------------------------------------------------------------------- /vacietis.test.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- lisp -*- 2 | 3 | (defsystem :vacietis.test 4 | :author "Vladimir Sedach with-c-io (default-pathname &body body) 12 | "Executes BODY with the C runtime I/O environment set up. DEFAULT-PATHNAME 13 | is the initial default pathname (/"current working directory/")." 14 | `(let ((*default-pathname* (zclib>extract-directory 15 | (fs:parse-pathname ,default-pathname))) 16 | (*file-descriptor-table* (make-array 10.)) 17 | (*terminal-stream* (make-instance 'unix-terminal-io-stream 18 | :actual-stream terminal-io)) 19 | (*signal-table* (make-array 17.))) 20 | (setf (aref *file-descriptor-table* *stdin-fd*) 21 | (if (terminal-io-syn-stream-p standard-input) *terminal-stream* 22 | standard-input)) 23 | (setf (aref *file-descriptor-table* *stdout-fd*) 24 | (if (terminal-io-syn-stream-p standard-output) *terminal-stream* 25 | standard-output)) 26 | (setf (aref *file-descriptor-table* *stderr-fd*) 27 | (if (terminal-io-syn-stream-p error-output) *terminal-stream* 28 | error-output)) 29 | (unwind-protect-case () 30 | (progn . ,body) 31 | (:normal (zclib>close-all-files)) 32 | (:abort (zclib>close-all-files ':abort))))) 33 | 34 | (defun zclib>run-program (name default-pathname args) 35 | "Runs a Zeta-C program NAME with arguments ARGS (a list of Lisp strings)." 36 | (zclib>initialize-program name) 37 | (nlet ((main (intern "main" name)) 38 | (arg-ptrs (mapcar #'string-to-C (cons (string name) args))) 39 | ((argv.ary (make-array (* 2 (length arg-ptrs)))))) 40 | (gmap nil #'(lambda (i arg) (aset arg argv.ary (* 2 i)) 41 | (aset 0 argv.ary (+ (* 2 i) 1))) 42 | (:index 0) 43 | (:list arg-ptrs)) 44 | (cond ((not (fboundp main)) 45 | (ferror "No /"main/" function defined for program ~A" name)) 46 | ((null (arglist main)) 47 | (when args 48 | (format error-output "~S does not take arguments; ~A ignored" 49 | main args)) 50 | (zclib>with-c-io default-pathname (funcall main))) 51 | (t 52 | (zclib>with-c-io default-pathname 53 | (funcall main (1+ (length args)) argv.ary 0)))))) 54 | 55 | (defun zclib>close-all-files (&optional abort-p) 56 | "Closes all files opened by a C program. If ABORT-P is non-NIL, the 57 | files are closed and aborted." 58 | (do ((i 3 (1+ i))) 59 | ((>= i (array-length *file-descriptor-table*))) 60 | (let ((stream (aref *file-descriptor-table* i))) 61 | (and stream (send stream :close (and abort-p ':abort)))) 62 | (aset nil *file-descriptor-table* i))) 63 | 64 | (defun zclib>reset-files (&optional abort-p) 65 | "Closes all files and reinitializes STDIN, STDOUT, and STDERR. Use this 66 | instead of FS:CLOSE-ALL-FILES while debugging." 67 | (zclib>close-all-files abort-p) 68 | (nlet ((stdin (aref *file-descriptor-table* 0)) 69 | ((unix-terminal-io (if (and (typep stdin 'unix-terminal-io-stream) 70 | (eq (send stdin :actual-stream) terminal-io)) 71 | stdin 72 | (make-instance 'unix-terminal-io-stream 73 | :actual-stream terminal-io))))) 74 | (setf (aref *file-descriptor-table* 0) unix-terminal-io) 75 | (setf (aref *file-descriptor-table* 1) unix-terminal-io) 76 | (setf (aref *file-descriptor-table* 2) unix-terminal-io))) 77 | 78 | ; ================================================================ 79 | ; File I/O. 80 | 81 | ; Bidirectional I/O doesn't work in LMIT system, I think. 82 | ; OPEN etc. return an integer as file descriptor, while FOPEN etc. use NCONS of 83 | ; an integer. The latter is intended to be stored in a pointer to FILE. 84 | ; Bidirectional I/O doesn't work in LMITI system. Sigh: it's important for C 85 | ; programs. Simulate with arrays? 86 | (defun-exporting c:|open| (name-ar name-idx mode) 87 | "Opens the file NAME for reading (if MODE is 0), writing (if MODE is 1), or both 88 | (if MODE is 2). Returns an integer file descriptor, for READ, WRITE, etc." 89 | (nlet ((name (string-to-lisp name-ar name-idx)) 90 | (options (selectq mode 91 | (0 '(:direction :input)) 92 | (1 '(:direction :output)) 93 | (2 '(:direction :io #+Symbolics :direct #+Symbolics t)) 94 | (:otherwise (ferror "Unknown OPEN mode: ~D" mode)))) 95 | ((stream (lexpr-funcall #'open (zclib>merge-pathname-defaults name) 96 | :error nil options)))) 97 | (if (or (stringp stream) (errorp stream)) 98 | -1 ; it's an error msg; return -1 99 | (zclib>stream-to-fd stream)))) 100 | 101 | ; Bidirectional I/O doesn't work in LMITI system. Sigh: it's important for C 102 | ; programs. Simulate with arrays?? 103 | (defun-exporting c:|creat| (name-ar name-idx mode) 104 | "Creates a file NAME. MODE = 0: normal output file; MODE = 1: bidirectional 105 | direct. Returns an integer file descriptor, for use with READ, WRITE, etc." 106 | (nlet ((name (string-to-lisp name-ar name-idx)) 107 | (options (selectq mode 108 | (0 '(:direction :output)) 109 | (1 '(:direction :io #+Symbolics :direct #+Symbolics t)))) 110 | ((stream (lexpr-funcall #'open (zclib>merge-pathname-defaults name) 111 | :error nil options)))) 112 | (if (or (stringp stream) (errorp stream)) 113 | -1 ; it's an error msg; return -1 114 | (zclib>stream-to-fd stream)))) 115 | 116 | (defun-exporting c:|close| (fd) 117 | "Closes the file on file descriptor FD." 118 | (let ((stream (zclib>fd-to-stream fd "CLOSE" "FCLOSE"))) 119 | (send stream :close) 120 | (unless (typep stream 'unix-terminal-io-stream) 121 | (aset nil *file-descriptor-table* fd)) 122 | 0)) 123 | 124 | (defun-exporting c:|read| (fd buffer-ar buffer-idx nbytes) 125 | "Reads NBYTES from FD, putting the result in BUFFER (which should be a pointer 126 | into a char array." 127 | (nlet ((stream (zclib>fd-to-stream fd "READ" "FREAD")) 128 | #+Chars (buffer-ar (zcprim>array-as-string buffer-ar)) 129 | ((save-array-leader-0 (and (array-has-leader-p buffer-ar) 130 | (array-leader buffer-ar 0))))) 131 | (prog1 (- (send stream :string-in nil buffer-ar buffer-idx 132 | (+ buffer-idx nbytes)) 133 | buffer-idx) 134 | (and (array-has-leader-p buffer-ar) 135 | (setf (array-leader buffer-ar 0) save-array-leader-0))))) 136 | 137 | (defun-exporting c:|write| (fd buffer-ar buffer-idx nbytes) 138 | "Writes NBYTES to FD from BUFFER (which should be a pointer into a char array." 139 | (nlet ((stream (zclib>fd-to-stream fd "WRITE" "FWRITE")) 140 | #+Chars (buffer-ar (zcprim>array-as-string buffer-ar))) 141 | (send stream :string-out buffer-ar buffer-idx (+ buffer-idx nbytes)) 142 | nbytes)) 143 | 144 | (defun-exporting c:|lseek| (fd offset whence) 145 | "Sets the read/write pointer of the file on FD to OFFSET, if WHENCE is 0; or to 146 | the current location plus OFFSET, if WHENCE is 1; or to the end of the file 147 | plus OFFSET, if WHENCE is 2. If the resulting position is before the beginning 148 | of the file, does nothing and returns -1; else returns the new value of the 149 | pointer." 150 | (let ((stream (zclib>fd-to-stream fd "LSEEK" "FSEEK"))) 151 | (when (not (memq ':set-pointer (send stream :which-operations))) 152 | (ferror "Stream ~A does not support seeking" stream)) 153 | (let ((new-pos (+ offset 154 | (selectq whence 155 | (0 0) 156 | (1 (send stream :read-pointer)) 157 | (2 (send stream :length)) 158 | (:otherwise (ferror "Unknown WHENCE option ~D" whence)))))) 159 | (if (or (< new-pos 0) (> new-pos (send stream :length))) -1 160 | (send stream :set-pointer new-pos) 161 | new-pos)))) 162 | 163 | (defun-exporting c:|tell| (fd) 164 | "Returns the current value of the read/write pointer for FD." 165 | (send (zclib>fd-to-stream fd "TELL" "FTELL") :read-pointer)) 166 | 167 | (defun-exporting c:|isatty| (fd) 168 | "Is FD a stream to a terminal?" 169 | ;; Seems like a valid heuristic 170 | (if (memq *rubout-handler-message* 171 | (send (zclib>fd-to-stream fd "ISATTY" "(none)") :which-operations)) 172 | 1 0)) 173 | 174 | (defun-exporting c:|gtty| (fd sgttyb-ar sgttyb-idx) 175 | "Gets the modes for the stream attached to FD (which must be a 176 | ZETA-C:UNIX-TERMINAL-IO-STREAM) into the structure pointed to by (SGTTYB-AR 177 | . IDX) (#include )." 178 | (let ((stream (zclib>fd-to-stream fd "GTTY" "(none)"))) 179 | (if (not (typep stream 'unix-terminal-io-stream)) 180 | (ferror "GTTY attempted on non-terminal stream ~A (file descriptor ~D)" 181 | stream fd) 182 | (array-initialize sgttyb-ar 0 sgttyb-idx (+ sgttyb-idx *SGTTYB-LENGTH*)) 183 | (setf (aref sgttyb-ar (+ sgttyb-idx 4)) 184 | (+ (if (send stream :cbreak-mode) 2 0) 185 | (if (send stream :no-echo) 0 #o10))) 186 | 0))) 187 | 188 | (defun-exporting c:|stty| (fd sgttyb-ar sgttyb-idx &optional dont-flush) 189 | "Sets the modes for the stream attached to FD (which must be a 190 | ZETA-C:UNIX-TERMINAL-IO-STREAM) according to the structure pointed to by 191 | (SGTTYB-AR . IDX) (#include )." 192 | (let ((stream (zclib>fd-to-stream fd "STTY" "(none)"))) 193 | (if (not (typep stream 'unix-terminal-io-stream)) 194 | (ferror "STTY attempted on non-terminal stream ~A (file descriptor ~D)" 195 | stream fd) 196 | (let ((flags (aref sgttyb-ar (+ sgttyb-idx 4)))) 197 | (unless dont-flush 198 | (send stream :clear-input) 199 | (send stream :force-output)) 200 | (send stream :set-cbreak-mode 201 | ;; Do CBREAK for CBREAK or RAW. 202 | (or (bit-test flags 2) (bit-test flags #o40))) 203 | (send stream :set-no-echo (not (bit-test flags #o10)))) 204 | 0))) 205 | 206 | (defconstant TIOCGETP (deposit-byte 8 8 8 (char-code #\t))) 207 | (defconstant TIOCSETP (deposit-byte 9 8 8 (char-code #\t))) 208 | (defconstant TIOCSETN (deposit-byte 10 8 8 (char-code #\t))) 209 | (defconstant FIONREAD (deposit-byte 3 8 8 (char-code #\f))) 210 | 211 | (defun-exporting c:|ioctl| (fd opcode thing.ar thing.idx) 212 | "Currently handles only TIOCGETP, TIOCSETP, TIOCSETN, and FIONREAD (for 213 | terminals)." 214 | (select opcode 215 | (TIOCGETP (c:|gtty| fd thing.ar thing.idx)) 216 | (TIOCSETP (c:|stty| fd thing.ar thing.idx)) 217 | (TIOCSETN (c:|stty| fd thing.ar thing.idx t)) 218 | ;; FIONREAD expects a pointer to int. 219 | (FIONREAD (zcptr>aset thing.ar thing.idx 220 | (if (send (zclib>fd-to-stream fd "IOCTL" "(none)") 221 | :listen) 222 | 1 0))) 223 | (:otherwise (ferror "IOCTL doesn't handle opcode #o~O" opcode)))) 224 | 225 | ;;; Much prettier than hacking alarms. Name is my idea -- does ANSI library 226 | ;;; support this? 227 | (defun-exporting c:|ttytimeout| (fd timeout) 228 | (send (zclib>fd-to-stream fd "TTYTIMEOUT" "(none)") 229 | :wait-for-input-with-timeout timeout)) 230 | 231 | (defun-exporting c:|fopen| (name.ar name.idx mode.ar mode.idx) 232 | "Opens the file NAME for reading (if MODE is /"r/"), writing (if MODE is /"w/"), 233 | or appending (if MODE is /"a/"). Returns a stream (of type /"FILE */"), for 234 | use with GETC, PUTC, FPRINTF, etc." 235 | (nlet ((name (string-to-lisp name.ar name.idx)) 236 | (options (selector (string-to-lisp mode.ar mode.idx) string-equal 237 | ("r" '(:direction :input)) 238 | ("w" '(:direction :output)) 239 | ("a" '(:direction :output :if-exists :append 240 | :if-does-not-exist :create)) 241 | (:otherwise (ferror "Unknown fopen mode: ~A" 242 | (string-to-lisp mode.ar mode.idx))))) 243 | ((stream (lexpr-funcall #'open (zclib>merge-pathname-defaults name) 244 | :error nil options)))) 245 | (if (or (stringp stream) (errorp stream)) 246 | (zclib>null-pointer) ; it's an error msg; return NULL 247 | (zclib>fd-to-stdio (zclib>stream-to-fd stream))))) 248 | 249 | (defun-exporting c:|fclose| (sstream.ar sstream.idx) 250 | "Closes the file on SSTREAM." 251 | (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FCLOSE" "CLOSE") 252 | (c:|close| (zclib>stdio-to-fd sstream.ar sstream.idx))) 253 | 254 | (defun-exporting c:|fflush| (sstream.ar sstream.idx) 255 | "Flushes the output buffer on SSTREAM." 256 | (send (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FFLUSH") 257 | :force-output) 258 | 0) 259 | 260 | (defun-exporting c:|feof| (sstream.ar sstream.idx) 261 | "TRUE iff SSTREAM is at end of file." 262 | (if (send (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FEOF") 263 | :tyipeek) 264 | 0 1)) 265 | 266 | (defun-exporting c:|getchar| () 267 | (let ((c (send (aref *file-descriptor-table* *stdin-fd*) :tyi))) 268 | (if c (char-code c) EOF))) 269 | 270 | (defun-exporting c:|getc| (sstream.ar sstream.idx) 271 | "Returns the next character from SSTREAM, or EOF if none." 272 | (let ((c (send (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "GETC" 273 | "READ (called differently)") 274 | :tyi))) 275 | (if c (char-code c) EOF))) 276 | 277 | (defun-exporting c:|fgetc| (sstream.ar sstream.idx) 278 | "Returns the next character from SSTREAM, or EOF if none." 279 | (c:|getc| sstream.ar sstream.idx)) 280 | 281 | (defun-exporting c:|ungetc| (c sstream.ar sstream.idx) 282 | "Ungets the previously read character C from SSTREAM. Only one character may be 283 | ungotten at a time, and it must be the same as the last character read." 284 | (unless (= c EOF) 285 | (send (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "UNGETC") :untyi 286 | (code-char c))) 287 | c) 288 | 289 | (defun-exporting c:|getw| (sstream.ar sstream.idx) 290 | "Gets a word (two bytes) from SSTREAM. Does not assume, nor enforce, any special 291 | alignment." 292 | (let* ((strm (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "GETW")) 293 | (c1 (send strm :tyi)) 294 | (c2 (send strm :tyi))) 295 | (or (and c1 c2 296 | (deposit-byte (char-code c1) 8 8 (char-code c2))) 297 | EOF))) 298 | 299 | (defun-exporting c:|gets| (s.ar s.idx) 300 | "Reads a line from STDIN into the character array S. Does not include the 301 | trailing newline. Returns NULL if end-of-file was encountered immediately." 302 | (let ((stdin (aref *file-descriptor-table* *stdin-fd*))) 303 | (if (null (send stdin :tyipeek)) 304 | (zclib>null-pointer) 305 | (do ((c (send stdin :tyi) (send stdin :tyi)) 306 | (idx s.idx (1+ idx))) 307 | ((or (null c) (eql c #\Return)) 308 | (aset (char-code NUL) s.ar idx) 309 | (values s.ar s.idx)) 310 | (aset (char-code c) s.ar idx))))) 311 | 312 | (defun-exporting c:|fgets| (s.ar s.idx n sstream.ar sstream.idx) 313 | "Reads a line from SSTREAM into the character array S. Reads at most N - 1 314 | characters before returning. The line includes the trailing newline, if 315 | one was read. Returns NULL if end-of-file was encountered immediately." 316 | (do ((idx s.idx (1+ idx)) 317 | (n n (1- n)) 318 | (strm (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FGETS"))) 319 | ((<= n 1) 320 | (aset (char-code NUL) s.ar idx) 321 | (values s.ar s.idx)) 322 | (let ((c (send strm :tyi))) 323 | (if (null c) 324 | (progn (aset (char-code NUL) s.ar idx) (return (zclib>null-pointer))) 325 | (aset (char-code c) s.ar idx) 326 | (when (eql c #\Return) (setq n 1)))))) 327 | 328 | (defun-exporting c:|putchar| (ch) 329 | "Writes a character to the standard output." 330 | (tyo (code-char ch) (aref *file-descriptor-table* *stdout-fd*)) 331 | ch) 332 | 333 | (defun-exporting c:|putc| (ch sstream.ar sstream.idx) 334 | "Writes a character to SSTREAM." 335 | (tyo (code-char ch) (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "PUTC")) 336 | ch) 337 | 338 | (defun-exporting c:|fputc| (ch sstream.ar sstream.idx) 339 | "Writes a character to SSTREAM." 340 | (c:|putc| ch sstream.ar sstream.idx)) 341 | 342 | (defun-exporting c:|putw| (w sstream.ar sstream.idx) 343 | "Writes a word (two bytes) to SSTREAM. Does not assume nor enforce any 344 | special alignment." 345 | (let ((strm (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "PUTW"))) 346 | (tyo (code-char (load-byte w 0 8)) strm) 347 | (tyo (code-char (load-byte w 8 8)) strm)) 348 | w) 349 | 350 | (defun-exporting c:|puts| (s.ar s.idx) 351 | "Writes string S to STDOUT, appending a newline." 352 | (send (aref *file-descriptor-table* *stdout-fd*) 353 | :line-out #-Chars s.ar #+Chars (zcprim>array-as-string s.ar) 354 | s.idx (+ s.idx (c:|strlen| s.ar s.idx))) 355 | '(:|No value returned from| c:|puts|)) 356 | 357 | (defun-exporting c:|fputs| (s.ar s.idx sstream.ar sstream.idx) 358 | "Writes string S to SSTREAM (does not append a newline)." 359 | (send (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FPUTS") 360 | :string-out #-Chars s.ar #+Chars (zcprim>array-as-string s.ar) 361 | s.idx (+ s.idx (c:|strlen| s.ar s.idx))) 362 | '(:|No value returned from| c:|fputs|)) 363 | 364 | (defun-exporting c:|fread| (buffer.ar buffer.idx item-size item-count 365 | sstream.ar sstream.idx) 366 | "Reads ITEM-COUNT items, each ITEM-SIZE bytes long, from SSTREAM into BUFFER. 367 | At the moment, ITEM-SIZE must be 1 (only char arrays can be read.)" 368 | (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FREAD" "READ") ; Ck error. 369 | (c:|read| (zclib>stdio-to-fd sstream.ar sstream.idx) 370 | buffer.ar buffer.idx (* item-size item-count))) 371 | 372 | (defun-exporting c:|fwrite| (buffer.ar buffer.idx item-size item-count 373 | sstream.ar sstream.idx) 374 | "Writes ITEM-COUNT items, each ITEM-SIZE bytes long, to SSTREAM from BUFFER. 375 | At the moment, ITEM-SIZE must be 1 (only char arrays can be written.)" 376 | (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FWRITE" "WRITE") ; Ck error. 377 | (c:|write| (zclib>stdio-to-fd sstream.ar sstream.idx) 378 | buffer.ar buffer.idx (* item-size item-count))) 379 | 380 | (defun-exporting c:|fseek| (sstream.ar sstream.idx offset whence) 381 | "Sets the read/write pointer of SSTREAM to OFFSET, if WHENCE is 0; or to the 382 | current location plus OFFSET, if WHENCE is 1; or to the end of the file plus 383 | OFFSET, if WHENCE is 2. If the resulting position is before the beginning of 384 | the file, does nothing and returns -1; else returns the new value of the 385 | pointer." 386 | (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FSEEK" "LSEEK") 387 | (c:|lseek| (zclib>stdio-to-fd sstream.ar sstream.idx) offset whence)) 388 | 389 | (defun-exporting c:|ftell| (sstream.ar sstream.idx) 390 | "Returns the current value of the read/write pointer for SSTREAM." 391 | (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FTELL" "TELL") 392 | (c:|tell| (zclib>stdio-to-fd sstream.ar sstream.idx))) 393 | 394 | (defun-exporting c:|frewind| (sstream.ar sstream.idx) 395 | "Sets the read/write pointer for SSTREAM to 0." 396 | (zclib>stdio-to-lispm-stream sstream.ar sstream.idx "FREWIND" 397 | "LSEEK (with additional arguments 0L, 0)") 398 | (c:|fseek| sstream.ar sstream.idx 0 0)) 399 | 400 | (defun zclib>stream-to-fd (stream) 401 | "Adds STREAM to the file descriptor table, and returns its index." 402 | (let ((idx (array-search nil *file-descriptor-table*))) 403 | (when (null idx) 404 | (setq idx (array-length *file-descriptor-table*)) 405 | (adjust-array-size *file-descriptor-table* (* 2 idx))) 406 | (aset stream *file-descriptor-table* idx) 407 | idx)) 408 | 409 | (defun array-search (x array &optional (from 0) to) 410 | "Searches ARRAY for element X, using EQ for comparisons. Search runs from 411 | element FROM (inclusive) to TO (exclusive); TO defaults to the active length of 412 | the array. Returns the index of the first element EQ to X, or NIL if none." 413 | (do ((i from (1+ i)) 414 | (to (or to (array-active-length array)))) 415 | ((>= i to) nil) 416 | (when (eq x (aref array i)) 417 | (return i)))) 418 | 419 | (defun zclib>fd-to-stream (fd func sfunc) 420 | (when (zcptr>ptr-p fd) 421 | (ferror "~A called on FOPENed stream ~S; use ~A instead" 422 | func fd sfunc)) 423 | (when (or (not (fixnump fd)) 424 | (< fd 0) 425 | (>= fd (array-length *file-descriptor-table*))) 426 | (ferror "Illegal file descriptor ~S" fd)) 427 | (or (aref *file-descriptor-table* fd) 428 | (ferror "File descriptor ~S refers to a closed file" fd))) 429 | 430 | (defun zclib>stdio-to-fd (sstream.ar sstream.idx) 431 | (if (eq sstream.ar :stdio) sstream.idx 432 | sstream.ar)) ; for back compatibility. 433 | 434 | (defun zclib>fd-to-stdio (fd) 435 | (values ':stdio fd)) 436 | 437 | (defun zclib>stdio-to-lispm-stream (sstream.ar sstream.idx func &optional kfunc) 438 | (ignore func kfunc) 439 | (zclib>fd-to-stream (zclib>stdio-to-fd sstream.ar sstream.idx) nil nil)) 440 | 441 | (defmacro zclib>initialize-file-pointer (name fd) 442 | (multiple-value-bind (array index) 443 | (zcprim>pointer-var-pair name) 444 | `(progn 'compile ;; Why not? 445 | (multiple-value (,array ,index) (zclib>fd-to-stdio ,fd)) 446 | (setq ,name (zcptr>cons ,array ,index))))) 447 | 448 | (defun zclib>extract-directory (pn) 449 | (send pn :new-pathname :name nil :type nil :version nil)) 450 | 451 | (defun zclib>parse-pathname (name) 452 | (let ((pn (fs:merge-pathnames name (or *default-pathname* (fs:user-homedir))))) 453 | #-Symbolics ; Why is this necessary? Oh well 454 | (when (memq (send pn :directory) '(nil :root)) 455 | (setq pn (send pn :new-directory :unspecific))) 456 | pn)) 457 | 458 | (defun zclib>merge-pathname-defaults (file) 459 | (fs:merge-pathnames file (or *default-pathname* (fs:user-homedir)))) 460 | 461 | 462 | ; ================================================================ 463 | ; Misc. file operations. 464 | 465 | (defun-exporting c:|unlink| (name.ar name.idx) 466 | "Deletes the file of the specified name. Does not expunge it." 467 | (if (stringp (deletef (zclib>merge-pathname-defaults 468 | (string-to-lisp name.ar name.idx)) nil)) 469 | -1 0)) 470 | 471 | (defun-exporting c:|chdir| (new-dir.ar new-dir.idx) 472 | "Changes the current directory to that specified by NEW-DIR. Note that NEW-DIR 473 | must be recognizable by FS:PARSE-PATHNAME as containing a directory." 474 | (setq *default-pathname* 475 | (zclib>extract-directory 476 | (fs:parse-pathname (string-to-lisp new-dir.ar new-dir.idx)))) 477 | 0) 478 | 479 | 480 | ; ================================================================ 481 | ; Miscellaneous. 482 | 483 | (defun-exporting c:|longjmp| (jmp_buf val) 484 | "Nonlocal exit. See SETJMP." 485 | (#+Symbolics throw #-Symbolics *throw jmp_buf 486 | (values (if (eql val 0) 1 val) jmp_buf))) 487 | --------------------------------------------------------------------------------