├── .gitignore ├── AUTHORS ├── COPYING ├── ChangeLog ├── LICENSE ├── Makefile.am ├── NEWS ├── README ├── README.md ├── TODO ├── _config.yml ├── c-mera.asd ├── configure.ac ├── roswell └── cm.ros ├── src ├── c-mera │ ├── c-mera.lisp │ ├── cmd.lisp │ ├── nodes.lisp │ ├── pretty.lisp │ ├── traverser.lisp │ ├── utils.lisp │ └── version.lisp ├── c │ ├── cm-c.lisp │ ├── cmu-c.lisp │ ├── nodes.lisp │ ├── pretty.lisp │ ├── reader.lisp │ ├── syntax.lisp │ ├── traverser.lisp │ └── utils.lisp ├── cuda │ ├── cm-cuda.lisp │ ├── nodes.lisp │ ├── pretty.lisp │ └── syntax.lisp ├── cxx │ ├── cm-cxx.lisp │ ├── cmu-cxx.lisp │ ├── nodes.lisp │ ├── pretty.lisp │ ├── reader.lisp │ ├── syntax.lisp │ └── traverser.lisp ├── front │ └── cm.c ├── glsl │ ├── cm-glsl.lisp │ ├── nodes.lisp │ ├── pretty.lisp │ └── syntax.lisp └── opencl │ ├── cm-opencl.lisp │ ├── nodes.lisp │ ├── pretty.lisp │ └── syntax.lisp ├── tests ├── Makefile ├── c.comment.00.lisp ├── c.cond.00.lisp ├── c.cond.01.lisp ├── c.decl.00.lisp ├── c.decl.01.lisp ├── c.decl.02.lisp ├── c.do.01.lisp ├── c.for.00.lisp ├── c.for.01.lisp ├── c.goto.00.lisp ├── c.meta.01.decompose-decl.lisp ├── c.misc.01.sizeof.lisp ├── c.misc.02.usevar.lisp ├── c.misc.03.macrolet.defmacro.lisp ├── c.misc.04.hex.lisp ├── c.misc.05.unary.lisp ├── c.misc.06.macrolet2.lisp ├── c.misc.07.reader.lisp ├── c.misc.09.struct.lisp ├── c.misc.10.cpp.lisp ├── c.misc.11.funcall.oref.funcall.lisp ├── c.misc.12.varargs.lisp ├── c.renaming.00.lisp ├── c.switch.00.lisp ├── c.when.01.lisp ├── c.when.02.lisp ├── c.while.01.lisp ├── cxx.class.00.lisp ├── cxx.class.01.lisp ├── cxx.class.02.lisp ├── cxx.class.03.lisp ├── cxx.class.04.lisp ├── cxx.decl.00.lisp ├── cxx.decl.01.lisp ├── cxx.decl.02.lisp ├── cxx.decl.03.lisp ├── cxx.meta.01.decompose-decl.lisp ├── cxx.misc.cast.00.lisp ├── cxx.misc.foreach.00.lisp ├── cxx.misc.lambda.00.lisp ├── cxx.misc.operators.00.lisp ├── cxx.misc.reader.00.lisp ├── cxx.misc.stmt-expr.00.lisp ├── cxx.misc.trycatch.00.lisp ├── cxx.namespace.00.lisp ├── cxx.namespace.01.lisp ├── cxx.namespace.02.lisp ├── cxx.namespace.03.lisp ├── cxx.namespace.04.lisp ├── cxx.namespace.05.lisp ├── cxx.namespace.06.lisp ├── cxx.namespace.07.lisp ├── cxx.namespace.08.lisp ├── cxx.namespace.09.lisp ├── cxx.namespace.10.lisp ├── cxx.templates.01.lisp ├── cxx.templates.02.lisp └── cxx.templates.03.lisp └── util ├── build ├── dump-c.lisp.in ├── dump-cuda.lisp.in ├── dump-cxx.lisp.in ├── dump-glsl.lisp.in └── dump-opencl.lisp.in ├── emacs ├── cm-mode.el └── cm.indent └── vim └── lisp_cmera.vim /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.dirstamp 3 | .deps 4 | Makefile 5 | Makefile.in 6 | configure 7 | config.status 8 | config.h 9 | config.h.in 10 | install-sh 11 | missing 12 | compile 13 | aclocal.m4 14 | autom4te.cache 15 | stamp-h1 16 | depcomp 17 | config.log 18 | *~ 19 | #* 20 | *TAGS 21 | /util/build/*.lisp 22 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Alexander Lier 2 | Kai Selgrad 3 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiselgra/c-mera/97701e850247fa39d79d36c4f302fbb6a116fb5c/ChangeLog -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | COPYING -------------------------------------------------------------------------------- /Makefile.am: -------------------------------------------------------------------------------- 1 | bin_PROGRAMS = cm cm-c cm-cxx cm-glsl cm-cuda cm-opencl 2 | 3 | AUTOMAKE_OPTIONS = subdir-objects 4 | 5 | cm_c_SOURCES = c-mera.asd \ 6 | src/c-mera/version.lisp \ 7 | src/c-mera/cmd.lisp \ 8 | src/c-mera/utils.lisp \ 9 | src/c-mera/nodes.lisp \ 10 | src/c-mera/traverser.lisp \ 11 | src/c-mera/pretty.lisp \ 12 | src/c-mera/c-mera.lisp \ 13 | src/c/utils.lisp \ 14 | src/c/nodes.lisp \ 15 | src/c/traverser.lisp \ 16 | src/c/pretty.lisp \ 17 | src/c/syntax.lisp \ 18 | src/c/reader.lisp \ 19 | src/c/cm-c.lisp \ 20 | src/c/cmu-c.lisp 21 | 22 | cm_cxx_SOURCES = src/cxx/nodes.lisp \ 23 | src/cxx/traverser.lisp \ 24 | src/cxx/syntax.lisp \ 25 | src/cxx/pretty.lisp \ 26 | src/cxx/reader.lisp \ 27 | src/cxx/cm-cxx.lisp \ 28 | src/cxx/cmu-cxx.lisp 29 | 30 | cm_glsl_SOURCES = src/glsl/nodes.lisp \ 31 | src/glsl/syntax.lisp \ 32 | src/glsl/pretty.lisp \ 33 | src/glsl/cm-glsl.lisp 34 | 35 | cm_cuda_SOURCES = src/cuda/nodes.lisp \ 36 | src/cuda/syntax.lisp \ 37 | src/cuda/pretty.lisp \ 38 | src/cuda/cm-cuda.lisp 39 | 40 | cm_opencl_SOURCES = src/opencl/nodes.lisp \ 41 | src/opencl/syntax.lisp \ 42 | src/opencl/pretty.lisp \ 43 | src/opencl/cm-opencl.lisp 44 | 45 | # since we store $(bindir) in the front-end program we have to make sure to recompile 46 | # when the Makefile changes (potential change of prefix. 47 | cm_SOURCES = src/front/cm.c 48 | cm_CFLAGS = -DBINDIR=\"$(bindir)\" 49 | cm$(EXEEXT): $(cm_SOURCES) Makefile 50 | $(CC) $(CPPFLAGS) $(cm_CFLAGS) $< -o $@ 51 | 52 | cm-c$(EXEEXT): $(cm_c_SOURCES) 53 | @LISP_PROG@ @DYNAMIC_SPACE_SPEC@ @LISP_LOAD_ARG@ util/build/dump-c.lisp 54 | 55 | cm-glsl$(EXEEXT) : $(cm_c_SOURCES) $(cm_glsl_SOURCES) 56 | @LISP_PROG@ @DYNAMIC_SPACE_SPEC@ @LISP_LOAD_ARG@ util/build/dump-glsl.lisp 57 | 58 | cm-cxx$(EXEEXT): $(cm_c_SOURCES) $(cm_cxx_SOURCES) 59 | @LISP_PROG@ @DYNAMIC_SPACE_SPEC@ @LISP_LOAD_ARG@ util/build/dump-cxx.lisp 60 | 61 | cm-cuda$(EXEEXT): $(cm_c_SOURCES) $(cm_cxx_SOURCES) $(cm_cuda_SOURCES) 62 | @LISP_PROG@ @DYNAMIC_SPACE_SPEC@ @LISP_LOAD_ARG@ util/build/dump-cuda.lisp 63 | 64 | cm-opencl$(EXEEXT): $(cm_c_SOURCES) $(cm_cxx_SOURCES) $(cm_opencl_SOURCES) 65 | @LISP_PROG@ @DYNAMIC_SPACE_SPEC@ @LISP_LOAD_ARG@ util/build/dump-opencl.lisp 66 | 67 | EXTRA_DIST = util/build/dump-c.lisp util/build/dump-glsl.lisp \ 68 | util/build/dump-cxx.lisp util/build/dump-cuda.lisp \ 69 | util/build/dump-opencl.lisp 70 | 71 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiselgra/c-mera/97701e850247fa39d79d36c4f302fbb6a116fb5c/NEWS -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | README.md -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # C-Mera 2 | C-Mera is a very simple source-to-source compiler 3 | that utilizes Lisp's macro system for meta programming of C-like languages. 4 | One of its main goals is to be easily extensible to other C-like languages 5 | and the different versions based on C-Mera's core illustrate that this is a simple process. 6 | 7 | **Please note:** C-Mera is in a good place and works for the things we use it for. There may be no commits for some stretches and it definitely is not our full-time job, but it is alive and well :) So please consier it slow, not dead. Set up an issue if you have problems, questions or feature-requests :) 8 | 9 | ## Contents 10 | 1. [Overview](#Overview) 11 | 1. [License](#License) 12 | 1. [Usage](#Usage) 13 | 1. [Build Instructions](#BuildInstructions) 14 | 1. [Emacs Integration](#EmacsIntegration) 15 | 1. [Vim Integration](#VimIntegration) 16 | 1. [Examples](#Examples) 17 | 1. [Compilation Process](#CompilationProcess) 18 | 1. [Programming Guide](#ProgGuide) 19 | 20 | ## C-Mera 21 | The C-Mera system is a set of very simple compilers that 22 | transform a notation based on S-Expressions (sexp) 23 | for C-like languages to the native syntax of that language, 24 | e.g. from sexp-C to C, and from sexp-CUDA to CUDA. The 25 | semantics of the sexp-based notation is identical to that of 26 | the native language, i.e. no inherent abstraction or layering 27 | is introduced. 28 | 29 | There are a number of different code generators available, all based on C-Mera with a few syntactic extensions. 30 | 31 | - **cm-c** is the default C code generator 32 | - **cm-cxx** is an extension supporting a subset of C++ 33 | - **cm-cuda** is an extension featuring cuda kernel definition and call syntax 34 | - **cm-glsl** is an extension of cgen that can generate opengl shader code 35 | - **cm-ocl** (or **cm-opencl**) is an extension that can generate opencl code (currently not actively maintained and tested, though) 36 | 37 | The recommended way to select a generator is by using the front-end program **cm**: 38 | 39 | $ cm c ... 40 | $ cm c++ ... 41 | $ ... 42 | 43 | The code for C-Mera and the C-backend is found in src/{c-mera,c,usr} and is rather comprehensive while the 44 | other generators (each in their own subdirectory) are quite concise. Browse the 45 | files of the derived generators to see how far the respective language support 46 | has grown. 47 | 48 | ## License 49 | The C-Mera system (which is the collective term for the code in the repository) 50 | is provided under the conditions of the GNU GPL version 3 or later, see the file COPYING. 51 | 52 | ## Usage 53 | 54 | To generate a C source file choose the appropriate generator and simply add the input 55 | and output file: 56 | 57 | $ cm c input.lisp -o test.c 58 | $ cm c++ input.lisp -o test.cpp 59 | 60 | For more details see [Compilation Process](#compilation) 61 | 62 | Please note that, as implied above, the system primarily implements a simple transformation and thus does not rewrite lisp code to, for example, either C or C++, but compiles C code written in Sexps to plain C, and C++ code written in Sexps to plain C++. 63 | 64 | However, the system can be leveraged to provide very high level programming paradigms by the use of Common Lisp macros, see [our papers](#papers). 65 | 66 | ### Build Instructions 67 | 68 | We recommend CCL due to long code-transformation times with SBCL. 69 | 70 | - Install SBCL or CCL 71 | - Install Clon (See reference [there](https://www.lrde.epita.fr/%7Edidier/software/lisp/clon.php)) 72 | - (Alternatively, install Clon with Quicklisp) 73 | - Install Quicklisp (See the example [there](https://www.quicklisp.org/)) 74 | - `sbcl --eval "(ql:quickload :net.didierverna.clon.core)"` or 75 | - `ccl --eval "(ql:quickload :net.didierverna.clon.core)"` 76 | - Build C-Mera 77 | - `autoreconf -if` (when building from a fresh repo) 78 | - `./configure --with-sbcl` (or `--with-ccl`) 79 | - `make` 80 | - `make install` 81 | 82 | ### Emacs Integration 83 | The easiest way to configure your Lisp to load C-Mera is by adding it to quicklisp, as follows 84 | 85 | $ ln -s ~/quicklisp/local-projects/c-mera 86 | 87 | #### Slime 88 | With this setup it is possible to use Slime for the development process. 89 | The relevant C-Mera modules can be loaded by 90 | 91 | (asdf:load-system :c-mera) 92 | (asdf:load-system :cmu-c) ; or :cmu-c++, cmu-cuda, etc. 93 | (in-package :cmu-c) ; cl-user equivalent with c-mera environment for c 94 | (cm-reader) ; switch to c-mera reader; optional for prototyping 95 | ; switch back with (cl-reader) 96 | 97 | After that you can enter Lisp expressions that print valid C Code to the REPL. 98 | 99 | (simple-print 100 | (function main () -> int 101 | (return 0))) 102 | 103 | #### Emacs Minor Mode (cm-mode) 104 | To support proper indentation and highlighting of keywords, especially when your forms are not known to a SLIME session, we provide a simple minor mode for Emacs. You can set it up by 105 | 106 | $ cp /util/emacs/cm-mode.el /cm-mode.el 107 | $ cp /util/emacs/cm.indent ~/.emacs.d/cm.indent 108 | 109 | You can then add `(require 'cm-mode)` to your `.emacs` file and load it using `M-x cm-mode`. 110 | To load it automatically you can add a mode specification to the top of your file: 111 | 112 | ; -*- mode: Lisp; eval: (cm-mode 1); -*- 113 | 114 | You can extend the indentation and keyword information by having an additional file called `cm.indent` along your source files, see the provided `cm.indent` for the layout. 115 | 116 | Our cm-mode ist still rather basic and we are open for extensions (e.g. better syntax matching). 117 | 118 | 119 | ### Vim Integration 120 | 121 | With Vim 8 asyc processes spawned Vlime, a project that strives to provide a Slime-like worlflow for Vim. We use is (via a small plugin) to drive indentation of C-Mera code. With Vim set up for Vlime you only have to drop the plugin in the appropriate place: 122 | 123 | $ ln -s /util/vim/lisp_cmera.vim ~/.vim/ftplugin/ 124 | 125 | To get the default behavior (see Emacs integraion) it still has to be told where to look for the `cm.indent` file. This can be set in your `~/.vimrc` 126 | 127 | let g:cmera_base_indent_file = '/home/kai/.emacs.d/cm.indent' 128 | 129 | 130 | ### Publications 131 | - C-Mera was introduced as "cgen" at ELS'14: [*Defmacro for C: Lightweight, Ad Hoc Code Generation*](https://selgrad.org/publications/2014_els_SLWLS.pdf) 132 | - We showed how advanced programming paradigms can be implemented on top of it (in this case, Feature Oriented Programming) at GPCE'15: [*Lightweight, Generative Variant Exploration for High-Performance Graphics Applications*](https://selgrad.org/publications/2015_gpce_SLKSL.pdf) 133 | - At ELS'16 we showcased its proformance for implementing comptetitive DSLs: [*A High-Performance Image Processing DSL for Heterogeneous Architectures*](https://selgrad.org/publications/2016_els_SLDRS.pdf) 134 | - as well as for exploring implementation variants: [*A Case Study in Implementation-Space Exploration*](https://selgrad.org/publications/2016_els_LFSS.pdf) 135 | - We describe some of the techniques used in our implementation in our ELS'17 paper: [*DIY Meta Languages with Common Lisp*](https://selgrad.org/publications/2017_els_LSS.pdf) 136 | 137 | ### Examples 138 | In the following we show a few examples of how to use C-Mera. 139 | Note that we give also give it thorough treatment in [our first ELS paper](https://selgrad.org/publications/2014_els_SLWLS.pdf). 140 | 141 | #### Implementation of `strcmp(3)` 142 | This example illustrates the basic function definition syntax. It's a 143 | straightforward transcription of the example in the K&R book. 144 | 145 | (function strcmp ((char *p) (char *q)) -> int 146 | (decl ((int i = 0)) 147 | (for (() (== p[i] q[i]) i++) 148 | (if (== p[i] #\null) 149 | (return 0))) 150 | (return (- p[i] q[i])))) 151 | 152 | #### Implementation of `strcat(3)` 153 | Here we add arrays to the mix. 154 | It, too, is a straightforward transcription of the example in the K&R book. 155 | 156 | (function strcat ((char p[]) (char q[])) -> void 157 | (decl ((int i = 0) (int j = 0)) 158 | (while (!= p[i] #\null) 159 | i++) 160 | (while (!= (set p[i++] q[j++]) #\null)))) 161 | 162 | #### Implementation of `wc -l` 163 | This example shows a main function 164 | and how to forward-declare externally defined symbols originating from C libraries. 165 | There is also `use-functions` to explicitly declare externally defined functions. 166 | In most cases, these forms are not required. 167 | C-mera checks if the symbols used are already defined and interprets them as function calls otherwise. 168 | 169 | (include ) 170 | 171 | (function main () -> int 172 | (decl ((int c) 173 | (int nl = 0)) 174 | (while (!= (set c (getchar)) EOF) 175 | (if (== c #\newline) 176 | ++nl)) 177 | (printf "%d\\n" nl) 178 | (return 0))) 179 | 180 | #### Implementation of Shellsort 181 | Lots of loops: 182 | 183 | (function shellsort ((int *v) (int n)) -> void 184 | (decl ((int temp)) 185 | (for ((int gap = (/ n 2)) (> gap 0) (/= gap 2)) 186 | (for ((int i = gap) (< i n) i++) 187 | (for ((int j = (- i gap)) (&& (>= j 0) (> v[j] (aref v (+ j gap)))) (-= j gap)) 188 | (set temp v[j] 189 | v[j] (aref v (+ j gap)) 190 | (aref v (+ j gap)) temp)))))) 191 | 192 | ### Compilation Process 193 | Suppose the file `wc-l.lisp` contains the code of the line counting example shown above. 194 | Here is a cmdline session: 195 | 196 | $ ls 197 | wc-l.lisp 198 | $ cm c wc-l.lisp 199 | #include 200 | 201 | int main(void) 202 | { 203 | int c; 204 | int nl = 0; 205 | while ((c = getchar()) != EOF) { 206 | if (c == '\n') 207 | ++nl; 208 | } 209 | printf("%d\n", nl); 210 | } 211 | $ cm c wc-l.lisp -o wc-l.c 212 | $ ls 213 | wc-l.c wc-l.lisp 214 | $ gcc -std=c99 wc-l.c -o wc-l 215 | 216 | 217 | ## Programming Guide 218 | 219 | This section describes how some aspects of the system work. 220 | We only describe what we believe may be noteworthy for either the seasoned Lisp or the seasoned C programmer. 221 | This part will be in motion as we add information that some of our users would have liked to have :) So please get back to us with your experience what might be helpful to mention. 222 | 223 | ### Changes from c-mera-2015 224 | For the old version see its branch. Here we only shortly list the major differences. 225 | 226 | - `decl` and `for` forms now require the use of `=` to distinguish the declarator from the initializer. Earlier we had elaborate guesses in place that worked most of the time, but not every time. 227 | - For C++ you can also use `(decl ((int v[] { 1 2 3 })) ...)` instead of `(decl ((int v[] = (clist 1 2 3))) ...)`. 228 | This change is required to be able to distinguish between regular initialization and initializer lists. The differences is easily illustrated by printing the values of the follwing vectors: 229 | 230 | ``` 231 | (typedef (instantiate #:std:vector (int)) T) 232 | (decl ((T vec1 = (T 10 20)) 233 | (T vec2 { 10 20 }))) 234 | ``` 235 | 236 | - You almost never have to use `use-variables` and `use-functions` anymore. 237 | 238 | ### Simple Syntax 239 | 240 | #### Conditionals 241 | 242 | `if` statements have exactly two or three subforms. The third subform represents the `else` part and is optional. Thus, the following example is not correct: 243 | 244 | (if (!= a 0) 245 | (printf "all is safe") 246 | (return (/ b a))) 247 | 248 | You can use `progn` to group multiple sub-forms 249 | 250 | (if (!= a 0) 251 | (progn 252 | (printf "all is safe") 253 | (return (/ b a)))) 254 | 255 | or, equivalently, `when` 256 | 257 | (when (!= a 0) 258 | (printf "all is safe") 259 | (return (/ b a))) 260 | 261 | which expands to the previous form using `progn`, which, in turn, expands to: 262 | 263 | if (a != 0) { 264 | ... 265 | } 266 | 267 | In contrast, the first example expands to 268 | 269 | if (a != 0) { 270 | printf(...); 271 | else 272 | return ...; 273 | 274 | We also support `cond`. 275 | 276 | ##### Open Issues 277 | We currently don't have `unless`. 278 | 279 | 280 | #### Loops 281 | A for loop is written with the loop-head grouped: 282 | 283 | (for ((int i = 0) (< i n) (+= i 1)) 284 | ...) 285 | 286 | Note that C-Mera supports C-like increments and decrements for simple expressions: 287 | 288 | (for ((int i = 0) (< i n) ++i) 289 | ...) 290 | 291 | `while` is straighforward 292 | 293 | (while (< a b) 294 | ... 295 | ...) 296 | 297 | ##### Open Issues 298 | `do-while` is not implemented at the moment. 299 | 300 | 301 | #### Declarations 302 | A set of declarations is introduced with 303 | 304 | (decl ((T name [= init]) 305 | ...) 306 | ...) 307 | 308 | or (for C++ based languages) 309 | 310 | (decl ((T name [{ init }]) 311 | ...) 312 | ...) 313 | 314 | the initializer is optional and C-Mera collects as many symbols to be part of the type as possible, 315 | e.g. 316 | 317 | (decl ((const unsigned long int x = 0)) ...) 318 | 319 | is correctly identified. 320 | 321 | As mentioned above, typenames are not checked. 322 | 323 | In declarations (such as `decl`, in function parameters and `(sizeof ...)`) the type does not have to 324 | be enclosed in parens (and must not be). There are places, however, 325 | where for the sake of simplicity type names must be grouped, as e.g. in function return values: 326 | 327 | (function foo ((const int *i) ...) -> (unsigned int) 328 | ...) 329 | 330 | As shown in this example C-Mera also supports some C-style decorations, i.e. 331 | 332 | (decl ((int *i 0)) ...) 333 | (decl ((int* i 0)) ...) 334 | 335 | are both recognized. 336 | 337 | 338 | ### Namespace (Lisp vs C-Mera) 339 | Some C-Mera symbols are also defined in Common Lisp. 340 | Initially, C-Mera starts out in the `cmu-` (user package, depending on the code generator used, e.g. `cmu-c`) which imports 341 | all `cl` symbols that do not conflict to provide metaprogramming as seamlessly as possible. 342 | 343 | Especially with symbols like `if` etc care has to be taken to use the right one. 344 | This can be done by explicitly naming the symbol `cl:if`, but to define lisp functions 345 | or lisp-heavy parts of the meta code it is often more convenient to use the `lisp` form, such as 346 | in the example from our ELS'14 presentation: 347 | 348 | (defmacro match (expression &rest clauses) 349 | `(macrolet 350 | ((match-int (expression &rest clauses) 351 | `(progn 352 | (set reg_err 353 | (regcomp ® ,(caar clauses) REG_EXTENDED)) 354 | (if (regexec ® ,expression 0 0 0) 355 | (progn ,@(cdar clauses)) 356 | ,(lisp (if (cdr clauses) 357 | `(match-int 358 | ,expression 359 | ,@(cdr clauses)))))))) 360 | (decl ((regex_t reg) 361 | (int reg_err)) 362 | (match-int ,expression ,@clauses)))) 363 | 364 | Here we define a recursively expanding macrolet, `match-int`, that inserts conditional clauses (as in `(if (regexec ....))` and also checks to terminate the iteration (with `,(lisp (if ...))`). 365 | 366 | ### Codestrings 367 | tbd. 368 | 369 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiselgra/c-mera/97701e850247fa39d79d36c4f302fbb6a116fb5c/TODO -------------------------------------------------------------------------------- /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-slate -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # Process this file with autoconf to produce a configure script. 2 | AC_INIT([c-mera],[1.0.1]) 3 | AM_INIT_AUTOMAKE 4 | 5 | AC_CONFIG_MACRO_DIR([m4]) 6 | 7 | AC_CONFIG_SRCDIR([c-mera.asd]) 8 | AC_CONFIG_HEADERS([config.h]) 9 | AC_CONFIG_FILES(Makefile 10 | util/build/dump-c.lisp util/build/dump-cuda.lisp util/build/dump-cxx.lisp 11 | util/build/dump-glsl.lisp util/build/dump-opencl.lisp) 12 | 13 | AC_PROG_CC 14 | 15 | 16 | ## 17 | ## find a compatible lisp. 18 | ## we are currently quite focused on sbcl. 19 | ## 20 | AC_ARG_WITH([ccl], 21 | [AS_HELP_STRING([--with-ccl], [Use clozure lisp as generator.])], 22 | LISP_PROG="ccl") 23 | 24 | AC_ARG_WITH([sbcl], 25 | [AS_HELP_STRING([--with-sbcl], [Use sbcl as generator.])], 26 | LISP_PROG="sbcl") 27 | 28 | if test "x$LISP_PROG" == "sbcl" ; then 29 | AC_CHECK_PROGS(LISP_PROG, [sbcl], no) 30 | elif test "x$LISP_PROG" == "ccl" ; then 31 | AC_CHECK_PROGS(LISP_PROG, [ccl], no) 32 | else 33 | AC_CHECK_PROGS(LISP_PROG, [ccl sbcl lisp], no) 34 | fi 35 | 36 | 37 | LISP_LOAD_ARG= 38 | if test "x$LISP_PROG" == "xno" ; then 39 | AC_MSG_ERROR([Cannot find any suitable lisp.]) ; 40 | elif test "x$LISP_PROG" == "xccl" ; then 41 | LISP_LOAD_ARG="-l" ; 42 | elif test "x$LISP_PROG" == "xsbcl" ; then 43 | LISP_LOAD_ARG="--script" 44 | fi 45 | AC_SUBST([LISP_PROG]) 46 | AC_SUBST([LISP_LOAD_ARG]) 47 | 48 | VER_MAJ=`echo $VERSION|sed -e 's/\(.\+\)\.\(.\+\)\.\(.\+\)/\1/'` 49 | VER_MIN=`echo $VERSION|sed -e 's/\(.\+\)\.\(.\+\)\.\(.\+\)/\2/'` 50 | VER_PAT=`echo $VERSION|sed -e 's/\(.\+\)\.\(.\+\)\.\(.\+\)/\3/'` 51 | AC_SUBST([VER_MAJ]) 52 | AC_SUBST([VER_MIN]) 53 | AC_SUBST([VER_PAT]) 54 | 55 | ## 56 | ## provide a means to compile programs with larger memory areas. 57 | ## 58 | AC_ARG_WITH([dynamic-space-size], 59 | [AS_HELP_STRING([--with-dynamic-space-size=MB], 60 | [Set other than default dynamic heap size. Only implemented for sbcl at the moment.])], 61 | dynamic_space_size_request=$withval, dynamic_space_size_request="no") 62 | DYNAMIC_SPACE_SPEC= 63 | if test "x$LISP_PROG" == "xsbcl" -a ! "x$dynamic_space_size_request" == "xno"; then 64 | DYNAMIC_SPACE_SPEC="--dynamic-space-size 16384" 65 | fi 66 | AC_SUBST([DYNAMIC_SPACE_SPEC]) 67 | 68 | 69 | 70 | AC_OUTPUT 71 | -------------------------------------------------------------------------------- /roswell/cm.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #|C-Mera generator 4 | exec ros -Q -L sbcl-bin -m c-mera -- $0 "$@" 5 | |# 6 | (progn ;;init forms 7 | (ros:ensure-asdf) 8 | #+quicklisp(ql:quickload '(:c-mera 9 | :cm-c 10 | :cmu-c 11 | :cm-c++ 12 | :cmu-c++ 13 | :cms-c++ 14 | :cms-cuda 15 | :cms-glsl 16 | :cms-opencl) 17 | :silent t)) 18 | 19 | (defpackage :ros.script.cm.3700387292 20 | (:use :cl)) 21 | (in-package :ros.script.cm.3700387292) 22 | 23 | (defvar *supported* '("c" "c++" "cxx" "glsl" "ocl" "opencl" "cuda")) 24 | (defvar *abbrev* '(("cxx" . "c++") ("ocl" . "opencl"))) 25 | (defvar *processor* '(("c++" . "cxx"))) 26 | 27 | (defun main (&rest argv) 28 | (let ((gen "c") 29 | version help (cmd (pathname-name *load-pathname*))) 30 | (when (and (> (length cmd) 3) 31 | (string-equal "cm-" cmd :end2 3)) 32 | (push (subseq cmd 3) argv)) 33 | (cond ((zerop (length argv)) 34 | (format 35 | t "~{~A~%~}" 36 | `("C-Mera generator selection frontend." 37 | ,(format nil "Please specify generator type as~{ ~A~^,~} or use --help." *supported*) 38 | "Generator abbreviations are ok and checked in the order given above.")) 39 | (ros:quit 1)) 40 | ((find (first argv) *supported* :test 'equal) 41 | (setf gen (or (cdr (assoc (first argv) *abbrev* :test 'equal)) 42 | (first argv)))) 43 | ((find (first argv) '("--version" "-V") :test 'equal) 44 | (setf version t)) 45 | (t (setf help t))) 46 | (let ((*package* (find-package (read-from-string (format nil ":cmu-~A" gen)))) 47 | (processor-name (or (cdr (assoc gen *processor* :test #'equal)) 48 | gen))) 49 | (setf (readtable-case *readtable*) :invert) 50 | (funcall (read-from-string (format nil "cm-~A::~A-processor" gen processor-name)) 51 | (cond 52 | (version '("--version")) 53 | (help '("--help")) 54 | (t (rest argv))))))) 55 | ;;; vim: set ft=lisp lisp: 56 | -------------------------------------------------------------------------------- /src/c-mera/c-mera.lisp: -------------------------------------------------------------------------------- 1 | (in-package :c-mera) 2 | 3 | (defmacro define-reader (&key file-reader string-reader macro-character) 4 | `(progn 5 | (defun ,file-reader (file &key (debug nil)) 6 | "Read c-mera source file and return AST" 7 | (let ((asts nil) 8 | (*readtable* (copy-readtable nil))) 9 | ;; Preserve case, and parse convenient stuff 10 | (setf (readtable-case *readtable*) :invert) 11 | ,@macro-character 12 | ;(handler-case 13 | (with-open-file (in file) 14 | (loop for s-expr = (read in nil nil nil) while s-expr do ;; TODO CHECK call 15 | (let* ((s-expr (eval s-expr)) 16 | (evaluated (if (listp s-expr) 17 | s-expr 18 | (list s-expr)))) 19 | (when (typep (car evaluated) 'node) 20 | (setf asts (append asts evaluated)))))) 21 | 22 | ;; TODO 23 | ;; Standard clozure error handling breaks console. 24 | ;; This hanlder-case is only a tentative fix 25 | ;#+clozure (error (err) (let ((*print-pretty* t)) 26 | ; (format *error-output* "~a" err)))) 27 | ;; Return single AST 28 | (nodelist asts))) 29 | (defun ,string-reader (str) 30 | "Rread c-mera source string and return AST" 31 | (let ((asts nil) 32 | (*readtable* (copy-readtable nil))) 33 | ;; Preserve case, and parse convenient stuff 34 | (setf (readtable-case *readtable*) :invert) 35 | ,@macro-character 36 | ;(handler-case 37 | (let* ((s-expr (eval (read-from-string str))) 38 | (evaluated (if (listp s-expr) 39 | s-expr 40 | (list s-expr)))) 41 | (when (typep (car evaluated) 'node) 42 | (setf asts evaluated))) 43 | 44 | ;; TODO 45 | ;; Standard clozure error handling breaks console. 46 | ;; This hanlder-case is only a tentative fix 47 | ;#+clozure (error (err) (let ((*print-pretty* t)) 48 | ; (format *error-output* "~a" err)))) 49 | ;; Return single AST 50 | (nodelist asts))))) 51 | 52 | 53 | 54 | ;;; Defines the start-up command of the lisp-executable. 55 | (defmacro define-processor (&key name file-reader string-reader extra-traverser) 56 | (let ((extras (loop for i in extra-traverser collect 57 | `(traverser (make-instance ',i) tree 0)))) 58 | `(defun ,name (args) 59 | (multiple-value-bind (input output debug) (parse-cmdline args ,string-reader) 60 | (when input 61 | (let ((tree nil) 62 | (pprint (make-instance 'pretty-printer))) 63 | (setf tree (,file-reader input)) 64 | ,@extras 65 | (if output 66 | (with-open-file 67 | (stream output :direction :output 68 | :if-exists :supersede 69 | :if-does-not-exist :create) 70 | (setf (slot-value pprint 'stream) stream) 71 | (traverser pprint tree 0)) 72 | (progn 73 | (setf (slot-value pprint 'stream) *standard-output*) 74 | (traverser pprint tree 0) 75 | (format t "~&"))) 76 | )))))) 77 | 78 | ;;; Used to build the executables. 79 | (defmacro save-generator (&key name start-function in-package) 80 | `(defun ,name (name) 81 | (labels ((dump-start () 82 | (in-package ,in-package) 83 | (setf (readtable-case *readtable*) :invert) 84 | #+sbcl (,start-function sb-ext:*posix-argv*) 85 | #+clozure (handler-case 86 | (,start-function ccl::*command-line-argument-list*) 87 | (error (err) (let ((*print-pretty* t)) 88 | (format *error-output* "~a" err) 89 | (ccl::quit 1)))) 90 | #+ecl (,start-function (loop for i from 0 below (si:argc) collect (si:argv i))) 91 | #-(or sbcl clozure ecl) 92 | (error "Missing implementation of 'save-generator' for your lisp implementation") 93 | )) 94 | (net.didierverna.clon:dump name dump-start)))) 95 | 96 | 97 | ;;; debug stuff 98 | (defun print! (tree) 99 | (let ((pp (make-instance 'pretty-printer)) 100 | (d (make-instance 'debug-traverser))) 101 | (traverser d tree 0) 102 | (traverser pp tree 0))) 103 | 104 | (defparameter *c-mera-reader* 'cm) 105 | (defvar *readtable-backup* (copy-readtable nil)) 106 | 107 | (defmacro define-switch (&key name macro-character) 108 | "Define a c-mera reader switch (in repl) 109 | allowing preprocessing and mixed case" 110 | `(defun ,name (&key (debug nil)) 111 | (cond ((eql *c-mera-reader* 'cl) 112 | (setf *c-mera-reader* 'cm) 113 | ;; TODO when debug 114 | ,@macro-character 115 | (setf (readtable-case *readtable*) :invert)) 116 | ((eql *c-mera-reader* 'cm) 117 | (setf *c-mera-reader* 'cl) 118 | (setf *readtable* *readtable-backup*)) 119 | (t (error "Unknown c-mera reader status: ~a" *c-mera-reader*))))) 120 | 121 | (defmacro define-switches (&key cl-reader cm-reader macro-character) 122 | "Define c-mera/common-lisp reader switches" 123 | `(progn 124 | (defun ,cl-reader () 125 | (setf *c-mera-reader* 'cl) 126 | (setf *readtable* *readtable-backup*)) 127 | (defun ,cm-reader () 128 | (setf *c-mera-reader* 'cm) 129 | ,@macro-character 130 | (setf (readtable-case *readtable*) :invert)))) 131 | -------------------------------------------------------------------------------- /src/c-mera/cmd.lisp: -------------------------------------------------------------------------------- 1 | (in-package :c-mera) 2 | (defpackage :cm-cmdline) 3 | 4 | (defun add-cmdline-definition (str) 5 | (let* ((=pos (position #\= str)) 6 | (white '(#\space #\newline #\tab)) 7 | (key str) 8 | val) 9 | (when =pos 10 | (setf key (subseq str 0 =pos)) 11 | (setf val (string-trim white (subseq str (1+ =pos))))) 12 | (setf key (string-trim white key)) 13 | (let ((symbol (cintern (format nil "~a" key) :cm-cmdline))) 14 | (eval `(defparameter ,symbol ,val)) 15 | (export symbol :cm-cmdline)))) 16 | 17 | (defmacro synopsis (&body syn) 18 | "Forwards all arguments to CLON:DEFSYNOPSIS. 19 | Also analyzes the list of statements to find options with and w/o arguments. 20 | This data is then used for cmdline-reordering via CLON-SHUFFLE to provide a more flexible notation." 21 | (let (flags-short flags-long opts-short opts-long) 22 | (flet ((short (list) 23 | (aref (cadr (member :short-name list)) 0)) 24 | (long (list) 25 | (cadr (member :long-name list)))) 26 | (loop for x in syn 27 | do (progn 28 | (when (find (first x) (list 'flag)) 29 | (let ((s (short x)) 30 | (l (long x))) 31 | (if s (push s flags-short)) 32 | (if l (push l flags-long)))) 33 | (when (find (first x) (list 'stropt)) 34 | (let ((s (short x)) 35 | (l (long x))) 36 | (if s (push s opts-short)) 37 | (if l (push l opts-long)))))) 38 | `(progn 39 | (defparameter *clon-shuffle-flags* (list ,@flags-short)) 40 | (defparameter *clon-shuffle-opts* (list ,@opts-short)) 41 | (defparameter *clon-shuffle-flags-long* (list ,@flags-long)) 42 | (defparameter *clon-shuffle-opts-long* (list ,@opts-long)) 43 | (net.didierverna.clon:defsynopsis 44 | ,@syn))))) 45 | 46 | (synopsis 47 | (:postfix "inputfile") 48 | (text :contents "A source-to-source compiler.") 49 | (flag :short-name "h" :long-name "help" :description "Print this help and exit.") 50 | (flag :short-name "V" :long-name "version" :description "Print c-mera version and exit.") 51 | (stropt :short-name "i" :long-name "in" :description "Input file name (can also be given as non-option argument).") 52 | (stropt :short-name "o" :long-name "out" :description "Output file name (if not specified we print to stdout).") 53 | (stropt :short-name "D" :long-name "defparameter" 54 | :description "Define given value as parameter as string. -Dfoo=9 will have the effect of (defparameter *foo* \"9\").") 55 | (stropt :short-name "E" :long-name "eval" ; I would really like to *not* have a short option for this, but it seems that clon does not work without a short-option name. 56 | :description "Evaluate the given form before reading the input file.") 57 | (flag :short-name "g" :long-name "debug" :description "Add debugging information such as line numbers in the output.") 58 | (flag :short-name "v" :long-name "verbose" :description "Be verbose.") 59 | (stropt :short-name "W" :long-name "warn" :description "Enable warnings: currently only 'hyphen'")) 60 | 61 | (defun clon-shuffle (input) 62 | "Make C-Mera's cmdline handling more conform to GNU standards by allowing non-option arguments to be interspersed with options. 63 | *CLON-SHUFFLE-FLAGS are options that do not take parameters, 64 | *CLON-SHUFFLE-OPTS are options that take parameters. 65 | Knowing this the order of the arguments can be changed safely." 66 | (let (opts 67 | args 68 | (expecting-arg nil)) 69 | (loop while input 70 | do (let ((arg (first input))) 71 | (cond 72 | ;; when expecting an argument the value has to be pushed to the option list, regardless of form 73 | (expecting-arg 74 | (setf expecting-arg nil) 75 | (push arg opts)) 76 | ;; the option terminator. push all remaining elements to the argument list 77 | ((string-equal arg "--") 78 | (loop for a in input do (push a args)) 79 | (setf input nil)) 80 | ;; a long option. if it takes an argument set appropriate state for when reading it. 81 | ((and (> (length arg) 2) (char= (aref arg 0) #\-) (char= (aref arg 1) #\-)) 82 | (when (find (subseq arg 2) *clon-shuffle-opts-long* :test #'string-equal) 83 | (setf expecting-arg t)) 84 | (push arg opts)) 85 | ;; a (series of) short option(s). ditto. 86 | ((and (> (length arg) 1) (char= (aref arg 0) #\-)) 87 | (loop for c across (subseq arg 1) 88 | do (if (find c *clon-shuffle-opts*) 89 | (setf expecting-arg t))) 90 | (push arg opts)) 91 | ;; anything else is a non-option argument 92 | (t 93 | (push arg args))) 94 | (if input (setf input (rest input))))) 95 | (append (reverse opts) (reverse args)))) 96 | 97 | (defmacro parse-cmdline (cmdline reader) 98 | `(let ((cmdline ,cmdline)) 99 | (block break-parse 100 | (net.didierverna.clon:make-context :cmdline (cons (first cmdline) (clon-shuffle (rest cmdline)))) 101 | (flet ((s= (a b c) (or (string-equal a b) (string-equal a c)))) 102 | (let ((in (net.didierverna.clon:getopt :short-name "i")) 103 | (out (net.didierverna.clon:getopt :short-name "o")) 104 | (debug (net.didierverna.clon:getopt :short-name "g")) 105 | (verb (net.didierverna.clon:getopt :short-name "v")) 106 | (args (net.didierverna.clon:remainder))) 107 | (declare (ignore verb)) 108 | (if in (push in args)) 109 | (net.didierverna.clon:do-cmdline-options (option name value source) 110 | (cond ((s= name "h" "help") 111 | (net.didierverna.clon:help) 112 | (return-from break-parse (values nil nil nil))) 113 | ((s= name "V" "version") 114 | (print-version) 115 | (return-from break-parse (values nil nil nil))) 116 | ((s= name "D" "defparameter") 117 | (add-cmdline-definition value)) 118 | ((s= name "E" "eval") 119 | (,reader value)) 120 | ((s= name "W" "warn") 121 | (if (string-equal value "no" :end1 2) 122 | (push (intern (string-upcase value) :keyword) *suppressed-warnings*) 123 | (push (intern (string-upcase value) :keyword) *enabled-warnings*))) 124 | (t (format t "Unnrecognized option ~a.~%" name)))) 125 | (cond ((> (length args) 1) 126 | (setf in nil) 127 | (net.didierverna.clon:help) 128 | (format t "Excess command line arguments.~%")) 129 | ((= (length args) 0) 130 | (setf in nil) 131 | (net.didierverna.clon:help) 132 | (format t "No input specified.~%")) 133 | (t (setf in (first args)))) 134 | (values in out debug)))))) 135 | -------------------------------------------------------------------------------- /src/c-mera/nodes.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Definitions of the most general node types 2 | (in-package :c-mera) 3 | 4 | ;;; Node utils 5 | (defmacro defclass# (name superclass-list slot-list &key export) 6 | "Class definition with slot initialisation :initarg :" 7 | (let ((slots (loop for slot in slot-list collect 8 | `(,slot :initarg ,(intern (symbol-name slot) :keyword))))) 9 | `(progn 10 | ,(when export `(export '(,name ,@slot-list))) 11 | (defclass ,name ,superclass-list ,slots)))) 12 | 13 | (defmacro make-instance# (name values subnodes) 14 | "Prepare make- macro for class instantiation" 15 | `(defmacro ,(intern (format nil "~:@(~a~)" name)) (,@values ,@subnodes) 16 | (list 'make-instance '',name 17 | ,@(loop for i in values append `(,(intern (symbol-name i) :keyword) ,i)) 18 | ,@(loop for i in subnodes append `(,(intern (symbol-name i) :keyword) ,i)) 19 | :values '',values 20 | :subnodes '',subnodes))) 21 | 22 | (defmacro defnode (name values subnodes) 23 | "Define node derived form node" 24 | `(progn 25 | (defclass# ,name (node) ,(append values subnodes) :export t) 26 | (make-instance# ,name ,values ,subnodes))) 27 | 28 | (defmacro defproxy (name) 29 | "Define node derived from proxy" 30 | `(progn 31 | (defclass# ,name (proxy) (values subnodes parent)) 32 | (make-instance# ,name () ()))) 33 | 34 | (defmacro defleaf (name values) 35 | "Define node derived from leaf" 36 | `(progn 37 | (defclass# ,name (leaf) ,values :export t) 38 | (make-instance# ,name ,values ()))) 39 | 40 | (defmacro defstatement (name values subnodes) 41 | "Define node derived from statement" 42 | `(progn 43 | (defclass# ,name (statement) ,(append values subnodes) :export t) 44 | (make-instance# ,name ,values ,subnodes))) 45 | 46 | (defmacro defexpression (name values subnodes) 47 | "Define node derived from expression" 48 | `(progn 49 | (defclass# ,name (expression) ,(append values subnodes) :export t) 50 | (make-instance# ,name ,values ,subnodes))) 51 | 52 | ;;; Symbols in 'subnodes' describe slots that contain nodes. 53 | ;;; Slots with only atoms are listed in 'values'. 54 | ;;; This distinction is used by the traverser. 55 | (defclass# node () (values subnodes)) 56 | (defclass# expression (node) ()) 57 | (defclass# statement (node) ()) 58 | (defclass# leaf (node) ()) 59 | 60 | ;;; Node with source location information. 61 | (defnode source-position (line file) (subnode)) 62 | 63 | ;;; Proxy nodes 64 | ;;; Temporary usage in traversers 65 | (defnode proxy (info) (proxy-subnode)) 66 | 67 | ;;; The one and only node type that contains a list of nodes. 68 | (defnode nodelist () (nodes)) 69 | 70 | ;; Defined in root c-mera for quoty 71 | (defnode function-call () (function arguments)) 72 | 73 | ;;; Leaf nodes 74 | (defleaf identifier (identifier)) 75 | (defleaf number-literal (number)) 76 | (defleaf string-literal (string)) 77 | (defleaf character-literal (character)) 78 | (defleaf empty ()) 79 | 80 | -------------------------------------------------------------------------------- /src/c-mera/pretty.lisp: -------------------------------------------------------------------------------- 1 | (in-package :c-mera) 2 | 3 | ;;; Pretty printing of leaf nodes: 4 | ;;; strings, chars, nums, identifiers 5 | (with-pp 6 | (defprettymethod :self leaf 7 | (loop for i in values do 8 | (let ((val (slot-value item i))) 9 | (when val 10 | (cond 11 | ((stringp val) 12 | (format stream "\"~a\"" val)) 13 | ((characterp val) 14 | (cond 15 | ((eql val #\tab) 16 | (format stream "'\\t'")) 17 | ((or (eql val #\nul) (eql val #\null)) 18 | (format stream "'\\0'")) 19 | ((eql val #\return) 20 | (format stream "'\\r'")) 21 | ((eql val #\newline) 22 | (format stream "'\\n'")) 23 | ((eql val #\') 24 | (format stream "'\\''")) 25 | (t (format stream "'~a'" val)))) 26 | ((floatp val) (format stream "~a" 27 | (substitute #\e #\d 28 | (format nil "~,8e" val)))) 29 | (t (format stream "~a" val))) 30 | ))))) 31 | -------------------------------------------------------------------------------- /src/c-mera/traverser.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Common traverser functions for pretty printing and other tasks. 2 | 3 | (in-package :c-mera) 4 | 5 | ;;; This is the common core of all traversal functions for the c-mera-ast. 6 | (defgeneric traverser (traverser node level)) 7 | 8 | (defparameter *indent* #\tab) 9 | (defun set-indent-char (x) 10 | (setf *indent* x)) 11 | 12 | ;;; Simply start the traversal for all subnodes. 13 | (defmethod traverser ((travers t) (item node) level) 14 | (with-slots (subnodes) item 15 | (loop for i in subnodes do 16 | (let ((subnode (slot-value item i))) 17 | (if subnode 18 | (traverser travers subnode (+ 1 level))))))) 19 | 20 | ;;; For nodelists this method ist used to start the traversal 21 | ;;; for subnodes in lists. 22 | (defmethod traverser ((travers t) (item nodelist) level) 23 | (with-slots (nodes) item 24 | (mapcar #'(lambda (x) (traverser travers x level)) nodes))) 25 | 26 | (defmethod traverser ((travers t) (item t) level) 27 | (declare (ignore level))) 28 | 29 | ;;; Inserts a single proxy-node in the AST. 30 | (defmacro make-proxy (slot node-type &key (node-name 'item) (parent 'item)) 31 | "Add proxy nodes to slot. Note: all uses in c-mera and cm-c implicitly assue that the node is called ITEM." 32 | (let ((val (gensym))) 33 | `(if (or (eql (find-class 'nodelist) (class-of (slot-value ,node-name ',slot)))) 34 | (let ((,val (slot-value (slot-value ,node-name ',slot) 'nodes))) 35 | (setf (slot-value (slot-value ,node-name ',slot) 'nodes) 36 | (loop for i in ,val collect 37 | (make-instance ,node-type 38 | :parent ,parent 39 | :proxy-subnode i 40 | :values '() 41 | :subnodes '(proxy-subnode))))) 42 | (let ((,val (slot-value ,node-name ',slot))) 43 | (if ,val 44 | (setf (slot-value ,node-name ',slot) 45 | (make-instance ,node-type 46 | :parent ,parent 47 | :proxy-subnode ,val 48 | :values '() 49 | :subnodes '(proxy-subnode))) 50 | (setf (slot-value ,node-name ',slot) 51 | (make-instance ,node-type 52 | :parent ,parent 53 | :proxy-subnode nil 54 | :values '() 55 | :subnodes '(proxy-subnode)))))))) 56 | 57 | ;;; Deletes a single proxy-node from the AST. 58 | (defmacro del-proxy (slot &key (node-name 'item)) 59 | "Remove proxy-node in slot" 60 | (let ((val (gensym)) (node-list (gensym))) 61 | `(let ((,val (slot-value ,node-name ',slot))) 62 | (if (eql (find-class 'nodelist) (class-of (slot-value ,node-name ',slot))) 63 | (let ((,node-list (slot-value (slot-value ,node-name ',slot) 'nodes))) 64 | (setf (slot-value (slot-value ,node-name ',slot) 'nodes) 65 | (loop for i in ,node-list collect 66 | (slot-value i 'proxy-subnode)))) 67 | (if ,val (setf (slot-value ,node-name ',slot) 68 | (slot-value ,val 'proxy-subnode))))))) 69 | 70 | ;;; Defines proxy nodes for local usage. 71 | ;;; These nodes can be used with 'add-proxy', 'del-proxy', 72 | ;;; 'defproxyprint', and 'defproxymetod'. 73 | ;;; Use proxy nodes directly and without quotation. 74 | (defmacro with-proxynodes (proxy-nodes &body body) 75 | "define proxy nodes for local usage" 76 | (if (not (listp proxy-nodes)) 77 | (setf proxy-nodes (list proxy-nodes))) 78 | (if proxy-nodes 79 | (let ((tmp (gensym (format nil "~:@(proxy-~a-~)" (first proxy-nodes))))) 80 | ;(format t "Symbol:: ~s" tmp) 81 | (setf (gethash (first proxy-nodes) *proxy-node*) tmp) 82 | ;;for debug/swank, else comment out 83 | ;;(eval `(defnode ,tmp (proxy) ())) 84 | ;; 85 | `(let ((,(first proxy-nodes) ',tmp)) 86 | 87 | ;(defnode ,tmp (proxy) ()) 88 | (defproxy ,tmp) 89 | 90 | (with-proxynodes ,(rest proxy-nodes) ,@body))) 91 | `(progn ,@body))) 92 | 93 | ;;; Local proxy nodes can only be used for method definition 94 | ;;; with this workaround. Direct usage in 'defmethod' will not work. 95 | (defmacro defproxymethod (qualifier class proxy-node &body body) 96 | "define a method for a proxy node" 97 | (if (eql :self qualifier) 98 | `(progn 99 | (setf (gethash (find-class ',(gethash proxy-node *proxy-node*)) 100 | *ignore-node*) t) 101 | (defmethod traverser 102 | (,class 103 | (item ,(gethash proxy-node *proxy-node*)) level) 104 | (declare (ignorable level)) 105 | (with-slots (values subnodes parent) item ,@body) 106 | (call-next-method))) 107 | `(defmethod traverser ,qualifier 108 | (,class 109 | (item ,(gethash proxy-node *proxy-node*)) level) 110 | (declare (ignorable level)) 111 | (with-slots (values subnodes parent) item ,@body)))) 112 | 113 | 114 | (defmacro defproxyprint (qualifier node &body body) 115 | "define a pretty-print method for a proxy node" 116 | `(defproxymethod ,qualifier (pp pretty-printer) ,node ,@body)) 117 | 118 | ;;; Extension for the traverser for pretty printing 119 | (defclass pretty-printer () 120 | ((indent :initform 0) 121 | (sign-stack :initform nil) 122 | (info-stack :initform nil) 123 | (stream :initform t :initarg :stream))) 124 | 125 | (defgeneric get-indent-generic (pretty-printer)) 126 | (defgeneric inc-indent-generic (pretty-printer)) 127 | (defgeneric dec-indent-generic (pretty-printer)) 128 | (defgeneric get-stream-generic (pretty-printer)) 129 | (defgeneric set-stream-generic (pretty-printer)) 130 | (defgeneric push-sign-generic (pretty-printer sign)) 131 | (defgeneric top-sign-generic (pretty-printer)) 132 | (defgeneric pop-sign-generic (pretty-printer)) 133 | (defgeneric push-info-generic (pretty-printer info)) 134 | (defgeneric top-info-generic (pretty-printer)) 135 | (defgeneric pop-info-generic (pretty-printer)) 136 | (defgeneric find-info-generic (pretty-printer info)) 137 | (defgeneric find-sign-generic (pretty-printer sign)) 138 | 139 | (defmacro defpretty-helper (name class args slots &body body) 140 | (if args 141 | `(defmethod ,name ((item ,class) .,args ) 142 | (with-slots ,slots item 143 | .,body)) 144 | `(defmethod ,name ((item ,class)) 145 | (with-slots ,slots item 146 | .,body)))) 147 | 148 | (defpretty-helper get-indent-generic pretty-printer nil (pre-indent indent) 149 | "return witespace string" 150 | (let ((x nil)) 151 | (loop for i from 1 to indent do 152 | (push *indent* x)) 153 | (coerce x 'string))) 154 | 155 | (defpretty-helper inc-indent-generic pretty-printer nil (indent) 156 | "incement pretty-printer indent" 157 | (incf indent)) 158 | 159 | (defpretty-helper dec-indent-generic pretty-printer nil (indent) 160 | "decrement pretty-printer indent" 161 | (decf indent)) 162 | 163 | (defpretty-helper get-stream-generic pretty-printer nil (stream) 164 | "get stream direction" 165 | stream) 166 | 167 | (defpretty-helper push-sign-generic pretty-printer (sign) (sign-stack) 168 | "put signs on stack" 169 | (push sign sign-stack 170 | )) 171 | 172 | (defpretty-helper pop-sign-generic pretty-printer nil (sign-stack) 173 | "delete (pop) sign from sign-stack" 174 | (pop sign-stack)) 175 | 176 | (defpretty-helper top-sign-generic pretty-printer nil (sign-stack) 177 | "get sign form sign-stack" 178 | (let ((ret (first sign-stack))) 179 | (if ret ret ""))) 180 | 181 | (defpretty-helper push-info-generic pretty-printer (info) (info-stack) 182 | "add info to info-stack" 183 | (push info info-stack)) 184 | 185 | (defpretty-helper pop-info-generic pretty-printer nil (info-stack) 186 | "remove top ifno from info-stack" 187 | (pop info-stack)) 188 | 189 | (defpretty-helper top-info-generic pretty-printer nil (info-stack) 190 | "get top info from info-stack" 191 | (first info-stack)) 192 | 193 | (defpretty-helper info-size-generic pretty-printer nil (info-stack) 194 | "get number of items in stack" 195 | (length info-stack)) 196 | 197 | (defpretty-helper find-info-generic pretty-printer (info) (info-stack) 198 | "find element in info stack" 199 | (find info info-stack)) 200 | 201 | (defpretty-helper find-sign-generic pretty-printer (sign) (sign-stack) 202 | "find sign in sign stack" 203 | (find sign sign-stack)) 204 | 205 | 206 | ;;; A definition macro used for the pretty printer. 207 | ;;; Adds the ":self" qualifier (besides :before :after) to override 208 | ;;; the standard node printing method (which simply prints all values). 209 | (defmacro defprettymethod (qualifier node &body body) 210 | (if (eql :self qualifier) 211 | `(progn (setf (gethash (find-class ',node) *ignore-node*) t) 212 | (defmethod traverser 213 | ((pp pretty-printer) 214 | (item ,node) level) 215 | (declare (ignorable level)) 216 | (with-slots (values subnodes) item .,body) 217 | (call-next-method))) 218 | `(defmethod traverser ,qualifier 219 | ((pp pretty-printer) 220 | (item ,node) level) 221 | (declare (ignorable level)) 222 | (with-slots (values subnodes) item .,body)))) 223 | 224 | ;;; Remove method 225 | (defmacro delprettymethod (qualifier node) 226 | (let ((quali (if (eql qualifier :self) 227 | '() 228 | `(,qualifier)))) 229 | `(remove-method #'traverser 230 | (find-method #'traverser 231 | ',quali 232 | (list 233 | ,(find-class 'pretty-printer) 234 | (find-class ',node) 235 | ,(find-class t)))))) 236 | 237 | 238 | 239 | ;;; Attempt to reduce write overhead. 240 | (defmacro with-pp (&body body) 241 | `(symbol-macrolet ((stream (get-stream-generic pp)) 242 | (indent (get-indent-generic pp)) 243 | (--indent (dec-indent-generic pp)) 244 | (++indent (inc-indent-generic pp))) 245 | (macrolet ((push-sign (x) `(push-sign-generic pp ,x)) 246 | (pop-sign () `(pop-sign-generic pp)) 247 | (top-sign () `(top-sign-generic pp)) 248 | (find-sign (x) `(find-sign-generic pp ,x)) 249 | (push-info (x) `(push-info-generic pp ,x)) 250 | (pop-info () `(pop-info-generic pp)) 251 | (top-info () `(top-info-generic pp)) 252 | (find-info (x) `(find-info-generic pp ,x)) 253 | (info-size () `(info-size-generic pp)) 254 | (node-slot (x) `(slot-value item ',x))) 255 | ,@body))) 256 | 257 | 258 | ;;; This traverser removes ambiguous nested nodelists. 259 | (defclass nodelist-traverser ()()) 260 | (defmethod traverser :before ((nt nodelist-traverser) (item nodelist) level) 261 | "remove unecessary nodelists, needed for correct if-block brackets" 262 | (declare (ignore level)) 263 | (with-slots (nodes) item 264 | (loop do 265 | (if (not (= (length nodes) 1)) 266 | (loop-finish) 267 | (cond ((eql (class-of (first nodes)) (find-class 'nodelist)) 268 | (setf nodes (slot-value nodes 'nodes))) 269 | ((eql (class-of (first nodes)) (find-class 'source-position)) 270 | (if (eql (class-of (slot-value (first nodes) 'subnode)) (find-class 'nodelist)) 271 | (setf nodes (slot-value (slot-value (first nodes) 'subnode) 'nodes)) 272 | (loop-finish))) 273 | (t (loop-finish))))))) 274 | 275 | ;;; Debug traverser 276 | ;;; Simply print all node types while traversing the tree. 277 | (defclass debug-traverser ()()) 278 | (defmethod traverser :before ((debug debug-traverser) (item t) level) 279 | (format t "~&~a~a~%" 280 | (eval `(concatenate 'string ,@(loop for i from 0 to level collect " "))) 281 | (class-name (class-of item)))) 282 | 283 | (defclass copy-traverser () 284 | ((stack :initform '()) 285 | (result :initform nil))) 286 | 287 | (defmethod traverser :before ((copy copy-traverser) (item node) level) 288 | (declare (ignore level)) 289 | (with-slots (stack) copy 290 | (push '() stack))) 291 | 292 | (defmethod traverser :after ((copy copy-traverser) (item node) level) 293 | (with-slots (stack result) copy 294 | (with-slots (values subnodes) item 295 | (let ((node-type (class-of item))) 296 | (let ((node-copy nil) 297 | (subnodes subnodes) ; changes can occur 298 | (subnode-copies (reverse (pop stack)))) 299 | (if (eq node-type (find-class 'nodelist)) 300 | (setf node-copy (make-instance 'nodelist 301 | :nodes subnode-copies 302 | :values '() 303 | :subnodes '(nodes))) 304 | (progn 305 | (setf node-copy (allocate-instance node-type)) 306 | (dolist (slot 307 | #+sbcl (mapcar #'sb-pcl::slot-definition-name (sb-pcl::class-slots node-type)) 308 | #+clozure (mapcar #'ccl::slot-definition-name (ccl::class-slots node-type)) 309 | #+ecl (mapcar #'slot-definition-name (class-slots node-type)) 310 | #-(or sbcl clozure ecl) 311 | (error "Copy traverser not implemented yet for your lisp implementaiton.") 312 | ) 313 | (when (slot-boundp item slot) 314 | (when (eq (slot-value item slot) nil) 315 | (setf subnodes (remove slot subnodes))) 316 | (let ((position (position slot subnodes))) 317 | (setf (slot-value node-copy slot) 318 | (if position 319 | (nth position subnode-copies) 320 | (slot-value item slot)))))))) 321 | (if (eq level 0) 322 | (setf result node-copy) 323 | (push node-copy (first stack)))))))) 324 | 325 | -------------------------------------------------------------------------------- /src/c-mera/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Utilities 2 | (in-package :c-mera) 3 | 4 | ;;; Inverts the case when interning a string. 5 | ;;; This is needed to keep the correct internal (inverted) case. 6 | ;;; Use this function for all c depending code. 7 | (defun cintern (name &optional package) 8 | (macrolet ((case-test (test string) 9 | `(reduce #'(lambda (a b) (and a b)) 10 | (mapcar (lambda(x) (or (not (both-case-p x)) (,test x))) 11 | (coerce ,string 'list))))) 12 | (let ((string (cond ((case-test upper-case-p name) (string-downcase name)) 13 | ((case-test lower-case-p name) (string-upcase name)) 14 | (t name)))) 15 | (if package 16 | (intern string package) 17 | (intern string))))) 18 | 19 | (defmacro defsyntax (tags packages lambda-list &body body) 20 | "Define syntax for tags from specific packages" 21 | (let ((tags (if (listp tags) tags (list tags)))) 22 | `(progn 23 | ,@(loop for i in tags append 24 | (loop for k in packages collect 25 | `(let ((tag ',i)) 26 | (declare (ignorable tag)) 27 | (defmacro ,(intern (format nil "~:@(~a~)" i) k) ,lambda-list 28 | ,@body) 29 | (export ',(intern (format nil "~:@(~a~)" i) k) ,k))))))) 30 | 31 | ;; check if function or macro is bound globally or lexically 32 | (defun fboundp! (function &optional env) 33 | "Check for globally of lexically bound function or macro" 34 | #+sbcl (sb-cltl2::function-information function env) 35 | #+clozure (ccl::function-information function env) 36 | #+ecl (or (fboundp function) 37 | (find function (rest env) 38 | :test #'(lambda (x y) (eql x (car y))))) 39 | #-(or sbcl clozure ecl) 40 | (error "Missing implementation of fboundp! for your lisp implementation.")) 41 | 42 | (defun vboundp! (variable &optional env) 43 | "Check for globally or lexically bound variables or symbol macros" 44 | #+sbcl (sb-cltl2::variable-information variable env) 45 | #+clozure (ccl::variable-information variable env) 46 | #+ecl (or (boundp variable) 47 | (find variable (first env) 48 | :test #'(lambda (x y) (eql x (car y))))) 49 | #-(or sbcl clozure ecl) 50 | (error "Missing implementation of vboundp! for your lisp implementation.")) 51 | 52 | ;;;; Quoty 53 | (defmacro quoty (item &environment env) 54 | "Quote undefined symbols, build functions from unknown lists" 55 | (cond ((eql item nil) 56 | (values)) 57 | ((listp item) 58 | (if (or (listp (first item)) 59 | (not (fboundp! (first item) env))) 60 | `(function-call 61 | (make-node ,(first item)) 62 | (make-nodelist ,(rest item))) 63 | item)) 64 | ((symbolp item) 65 | (if (vboundp! item env) 66 | item 67 | `',item)) 68 | (t item))) 69 | 70 | ;;; the list nodes 71 | (defmacro make-nodelist (items &key (prepend nil) (quoty nil)) 72 | "Build general or specific nodelist." 73 | (let ((prepend (if (listp prepend) prepend `(,prepend)))) 74 | `(nodelist 75 | (list ,@(loop for i in items collect 76 | (if prepend 77 | (if quoty 78 | `(,@prepend (quoty ,i)) 79 | `(,@prepend ,i)) 80 | `(make-node-function (quoty ,i)))))))) 81 | ;`(make-node ,i))))))) 82 | 83 | ;;; the atom lists 84 | ;(defmacro make-node (item) 85 | ; "Try to identify and make node object" 86 | ; (cond 87 | ; ;; Item is not an atom 88 | ; ((listp item) 89 | ; (if (listp (first item)) 90 | ; ;; List with multiple sublists/macros 91 | ; `(make-nodelist ,item) 92 | ; ;; Possibly a macro 93 | ; `(make-node-function (quoty ,item)))) 94 | ; (t `(make-node-function (quoty ,item))))) 95 | 96 | (defmacro make-node (item) 97 | "Try to identify and make node object" 98 | `(make-node-function (quoty ,item))) 99 | 100 | ;;; the atoms 101 | (defun make-node-function (item) 102 | "Build Node from symbol after expansion" 103 | (cond 104 | ;; no item 105 | ((eql item nil) (values)) 106 | ;; item is already c-mera node 107 | ((typep item 'node) item) 108 | ;; Item is most possibly an atom or a quoted symbol 109 | ((symbolp item) (identifier item)) 110 | ((numberp item) (number-literal item)) 111 | ((stringp item) (string-literal item)) 112 | ((characterp item) (character-literal item)) 113 | ;; Item is not a known atom 114 | (t (error "C-Mera encountered an unknown atom: ~a" item)))) 115 | 116 | ;;; From "let over lambda": 117 | (defun flatten (x) 118 | "Flatten cascaded list" 119 | (labels ((rec (x acc) 120 | (cond ((null x) acc) 121 | ((atom x) (cons x acc)) 122 | (t (rec 123 | (car x) 124 | (rec (cdr x) acc)))))) 125 | (rec x nil))) 126 | 127 | 128 | ;;; Ensure list 129 | (defmacro ensure-list (item &body body) 130 | `(let ((,item (if (listp ,item) ,item '(,item)))) 131 | ,@body)) 132 | 133 | ;;; Context switch 134 | (defun build-context-switches (&key user-package symbols) 135 | (let ((lisp-macrolet 136 | (loop for i in symbols collect 137 | (let ((symbol (format nil "~a" i))) 138 | ;; get :: name 139 | `(,(intern symbol user-package) (&rest rest) 140 | ;; map to cl:: 141 | (list* ',i rest))))) 142 | (cm-macrolet 143 | (loop for i in symbols collect 144 | (let ((symbol (intern (format nil "~a" i) user-package))) 145 | ;; get :: name 146 | `(,symbol (&rest rest) 147 | ;; map to its macroexpansion 148 | ;; -> expansion without local environment 149 | (macroexpand-1 `(,',symbol ,@rest)))))) 150 | (lisp-switch (intern "LISP" user-package)) 151 | (cm-switch (intern "CM" user-package))) 152 | (eval 153 | `(progn 154 | ;; define macro user-package::lisp 155 | ;; use common-lisp functions for macrolet scope 156 | (defmacro ,lisp-switch (&body body) 157 | `(macrolet ,',lisp-macrolet ,@body)) 158 | 159 | ;; define macro user-package::cm 160 | ;; use c-mera functions for macrolet scope 161 | ;; used to switch back within lisp-scope 162 | (defmacro ,cm-switch (&body body) 163 | `(macrolet ,',cm-macrolet (progn ,@body))))))) 164 | 165 | (defun build-swap-package (&key user-package swap-package symbols) 166 | (eval 167 | `(progn 168 | ,@(loop for i in symbols collect 169 | (let ((cm-symbol (intern (format nil "~a" i) user-package)) 170 | (sw-symbol (intern (format nil "~a" i) swap-package))) 171 | `(defmacro ,sw-symbol (&rest rest) 172 | (macroexpand-1 `(,',cm-symbol ,@rest)))))))) 173 | 174 | 175 | ;;; globally used hashes 176 | (defvar *ignore-node* (make-hash-table)) 177 | (defvar *proxy-node* (make-hash-table)) 178 | 179 | (defvar *enabled-warnings* '()) 180 | (defvar *suppressed-warnings* '()) 181 | 182 | 183 | ;;; ================================= 184 | ;;; currently unused 185 | ;;; ================================= 186 | 187 | ;;; be verbose and print info text for 'using functions..' and so on 188 | (defparameter *be-verbose* nil) 189 | 190 | 191 | ;;; Used for source-location 192 | (defun count-lines (file) 193 | "count lines from file and store character per line in global hash" 194 | (with-open-file (in file) 195 | (let ((nchars 0) 196 | (nlines 1) 197 | (chars-per-line '())) 198 | (loop for char = (read-char in nil nil nil) 199 | while char do 200 | (setf nchars (1+ nchars)) 201 | (if (eql char #\NewLine) 202 | (progn 203 | (push `(,nchars ,nlines) chars-per-line) 204 | (setf nlines (1+ nlines))))) 205 | (push `(,nchars ,nlines) chars-per-line) 206 | (reverse chars-per-line)))) 207 | 208 | (defparameter *chars-per-line* '()) ;; STack of stream-to-line mapppings 209 | 210 | ;;; Must be prepared with count-lines before usage. 211 | (defun get-line (stream) 212 | "get the current line number of the stream" 213 | (let ((fpos (file-position stream))) 214 | (second (car (remove-if #'(lambda (x) (< (car x) fpos)) 215 | (first *chars-per-line*)))))) 216 | 217 | 218 | 219 | (defparameter *current-file* '()) ; Stack of files in process 220 | ;; moved for clozure 221 | ;;(defparameter *chars-per-line* '()) ; Stack of Stream to Line mapping 222 | 223 | ;;; Contains mapping of S-Expr to line and file informations. 224 | (defparameter *line-hash* (make-hash-table :test 'equal)) 225 | (defparameter *file-hash* (make-hash-table :test 'equal)) 226 | -------------------------------------------------------------------------------- /src/c-mera/version.lisp: -------------------------------------------------------------------------------- 1 | (in-package :c-mera) 2 | 3 | (defparameter *version* (asdf:component-version (asdf:find-system :c-mera))) 4 | (defparameter *generator* :undefined) 5 | 6 | (defun print-version () 7 | (format t "~a~%" *version*)) 8 | -------------------------------------------------------------------------------- /src/c/cm-c.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c) 2 | 3 | ;; Define a c-mera file reader with extra macro characters 4 | (define-reader 5 | :file-reader read-in-file 6 | :string-reader read-in-string 7 | :macro-character 8 | ((set-macro-character #\Space #'pre-process) 9 | (set-macro-character #\Tab #'pre-process) 10 | (set-macro-character #\Newline #'pre-process) 11 | (set-macro-character #\( #'pre-process-heads))) 12 | 13 | ;; Define a start-up function 14 | (define-processor 15 | :name c-processor 16 | :file-reader read-in-file 17 | :string-reader read-in-string 18 | :extra-traverser 19 | (nested-nodelist-remover 20 | else-if-traverser 21 | if-blocker 22 | decl-blocker 23 | renamer)) 24 | 25 | ;; Define a save function 26 | (save-generator 27 | :name save 28 | :start-function c-processor 29 | :in-package :cmu-c) 30 | 31 | ;;; Simply prints the ast, useful in REPL. 32 | (defun simple-print (tree) 33 | "Pretty prints c-mera ast" 34 | (let ( 35 | ;(nc (make-instance 'nodelist-traverser)) 36 | (ei (make-instance 'else-if-traverser)) 37 | (ib (make-instance 'if-blocker)) 38 | (db (make-instance 'decl-blocker)) 39 | (rn (make-instance 'renamer)) 40 | (pp (make-instance 'pretty-printer))) 41 | (progn 42 | ;(traverser nc tree 0) 43 | (traverser ei tree 0) 44 | (traverser ib tree 0) 45 | (traverser db tree 0) 46 | (traverser rn tree 0) 47 | (traverser pp tree 0)))) 48 | 49 | ;;; Define a reader switch with c pre-processing 50 | (define-switch 51 | :name switch-reader 52 | :macro-character 53 | ((set-macro-character #\Space #'pre-process) 54 | (set-macro-character #\Tab #'pre-process) 55 | (set-macro-character #\Newline #'pre-process) 56 | (set-macro-character #\( #'pre-process-heads))) 57 | 58 | (define-switches 59 | :cl-reader cl-reader 60 | :cm-reader cm-reader 61 | :macro-character 62 | ((set-macro-character #\Space #'pre-process) 63 | (set-macro-character #\Tab #'pre-process) 64 | (set-macro-character #\Newline #'pre-process) 65 | (set-macro-character #\( #'pre-process-heads))) 66 | 67 | -------------------------------------------------------------------------------- /src/c/cmu-c.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cmu-c) 2 | 3 | ;;standard functions/macros 4 | (defmacro when (test &body forms) 5 | `(if ,test 6 | ,(cl:if (cadr forms) 7 | `(progn ,@forms) 8 | (car forms)))) 9 | 10 | ;;; new cons with (t ...) and without "else {}" 11 | (defmacro cond (&rest clauses) 12 | (let ((head (first clauses))) 13 | (lisp 14 | (when head 15 | (if (eql (first head) t) 16 | (cons 'progn (cdr head)) 17 | `(if ,(first head) 18 | ,(when (cdr head) 19 | (cons 'progn (cdr head))) 20 | ,(when (cdr clauses) 21 | `(cond ,@(cdr clauses))))))))) 22 | 23 | (defmacro 1+ (number) 24 | `(+ ,number 1)) 25 | 26 | (defmacro 1- (number) 27 | `(- ,number 1)) 28 | 29 | (defmacro cpp (&rest args) 30 | `(comment ,(format nil "~{~a~^ ~}" args) :prefix "#")) 31 | 32 | (defmacro pragma (&rest args) 33 | `(cpp "pragma" ,@args)) 34 | 35 | ;; Code proposed by plops on issue #17 36 | ;; https://github.com/kiselgra/c-mera/issues/17 37 | (defun replace-newline-with-backslash-newline (string) 38 | ;; this is from common lisp cookbook i got it from here: 39 | ;; http://stackoverflow.com/questions/4366668/str-replace-in-lisp 40 | ;; i modified it to only search for newlines 41 | (lisp 42 | (let ((part #\Newline) 43 | (replacement "\\ 44 | ")) 45 | (with-output-to-string (out) 46 | (loop 47 | for old-pos = 0 then (+ pos 1) 48 | for pos = (position part string 49 | :start old-pos 50 | :test #'char=) 51 | do (write-string string out 52 | :start old-pos 53 | :end (or pos (cl:length string))) 54 | when pos do (write-string replacement out) 55 | while pos))))) 56 | 57 | (defmacro codestring (&body body) 58 | `(comment (format nil "\"~a\"" 59 | (replace-newline-with-backslash-newline 60 | (with-output-to-string (*standard-output*) 61 | (simple-print (progn ,@body))))) 62 | :prefix "")) 63 | 64 | (defun symbol-append (&rest symbols) 65 | "Generate a symbol by combining the names of a number of symbols." 66 | (lisp 67 | (intern (apply #'concatenate 'string 68 | (mapcar #'symbol-name symbols))))) 69 | 70 | (defun extract-parameter-names-from-lambda-list (args) 71 | "Find the names of all parameters in a DEFMACRO-sytle (i.e. nested) lambda list." 72 | (lisp 73 | (let* ((special 0) 74 | (plain (loop 75 | for arg in args 76 | for i from 1 77 | until (member arg lambda-list-keywords) 78 | if (listp arg) append (extract-parameter-names-from-lambda-list arg) 79 | else collect arg 80 | finally (setf special i)))) 81 | (append plain 82 | (loop for arg in (common-lisp:subseq args special) 83 | if (listp arg) collect (first arg) 84 | else if (not (member arg lambda-list-keywords)) collect arg))))) 85 | 86 | (defun get-declaration-name (item) 87 | (let ((id (cl:if 88 | (let ((symbol (first (last (butlast item))))) 89 | (cl:and (symbolp symbol) 90 | (equal (symbol-name symbol) "="))) 91 | (first (last item 3)) 92 | (first (last item))))) 93 | (cl:if (cl:and (listp id) 94 | (let ((first (first id))) 95 | (cl:or (eql first 'aref) 96 | (eql first 'array) 97 | (eql first 'fpointer) 98 | (eql first 'funcall)))) 99 | (first (last (flatten (second id)))) 100 | (first (flatten id))))) 101 | 102 | ;;; still useful 103 | (defmacro use-variables (&rest variables) 104 | `(progn 105 | ,@(loop for i in variables collect 106 | `(defparameter ,i ',i)) 107 | (values))) 108 | 109 | (defmacro use-functions (&rest functions) 110 | `(progn 111 | ,@(loop for i in functions collect 112 | `(defmacro ,i (&rest body) `(funcall ,',i ,@body))))) 113 | 114 | 115 | -------------------------------------------------------------------------------- /src/c/nodes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c) 2 | 3 | ;;; 4 | ;;; Plain nodes 5 | ;;; 6 | 7 | ;; function 8 | (defnode function-definition () (item parameter body)) 9 | (defnode parameter-list () (parameters)) 10 | 11 | ;; struct 12 | (defnode struct-definition () (identifier members)) 13 | ;; union 14 | (defnode union-definition () (identifier members)) 15 | ;; enum 16 | (defnode enum-definition () (identifier members)) 17 | 18 | ;; variable declaration 19 | (defnode declaration-list (braces) (bindings body)) 20 | (defnode declaration-item () (specifier type identifier value)) 21 | (defnode declaration-value () (value)) 22 | 23 | ;; essential bulding blocks 24 | (defnode clist () (items)) 25 | (defnode array-reference () (array indizes)) 26 | (defnode object-reference () (object component)) 27 | (defnode pointer-reference () (pointer component)) 28 | (defnode type () (type)) 29 | (defnode float-type () (number)) 30 | (defnode specifier () (specifier)) 31 | (defnode function-pointer () (identifier parameters)) 32 | 33 | ;;; 34 | ;;; Expressions 35 | ;;; 36 | 37 | ;; = *= /= %= += -= <<= >>= &= ^= \|= 38 | (defexpression assignment-expression (operator) (variable value)) 39 | 40 | ;; + - / * > < == != += -= >= <= \| \|\| & &= && % << >> or and 41 | (defexpression infix-expression (operator) (members)) 42 | 43 | ;; - + -- ++ ! * & 44 | (defexpression prefix-expression (operator) (object)) 45 | 46 | ;; - + -- ++ * 47 | (defexpression postfix-expression (operator) (object)) 48 | 49 | ;; not ('!' defined as prefix) 50 | (defexpression not-expression () (value)) 51 | 52 | ;; ? : 53 | (defexpression conditional-expression () (test then else)) 54 | 55 | ;; cast 56 | (defexpression cast-expression () (type object)) 57 | 58 | 59 | ;;; 60 | ;;; Statements 61 | ;;; 62 | 63 | ;; goto, continue, break return 64 | (defstatement jump-statement () (kind members)) 65 | (defstatement label-statement () (name)) 66 | 67 | (defstatement expression-statement (force-semicolon) (expression)) 68 | (defstatement compound-statement (braces) (statements)) 69 | 70 | (defstatement if-statement () (test if-body else-body)) 71 | 72 | ;;; Loops 73 | (defstatement for-statement () (init test step body)) 74 | (defstatement while-statement () (test body)) 75 | (defstatement do-statement () (body test)) 76 | 77 | 78 | ;;; Comment. Leading chars ('//' or other) can also be defined explicitly. 79 | (defstatement comment (chars comment linebreak) ()) 80 | 81 | ;;; switch-case 82 | (defstatement switch-case-statement () (switch cases)) 83 | (defnode switch-case-item () (constant body)) 84 | 85 | ;;; 86 | ;;; gcc extensions 87 | ;;; 88 | 89 | (defexpression attribute-expression () (arguments)); 90 | 91 | 92 | ;;; typedef 93 | (defstatement typedef () (declaration)) 94 | 95 | ;;; 96 | ;;; Special nodes 97 | ;;; 98 | 99 | 100 | (defnode include (file) ()) 101 | 102 | ;;; TODO test! 103 | (defnode preprocessor-macro (name function) (body)) 104 | -------------------------------------------------------------------------------- /src/c/reader.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c) 2 | 3 | ;;; Used as a global pre-processor for all symbols in c-mera nodes 4 | (defun dissect (item &key (quoty nil)) 5 | "starts the appropriate preprocessing for the item" 6 | (cond 7 | ((symbolp item) 8 | (cond 9 | ((and (eql (first (coerce (symbol-name item) 'list)) #\") 10 | (eql (first (reverse (coerce (symbol-name item) 'list))) #\")) 11 | item) 12 | ((and (eql (first (coerce (symbol-name item) 'list)) #\<) 13 | (eql (first (reverse (coerce (symbol-name item) 'list))) #\>)) 14 | item) 15 | ((and (eql (first (coerce (symbol-name item) 'list)) #\*) 16 | (eql (first (reverse (coerce (symbol-name item) 'list))) #\*)) 17 | item) 18 | ;; check/(fix package 19 | ((or (eql item 'cmu-c::&optional) 20 | (eql item 'cmu-c::&key) 21 | (eql item 'cmu-c::&environment) 22 | (eql item 'cmu-c::&body) 23 | (eql item 'cmu-c::&rest)) 24 | item) 25 | ((and (> (length (symbol-name item)) 1) 26 | (eql (first (coerce (symbol-name item) 'list)) #\&)) 27 | (split-addrof item)) 28 | ((and (> (length (symbol-name item)) 1) 29 | (eql (first (coerce (symbol-name item) 'list)) #\*) 30 | (not (eql (first (reverse (coerce (symbol-name item) 'list))) #\*))) 31 | (split-targof item)) 32 | (t 33 | (let* ((name-string (symbol-name item)) 34 | (num-pos (position-if #'numberp (mapcar #'digit-char-p (coerce name-string 'list)))) 35 | (f-pos (search "F" name-string :from-end t)) 36 | (-pos (search "-" name-string)) 37 | (dot-pos2 (search "." name-string)) ;hack 38 | (dot-pos (search "." name-string :from-end t)) 39 | (arrow-pos (search "->" name-string :from-end t)) 40 | (bracket-pos (search "]" name-string :from-end t))) 41 | (labels ((pos-cond (a b c) (if a (and (if b (> a b) t) (if c (> a c) t)) nil))) 42 | (cond 43 | ((and (eql f-pos (- (length name-string) 1)) (or (eql num-pos 0) 44 | (eql -pos 0) 45 | (eql dot-pos2 0))) 46 | (read-float item)) 47 | ((pos-cond dot-pos arrow-pos bracket-pos) (split-oref item)) 48 | ((pos-cond arrow-pos dot-pos bracket-pos) (split-pref item)) 49 | ((pos-cond bracket-pos arrow-pos dot-pos) (split-aref item)) 50 | ((or (search "+" name-string) 51 | (search "-" name-string) 52 | (search "!" name-string) 53 | (search "*" name-string) 54 | (search "~" name-string)) 55 | (split-unary item)) 56 | (t (if (not (find-if-not #'digit-char-p (symbol-name item))) 57 | (parse-integer (symbol-name item)) 58 | (if quoty 59 | `(quoty ,item) 60 | item))))))))) 61 | (t item))) 62 | 63 | (defun read-float (item) 64 | "perace correct float print" 65 | (let* ((name (symbol-name item)) 66 | (len (length name))) 67 | ;; Inspired by: Bozhidar Batsov, batsov.com/articles/2011/04/30/parsing-numbers-from-string-in-lisp 68 | (with-input-from-string (in (subseq name 0 (- len 1))) 69 | `(cmu-c::float-type ,(read in))))) 70 | 71 | (defun split-unary (item) 72 | "prepare ++i or the like to unary node cration: ++i => (prefix i ++)" 73 | (let* ((name (symbol-name item)) 74 | (len (length name)) 75 | (>2 (> len 2)) 76 | (>1 (> len 1))) 77 | (if (not >1) 78 | item 79 | (let ((pos-inc (equalp (subseq name (- len 2) len) "++")) 80 | (pos-dec (equalp (subseq name (- len 2) len) "--")) 81 | (pre-inc (equalp (subseq name 0 2) "++")) 82 | (pre-dec (equalp (subseq name 0 2) "--")) 83 | (minus (equalp (subseq name 0 1) "-")) 84 | (plus (equalp (subseq name 0 1) "+")) 85 | (not (equalp (subseq name 0 1) "!")) 86 | (not2 (equalp (subseq name 0 1) "~")) 87 | (ast (equalp (subseq name (- len 1) len) "*"))) 88 | 89 | (cond 90 | ((and pos-inc >2) `(cmu-c::postfix++ ,(dissect (intern (subseq name 0 (- len 2))) :quoty t))) 91 | ((and pos-dec >2) `(cmu-c::postfix-- ,(dissect (intern (subseq name 0 (- len 2))) :quoty t))) 92 | ((and ast >1) `(cmu-c::postfix* ,(dissect (intern (subseq name 0 (- len 1))) :quoty t))) 93 | ((and pre-inc >2) `(cmu-c::prefix++ ,(dissect (intern (subseq name 2 len)) :quoty t))) 94 | ((and pre-dec >2) `(cmu-c::prefix-- ,(dissect (intern (subseq name 2 len)) :quoty t))) 95 | ((and minus >1) `(cmu-c::- ,(dissect (intern (subseq name 1 len)) :quoty t))) 96 | ((and plus >1) `(cmu-c::+ ,(dissect (intern (subseq name 1 len)) :quoty t))) 97 | ((and not >1) `(cmu-c::! ,(dissect (intern (subseq name 1 len)) :quoty t))) 98 | ((and not2 >1) `(cmu-c::~ ,(dissect (intern (subseq name 1 len)) :quoty t))) 99 | (t item)))))) 100 | 101 | (defun split-addrof (name) 102 | "prepare addr-of node: &foo => (addr-of foo)" 103 | (let ((name (symbol-name name))) 104 | `(cmu-c::addr-of ,(dissect (intern (subseq name 1 (length name))) :quoty t)))) 105 | 106 | (defun split-targof (name) 107 | "prepare targ-of node: *foo => (targ-of foo)" 108 | (let ((name (symbol-name name))) 109 | `(cmu-c::targ-of ,(dissect (intern (subseq name 1 (length name))) :quoty t)))) 110 | 111 | (defun split-oref (name) 112 | "prepare oref node: foo.baz => (oref foo baz)" 113 | (let* ((name-string (symbol-name name)) 114 | (pos (search "." name-string :from-end t)) 115 | (names (fix-case (subseq name-string 0 pos) (subseq name-string (+ 1 pos))))) 116 | `(cmu-c::oref ,(dissect (first names) :quoty t) 117 | ,(dissect (second names) :quoty t)))) 118 | 119 | (defun split-pref (name) 120 | "prepare pref node: a->b => (pref a b)" 121 | (let* ((name-string (symbol-name name)) 122 | (pos (search "->" name-string :from-end t)) 123 | (names (fix-case (subseq name-string 0 pos) (subseq name-string (+ 2 pos))))) 124 | (if (eql pos 0) 125 | name ;; function definition arrow, dont touch 126 | `(cmu-c::pref ,(dissect (first names) :quoty t) 127 | ,(dissect (second names) :quoty t))))) 128 | 129 | (defun split-aref (name) 130 | "make aref node: a[b][c] => (aref (aref a b) c)" 131 | (let* ((name-string (symbol-name name)) 132 | (name-list (reverse (coerce name-string 'list)))) 133 | (let ((pos 0) 134 | (counter 0) 135 | (names nil)) 136 | 137 | ;; get position of matching '[ for last '] 138 | (loop for i in name-list do 139 | (progn 140 | (cond 141 | ((eql i #\]) (incf counter)) 142 | ((eql i #\[) (decf counter))) 143 | (incf pos) 144 | (when (eql counter 0) 145 | (return)))) 146 | (setf pos (- (length name-string) pos)) 147 | (setf names (fix-case (subseq name-string 0 pos) 148 | (subseq name-string (1+ pos) (1- (length name-string))))) 149 | (if (not (equal "" (symbol-name (second names)))) 150 | ;; index not empty 151 | `(cmu-c::aref ,(dissect (first names) :quoty t) 152 | ,(dissect (second names) :quoty t)) 153 | ;; index empty 154 | `(cmu-c::aref ,(dissect (first names) :quoty t)))))) 155 | 156 | (defun pre-process (stream char) 157 | "Pre process symbols in stream an prepare actual node" 158 | (declare (ignore char)) 159 | (let ((peek (peek-char nil stream nil nil nil))) 160 | ;; stop at whitespace and comments 161 | (if (not (or (eql peek #\)) 162 | (eql peek #\;) 163 | (eql peek #\#) 164 | (eql peek #\Space) 165 | (eql peek #\Newline) 166 | (eql peek #\Tab))) 167 | (dissect (read stream nil nil nil)) 168 | (values)))) 169 | 170 | (defun pre-process-heads (stream char) 171 | "Pre process list heads and prepare nodes" 172 | (declare (ignore char)) 173 | (let ((peek (peek-char nil stream nil nil nil)) 174 | (list (read-delimited-list #\) stream t))) 175 | (let ((first (first list))) 176 | ;; stop at whitespace and comments 177 | (if (not (or (eql peek #\() 178 | (eql peek #\)) 179 | (eql peek #\;) 180 | (eql peek #\#) 181 | (eql peek #\Space) 182 | (eql peek #\Newline) 183 | (eql peek #\Tab) 184 | (and (symbolp first) 185 | (fboundp! first)))) 186 | (append (list (dissect first)) (rest list)) 187 | list)))) 188 | 189 | ;;; Needs further analysis 190 | ;;(defun comment-reader (stream char) 191 | ;; "Rread lisp comments and emmit c-mera comments" 192 | ;; (let ((peek (peek-char nil stream nil nil nil))) 193 | ;; (if (not (eql peek #\;)) 194 | ;; `(cmu-c::comment #+clozure ,(ccl::read-string stream #\Newline) 195 | ;; #+sbcl ,(sbcl::read-string stream #\Newline)) 196 | ;; (values)))) 197 | 198 | -------------------------------------------------------------------------------- /src/c/syntax.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c) 2 | 3 | (defmacro c-syntax (tags lambda-list &body body) 4 | `(defsyntax ,tags (:cmu-c) ,lambda-list ,@body)) 5 | 6 | (defmacro make-expressions (list) 7 | ;; make expression statements with semicolon and wrap in quoties 8 | `(make-nodelist ,list :prepend (expression-statement nil) :quoty t)) 9 | 10 | (defmacro make-block (list) 11 | "Code block with curly braces and intendation" 12 | `(compound-statement 13 | ;; curly braces: t 14 | t 15 | ;(make-nodelist ,list))) 16 | ;; make expressions with ';' delimiter 17 | (make-expressions ,list))) 18 | 19 | (defmacro make-simple-block (list) 20 | "Code block without underlying nodelist. 21 | Used for 'bodys' where implicit progn is required" 22 | `(compound-statement 23 | ;; curly braces: t 24 | t 25 | ;; also handle expressions when 'progn' is absent 26 | (expression-statement nil (quoty ,list)))) 27 | 28 | (c-syntax block (&body body) 29 | "Code block with curly braces and intendation" 30 | `(make-block ,body)) 31 | 32 | (c-syntax progn (&body body) 33 | "Code block without curly braces nor intendation" 34 | ;; make expressions with ';' delimiter 35 | `(make-expressions ,body)) 36 | 37 | (c-syntax set (&rest rest) 38 | "Assigment operator for multiple inputs" 39 | (when (oddp (length rest)) 40 | (error "Set operator with odd number of elements: ~a" rest)) 41 | (if (eql (length rest) 2) 42 | ;; signel assignment 43 | `(assignment-expression '= (make-node ,(pop rest)) (make-node ,(pop rest))) 44 | ;; muliple assignments 45 | `(make-expressions 46 | ;; collect item pairwise and emmit sigle assignments 47 | ,(loop while rest collect 48 | `(assignment-expression '= (make-node ,(pop rest)) (make-node ,(pop rest))))))) 49 | 50 | (c-syntax (= *= /= %= += -= <<= >>= &= ^= \|=) (variable value) 51 | "Assignment operators for single inputs" 52 | `(assignment-expression ',tag (make-node ,variable) (make-node ,value))) 53 | 54 | (c-syntax (/ > < == != >= <= \| \|\| % << >> or and ^ &&) (&rest rest) 55 | "Infix expressions for multiple inputs" 56 | `(infix-expression ',tag (make-nodelist ,rest))) 57 | 58 | (c-syntax (- + * &) (&rest rest) 59 | "Infix or prefix version" 60 | (if (eql (length rest) 1) 61 | `(prefix-expression ',tag (make-node ,@rest)) 62 | `(infix-expression ',tag (make-nodelist ,rest)))) 63 | 64 | (c-syntax (~ !) (item) 65 | "Prefix operators" 66 | `(prefix-expression ',tag (make-node ,item))) 67 | 68 | (c-syntax (addr-of) (item) 69 | "Address-of function (&)" 70 | `(prefix-expression '& (make-node ,item))) 71 | 72 | (c-syntax (targ-of dref) (item) 73 | "Taget-of or dereferencing pointer" 74 | `(prefix-expression '* (make-node ,item))) 75 | 76 | (c-syntax ptr-to (item) 77 | "Specify pointer type" 78 | `(postfix-expression '* (make-node ,item))) 79 | 80 | (c-syntax prefix++ (item) 81 | "Prefix operator ++" 82 | `(prefix-expression '++ (make-node ,item))) 83 | 84 | (c-syntax prefix-- (item) 85 | "Prefix operator --" 86 | `(prefix-expression '-- (make-node ,item))) 87 | 88 | (c-syntax postfix-- (item) 89 | "Postfix operator --" 90 | `(postfix-expression '-- (make-node ,item))) 91 | 92 | (c-syntax postfix++ (item) 93 | "Postfix operator ++" 94 | `(postfix-expression '++ (make-node ,item))) 95 | 96 | (c-syntax postfix* (item) 97 | "Postfix operator *" 98 | `(postfix-expression '* (make-node ,item))) 99 | 100 | (c-syntax struct (name &body body) 101 | "Struct definition" 102 | `(struct-definition 103 | ;; struct name 104 | (make-node ,name) 105 | ;; struct body 106 | ,(when body 107 | `(compound-statement 108 | ;; curly braces: t 109 | t 110 | ;; build subnodes 111 | (make-nodelist ,body))))) 112 | 113 | (c-syntax union (name &body body) 114 | "Syntax for union" 115 | `(union-definition 116 | ;; union name 117 | (make-node ,name) 118 | ;; union body 119 | (compound-statement 120 | ;; curly braces: t 121 | t 122 | ;; build subnodes 123 | (make-nodelist ,body)))) 124 | 125 | (c-syntax enum (&rest rest) 126 | "Syntax for enum" 127 | (destructuring-bind (enum-list &optional name) (reverse rest) 128 | (setf enum-list (mapcar #'(lambda (x) 129 | (if (listp x) 130 | x 131 | (list x))) enum-list)) 132 | `(enum-definition 133 | ;; enum name 134 | ,(when name 135 | `(make-node ,name)) 136 | ;; enums as parameter list 137 | (make-nodelist ,enum-list :prepend decompose-enum)))) 138 | 139 | (c-syntax (aref array) (array &rest indizes &environment env) 140 | "Array reference" 141 | (if (not indizes) 142 | (setf indizes '(nil))) 143 | ;; make array referende 144 | `(array-reference 145 | ;; check if identifier / type / macro 146 | ,(if (listp array) 147 | ;; check if macro/function or list 148 | (let ((first (first array))) 149 | (if (and (not (listp first)) (fboundp! first env)) 150 | ;; type is macro or function 151 | `(make-node ,array) 152 | ;; type is list with type information 153 | `(make-declaration-node (,@array nil)))) 154 | ;; type is single symbol 155 | `(make-node ,array)) 156 | ;; indizes 157 | (make-nodelist ,indizes))) 158 | 159 | 160 | ;((make-node ,array) (make-nodelist ,indizes))) 161 | 162 | (c-syntax oref (&rest rest) 163 | "Object reference" 164 | (let* ((items (reverse rest)) 165 | (last-item (pop items)) 166 | (butlast-item (pop items)) 167 | (oref `(object-reference (make-node ,butlast-item) (make-node ,last-item)))) 168 | (loop for item in items do 169 | (setf oref `(object-reference (make-node ,item) ,oref))) 170 | oref)) 171 | 172 | (c-syntax pref (pointer component) 173 | "Pointer reference" 174 | `(pointer-reference (make-node ,pointer) (make-node ,component))) 175 | 176 | (c-syntax type (type) 177 | "C data type" 178 | `(type (make-node ,type))) 179 | 180 | (c-syntax specifier (specifier) 181 | "Type specifier/qualifier" 182 | `(specifier (make-node ,specifier))) 183 | 184 | (c-syntax include (file) 185 | "Include for c files" 186 | `(include (quoty ,file))) 187 | 188 | (c-syntax comment (comment &key (prefix nil) (linebreak t)) 189 | "Comment with default ('//') or user defined delimiter." 190 | `(comment 191 | (quoty ,(if prefix prefix "//")) 192 | (quoty ,comment) 193 | ,linebreak)) 194 | 195 | (defun decompose-declaration (item) 196 | "Decompose declaration item into its SPECIFIERS, TYPE, NAME and INITIALIZER" 197 | (if (let ((symbol (first (last (butlast item))))) 198 | (and (symbolp symbol) 199 | (equal (symbol-name symbol) "="))) 200 | 201 | ;; decompose arg list with init 202 | (let ((specifier (butlast item 4)) 203 | (type+id+val (last item 4))) 204 | (let ((type (first type+id+val)) 205 | (id (second type+id+val)) 206 | (init (fourth type+id+val))) 207 | (values specifier type id init))) 208 | 209 | ;; decompose arg list without init 210 | (let ((specifier (butlast item 2)) 211 | (type+id (last item 2))) 212 | (let ((type (first type+id)) 213 | (id (second type+id))) 214 | (values specifier type id nil))))) 215 | 216 | (defmacro make-declaration-node (item) 217 | "Decompose declaration item and instantiate nodes" 218 | (if (eql item '&rest) 219 | `(make-node '|...|) 220 | (multiple-value-bind (specifier type id init) (decompose-declaration item) 221 | `(declaration-item 222 | ;; set specifiers 223 | ,(when specifier 224 | `(specifier 225 | (make-nodelist ,specifier))) 226 | ;; set type 227 | (type (make-node ,type)) 228 | ;; set identifier 229 | (make-node ,id) 230 | ;; set value 231 | ,(if init 232 | `(declaration-value 233 | (make-node ,init)) 234 | nil))))) 235 | 236 | (defmacro decompose-type (item) 237 | "Decompose type like declaration but without name" 238 | `(make-declaration-node (,@item nil))) 239 | 240 | (defmacro decompose-enum (item) 241 | "Decompose enum like declaration but without type" 242 | `(declaration-item 243 | ;; no specifier 244 | nil 245 | ;; no type 246 | nil 247 | ;; enum name 248 | (make-node ,(first item)) 249 | ;; enum init 250 | ,(when (second item) 251 | `(declaration-value 252 | (make-node ,(second item)))))) 253 | 254 | (c-syntax decl (bindings &body body) 255 | "Declare variables" 256 | `(declaration-list 257 | ;; braces t, adjusted later by traverser 258 | t 259 | ;; make single declarations/bindings 260 | (make-nodelist 261 | ,(remove nil bindings) :prepend make-declaration-node) 262 | ;; make listnode with body 263 | ,(when body 264 | ;; make single expression statements 265 | `(make-expressions ,body)))) 266 | 267 | (c-syntax function (name parameters -> type &body body &environment env) 268 | "Define c function" 269 | (declare (ignore ->)) 270 | `(function-definition 271 | ;; function name + type 272 | ,(if (listp type) 273 | ;; check if macro/function or list 274 | (let ((first (first type))) 275 | (if (and (not (listp first)) (fboundp! first env)) 276 | ;; type is macro or function 277 | `(make-declaration-node (,type ,name)) 278 | ;; type is list with type information 279 | `(make-declaration-node (,@type ,name)))) 280 | ;; type is single symbol 281 | `(make-declaration-node (,type ,name))) 282 | ;; parameter list 283 | (parameter-list 284 | (make-nodelist ,parameters :prepend make-declaration-node)) 285 | ;; body 286 | ,(when body 287 | `(make-block ,body)))) 288 | 289 | (c-syntax fpointer (name &optional parameters) 290 | "Define a function pointer" 291 | `(function-pointer 292 | ;; function pointer identifier 293 | (make-node ,name) 294 | ;; function pointer parameters 295 | (parameter-list 296 | (make-nodelist ,parameters :prepend make-declaration-node)))) 297 | 298 | (c-syntax for (init &body body) 299 | "The c for loop" 300 | `(for-statement 301 | ;; check if initialization present 302 | ,(when (first init) 303 | ;; set init 304 | `(make-declaration-node ,(first init))) 305 | ;; test 306 | (make-node ,(second init)) 307 | ;; step 308 | (make-node ,(third init)) 309 | ;; the loop body 310 | (make-block ,body))) 311 | ;(make-expressions ,body))) 312 | 313 | (c-syntax if (test if-body &optional else-body) 314 | "The c if expression" 315 | `(if-statement 316 | ;; case test 317 | (make-node ,test) 318 | ;; if true: 319 | (make-simple-block ,(if if-body if-body (empty))) 320 | ;; if else and present 321 | ,(when else-body 322 | `(make-simple-block ,else-body)))) 323 | 324 | (c-syntax ? (test then else) 325 | "The conditinal expression 'test ? then : else'" 326 | `(conditional-expression 327 | (make-node ,test) 328 | (make-node ,then) 329 | (make-node ,else))) 330 | 331 | (defmacro make-switch-case-item (item) 332 | "switch case item helper" 333 | `(switch-case-item 334 | ;; list of trigger values 335 | ,(if (eql (first item) t) 336 | ;; identify default case 337 | nil 338 | ;; normal cases 339 | `(make-nodelist ,(if (listp (first item)) 340 | (first item) 341 | (list (first item))) 342 | :quoty t)) 343 | ;; case body 344 | (make-expressions ,(rest item)))) 345 | 346 | (c-syntax switch (expression &rest cases) 347 | "Switch-Case" 348 | `(switch-case-statement 349 | ;; set expression 350 | (make-node ,expression) 351 | (compound-statement 352 | ;; curly braces: t 353 | t 354 | ;; cases 355 | (make-nodelist ,cases :prepend make-switch-case-item)))) 356 | 357 | 358 | 359 | (c-syntax while (test &body body) 360 | "The c while loop" 361 | `(while-statement 362 | ;; while clause 363 | (make-node ,test) 364 | ;; body expressions 365 | (make-block ,body))) 366 | 367 | (c-syntax do-while (test &body body) 368 | "The c do-whiel loop" 369 | `(do-statement 370 | ;; body expressions 371 | (make-block ,body) 372 | ;; while cluase 373 | (make-node ,test))) 374 | 375 | (c-syntax typedef (&rest rest) 376 | "Typedef for c types" 377 | `(typedef 378 | ;; decompose type + alias 379 | (make-declaration-node ,rest))) 380 | 381 | (c-syntax cast (&rest rest) 382 | "Cast type" 383 | `(cast-expression 384 | ;; cast to type, with nil variable 385 | (decompose-type ,(butlast rest)) 386 | ;; casted object 387 | (make-node ,(first (last rest))))) 388 | 389 | (c-syntax sizeof (&rest type) 390 | "C sizeof function" 391 | `(function-call 392 | ;; function name 393 | (make-node sizeof) 394 | ;; rest ('type') as single argmument 395 | (decompose-type ,type))) 396 | 397 | (c-syntax float-type (item) 398 | "Generate 'f' suffixes" 399 | `(float-type (make-node ,item))) 400 | 401 | (c-syntax (goto continue break return) (&optional item) 402 | "Jump statements with optional item" 403 | `(jump-statement 404 | (make-node ,tag) 405 | ,(when item `(make-node ,item)))) 406 | 407 | (c-syntax (label) (name) 408 | "Label" 409 | `(label-statement (make-node ,name))) 410 | 411 | (c-syntax not (item) 412 | "Not-expression" 413 | `(not-expression (make-node ,item))) 414 | 415 | (c-syntax clist (&rest rest) 416 | "C style list" 417 | `(clist (make-nodelist ,rest))) 418 | 419 | (c-syntax funcall (function &rest args) 420 | "C function call" 421 | `(function-call 422 | (make-node ,function) 423 | (make-nodelist ,args))) 424 | 425 | (c-syntax attribute (&rest args) 426 | "GCC attribute extension" 427 | `(attribute-expression 428 | (make-nodelist ,args))) 429 | 430 | ;; build 'lisp' and 'cm' macros in :cmu-c package 431 | ;; lisp -> switch inside scope to lisp functions 432 | ;; cm -> switch isnide scope to c-mera 433 | ;; (might be useful inside lisp scope) 434 | ;; c-symbols: defined in c-mera.asd 435 | (build-context-switches 436 | :user-package :cmu-c 437 | :symbols c-symbols) 438 | 439 | (build-swap-package 440 | :user-package :cmu-c 441 | :swap-package :cms-c 442 | :symbols c-swap) 443 | 444 | 445 | ;;TODO 446 | ;; - peprocessor macro 447 | ;; - source pos 448 | ;; - do-while 449 | 450 | 451 | -------------------------------------------------------------------------------- /src/c/traverser.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Common traverser functions for pretty printing and other tasks. 2 | 3 | (in-package :cm-c) 4 | 5 | ;;; A traverser which checks the identifier for c-conformity 6 | ;;; and automatically solves naming problems. 7 | (defclass renamer () 8 | ((used-names :initform (make-hash-table :test 'equal)) 9 | (name-map :initform (make-hash-table :test 'equal)))) 10 | (defgeneric check-and-get-name (renamer check-name)) 11 | 12 | ;;; Check if identifier is OK. 13 | ;;; Store in hash table and correct if necessary. 14 | (defmethod check-and-get-name ((item renamer) check-name) 15 | (with-slots (used-names name-map) item 16 | (if (eql check-name '|...|) 17 | ;; ignore '...' 18 | check-name 19 | ;; treat hyphen and underscore equally / map hyphen to underscore 20 | (let* ((name-string (symbol-name check-name)) 21 | (identifier (substitute #\_ #\- name-string))) 22 | (when (and (not (equal identifier name-string)) 23 | (find :hyphen *enabled-warnings*)) 24 | (warn "Possible ambiguity through hyphen override of ~s" check-name)) 25 | (let ((alr-checked (gethash identifier name-map))) 26 | (if alr-checked 27 | alr-checked 28 | (labels ((check-char (x) (alpha-char-p x)) 29 | (check-underscore (x) (eql #\_ x)) 30 | (check-tilde (x) (eql #\~ x)) 31 | (check-num (x) (digit-char-p x)) 32 | (check-hex (x) (and (eql #\0 (first x)) 33 | (or (eql #\x (second x)) 34 | (eql #\X (second x))))) 35 | (check-all (x) 36 | (or 37 | (check-char x) 38 | (check-underscore x) 39 | (check-num x))) 40 | (check-nall (x) 41 | (not (check-all x)))) 42 | (let* ((identifier-l (concatenate 'list identifier)) 43 | (changed-l (if (check-tilde (car identifier-l)) 44 | (concatenate 'list 45 | '(#\~) 46 | (substitute-if #\_ #'check-nall (rest identifier-l))) 47 | (substitute-if #\_ #'check-nall identifier-l))) 48 | (changed (concatenate 'string changed-l))) 49 | 50 | (when (and (check-num (first changed-l)) 51 | (not (check-hex changed-l))) 52 | (setf (first changed-l) #\_) 53 | (setf changed (concatenate 'string changed-l))) 54 | 55 | (loop while (gethash changed used-names) do 56 | (setf changed (format nil "_~a" changed))) 57 | (setf (gethash changed used-names) t) 58 | (setf changed (intern changed)) 59 | (setf (gethash identifier name-map) changed) 60 | changed)))))))) 61 | 62 | ;;; Traverses the tree but checks only the identifier nodes. 63 | (defmethod traverser ((rn renamer) (item identifier) level) 64 | (declare (ignore level)) 65 | (with-slots (identifier) item 66 | ;(setf identifier (check-and-get-name rn (intern (symbol-name identifier) :cgen))))) 67 | (setf identifier (check-and-get-name rn identifier)))) ;(intern (symbol-name identifier)))))) 68 | 69 | ;;; This Traverser checks whether braces really are necessary. 70 | (defclass decl-blocker () 71 | ((names :initform `(,(make-hash-table))) 72 | (delta-names :initform '(nil)) 73 | (in-decl :initform '(nil)) 74 | (in-decl-item :initform '(nil)) 75 | (make-block :initform '(nil)))) 76 | 77 | (defmethod traverser ((db decl-blocker) (item identifier) level) 78 | "find names, check if in decl-item, save infos on stack in decl-blocker" 79 | (declare (ignore level)) 80 | (with-slots (identifier) item 81 | (with-slots (names delta-names in-decl-item make-block) db 82 | (when (first in-decl-item) 83 | (if (gethash identifier (first names)) 84 | (setf (first make-block) t) 85 | (progn (push identifier (first delta-names)) 86 | (setf (gethash identifier (first names)) t))))))) 87 | 88 | (with-proxynodes (proxy) 89 | "find declaration-item identifier" 90 | 91 | (defproxymethod :before (db decl-blocker) proxy 92 | "push 'true' on in-decl stack in decl-blocker" 93 | (with-slots (in-decl in-decl-item) db 94 | (when (first in-decl) 95 | (setf (first in-decl-item) t)))) 96 | 97 | (defproxymethod :after (db decl-blocker) proxy 98 | "pop last item on in-decl stack of decl-blocker" 99 | (with-slots (in-decl in-decl-item) db 100 | (when (first in-decl) 101 | (setf (first in-decl-item) nil)))) 102 | 103 | (defmethod traverser :before ((db decl-blocker) (item declaration-item) level) 104 | "prepare decl-blocker-proxy to identify names" 105 | (declare (ignore level)) 106 | (with-slots (identifier) item 107 | (make-proxy identifier proxy))) 108 | 109 | (defmethod traverser :after ((db decl-blocker) (item declaration-item) level) 110 | "remove decl-blocker-proxy" 111 | (declare (ignore level)) 112 | (with-slots (identifier) item 113 | (del-proxy identifier))) 114 | ) 115 | 116 | (with-proxynodes (tmp-proxy) 117 | "find genuine identifier in array reference" 118 | 119 | (defproxymethod :before (db decl-blocker) tmp-proxy 120 | "array[indizes] -> both are 'name', set 'false' for indizes on stack" 121 | (with-slots (in-decl in-decl-item) db 122 | (if (first in-decl) 123 | (push nil in-decl-item)))) 124 | 125 | (defproxymethod :after (db decl-blocker) tmp-proxy 126 | "pop last item on in-decl stack of decl-blocker" 127 | (with-slots (in-decl in-decl-item) db 128 | (if (first in-decl) 129 | (pop in-decl-item)))) 130 | 131 | (defmethod traverser :before ((db decl-blocker) (item array-reference) level) 132 | "add proxy do distinct array from indizes" 133 | (declare (ignore level)) 134 | (with-slots (indizes) item 135 | (make-proxy indizes tmp-proxy))) 136 | 137 | (defmethod traverser :after ((db decl-blocker) (item array-reference) level) 138 | "remove proxy..." 139 | (declare (ignore level)) 140 | (with-slots (indizes) item 141 | (del-proxy indizes))) 142 | ) 143 | 144 | (with-proxynodes (funcall-args) 145 | "identify parameters in function call (similar to arrey/indizes)" 146 | 147 | (defmethod traverser :before ((db decl-blocker) (item function-call) level) 148 | "add proxy" 149 | (declare (ignore level)) 150 | (with-slots (arguments) 151 | (make-proxy arguments funcall-args))) 152 | 153 | (defmethod traverser :after ((db decl-blocker) (item function-call) level) 154 | "remove proxy" 155 | (declare (ignore level)) 156 | (with-slots (arguments) 157 | (del-proxy arguments))) 158 | 159 | (defproxymethod :before (db decl-blocker) funcall-args 160 | "(constructor arg1 arg2..) -> 'constructor', 'arg1', 'arg2' are identifier -> hide args" 161 | (with-slots (in-decl in-decl-item) db 162 | (when (first in-decl) 163 | (push nil in-decl-item)))) 164 | 165 | (defproxymethod :after (db decl-blocker) funcall-args 166 | "pop last item from in-decl stack of decl-blocker" 167 | (with-slots (in-decl in-decl-item) db 168 | (when (first in-decl) 169 | (pop in-decl-item))))) 170 | 171 | 172 | 173 | (defmethod traverser :before ((db decl-blocker) (item declaration-list) level) 174 | "prepare empty lists and a nil-value for further traversing" 175 | (declare (ignore level)) 176 | (with-slots (delta-names make-block in-decl in-decl-item) db 177 | (push nil delta-names) 178 | (push nil make-block) 179 | (push t in-decl) 180 | (push nil in-decl-item))) 181 | 182 | (defmethod traverser :after ((db decl-blocker) (item declaration-list) level) 183 | "check values in decl-blocker and set braces to 'true' or 'nil'" 184 | (declare (ignore level)) 185 | (with-slots (names delta-names make-block in-decl in-decl-item) db 186 | (if (first make-block) 187 | (progn 188 | (setf (slot-value item 'braces) t) 189 | (loop for i in (first delta-names) do 190 | (setf (gethash i (first names)) nil))) 191 | (if (> (list-length delta-names) 1) 192 | (progn 193 | (setf (slot-value item 'braces) nil) 194 | (loop for i in (first delta-names) do 195 | (push i (second delta-names)))))) 196 | (pop delta-names) 197 | (pop make-block) 198 | (pop in-decl) 199 | (pop in-decl-item))) 200 | 201 | (defmacro prepare-blocker-stacks (node-class) 202 | "create method which prepares decl-blocker stacks" 203 | `(defmethod traverser :before ((db decl-blocker) (item ,node-class) level) 204 | "prepare empty decl-blocker stacks and values" 205 | (declare (ignore level)) 206 | (with-slots (names) db 207 | (push (make-hash-table) names)))) 208 | 209 | (defmacro clean-blocker-stacks (node-class) 210 | "creates method which cleans decl-blocker stacks" 211 | `(defmethod traverser :after ((db decl-blocker) (item ,node-class) level) 212 | "clean up decl-blocker stack and values" 213 | (declare (ignore level)) 214 | (with-slots (names) db 215 | (pop names)))) 216 | 217 | (defmacro decl-blocker-extra-nodes (&rest nodes) 218 | `(progn .,(loop for i in nodes collect 219 | `(progn (eval (prepare-blocker-stacks ,i)) 220 | (eval (clean-blocker-stacks ,i)))))) 221 | 222 | (decl-blocker-extra-nodes function-definition struct-definition for-statement compound-statement) 223 | 224 | ;;; This traverser hides "{}" in ifs where possible 225 | (defclass if-blocker () 226 | ((parent-node :initform '()) 227 | (statement-count :initform '(0)) 228 | (first-statement :initform '(nil)) 229 | (self-else :initform '(nil)) 230 | (child-else :initform '(nil)) 231 | (force-braces :initform '(nil)) 232 | (curr-level :initform '()))) 233 | 234 | 235 | (with-proxynodes (if-proxy else-proxy) 236 | "use proxy nodes for if and else body in if-statements" 237 | 238 | (defmethod traverser :before ((ib if-blocker) (item if-statement) level) 239 | "add proxy-node to if- and else-body; add stack infos; check nested-if" 240 | (declare (ignore level)) 241 | (with-slots (if-body else-body) item 242 | (with-slots (self-else child-else) ib 243 | (if else-body 244 | (progn 245 | (make-proxy else-body else-proxy) 246 | (push t self-else) 247 | (setf (first child-else) t)) 248 | (progn 249 | (push nil self-else) 250 | (setf (first child-else) nil))) 251 | (push 'unknown child-else) ;;handled like t, better debug-output 252 | (make-proxy if-body if-proxy)))) 253 | 254 | (defmethod traverser :after ((ib if-blocker) (item if-statement) level) 255 | "clean up proxy-nodes and stack" 256 | (declare (ignore level)) 257 | (with-slots (if-body else-body) item 258 | (with-slots (self-else child-else) ib 259 | (del-proxy if-body) 260 | (if else-body 261 | (del-proxy else-body)) 262 | (pop child-else) 263 | (pop self-else)))) 264 | 265 | (defproxymethod :before (ib if-blocker) if-proxy 266 | "push 'if-body info on stack" 267 | (with-slots (parent-node) ib 268 | (push 'if-body parent-node))) 269 | 270 | (defproxymethod :after (ib if-blocker) if-proxy 271 | "pop stack" 272 | (with-slots (parent-node) ib 273 | (pop parent-node))) 274 | 275 | (defproxymethod :before (ib if-blocker) else-proxy 276 | "push 'else-body info on stack" 277 | (with-slots (parent-node) ib 278 | (push 'else-body parent-node))) 279 | 280 | (defproxymethod :after (ib if-blocker) else-proxy 281 | "pop stack" 282 | (with-slots (parent-node) ib 283 | (pop parent-node))) 284 | ) 285 | 286 | (defmethod traverser :before ((ib if-blocker) (item compound-statement) level) 287 | "prepare stacks, count statements" 288 | (with-slots (parent-node statement-count first-statement force-braces curr-level) ib 289 | (with-slots (statements) item 290 | (push level curr-level) 291 | (push t first-statement) 292 | (push 'compound-statement parent-node) 293 | (push nil force-braces) 294 | (push 0 statement-count)))) 295 | 296 | (defmethod traverser :after ((ib if-blocker) (item compound-statement) level) 297 | "decide wheter to print braces or not" 298 | (with-slots (parent-node statement-count first-statement 299 | self-else child-else force-braces curr-level) ib 300 | (with-slots (statement braces) item 301 | (pop parent-node) 302 | (pop curr-level) 303 | 304 | (cond ((eql (first parent-node) 'if-body) 305 | 306 | (cond ((and (< (first statement-count) 2) 307 | (not (first self-else))) 308 | (setf braces nil)) 309 | ((and (< (first statement-count) 2) 310 | (first self-else) 311 | (first child-else)) 312 | (setf braces nil)))) 313 | 314 | ((eql (first parent-node) 'else-body) 315 | (if (< (first statement-count) 2) 316 | (setf braces nil)))) 317 | 318 | (if (first force-braces) 319 | (setf braces t)) 320 | (pop statement-count) 321 | (pop first-statement) 322 | (pop force-braces)))) 323 | 324 | (defmethod traverser :after ((ib if-blocker) (item comment) level) 325 | "force braces if comments are present / important for solitary comments" 326 | (declare (ignore level)) 327 | (with-slots (force-braces) ib 328 | (setf (first force-braces) t))) 329 | 330 | (defmethod traverser :before ((ib if-blocker) (item declaration-list) level) 331 | "set force-braces (to t) if declartion-list found" 332 | (declare (ignore level)) 333 | (with-slots (force-braces) ib 334 | (if force-braces 335 | (setf (first force-braces) t)))) 336 | 337 | (defmethod traverser :before ((ib if-blocker) (item nodelist) level) 338 | "check nodelists that belong to a compound-statement" 339 | (with-slots (statement-count first-statement parent-node curr-level) ib 340 | (with-slots (nodes) item 341 | (when (and (first first-statement) 342 | (eql (first parent-node) 'compound-statement) 343 | (eql (- level (first curr-level)) 2)) 344 | 345 | (let ((count (length nodes))) 346 | (setf (first first-statement) nil) 347 | (setf (first statement-count) 348 | (max count (first statement-count)))))))) 349 | 350 | 351 | (defmethod traverser :after ((ib if-blocker) (item expression-statement) level) 352 | "place semicolon at empty branches" 353 | (with-slots (statement-count curr-level force-braces) ib 354 | (with-slots (force-semicolon expression) item 355 | (if (and 356 | ;; subnode that can contain no further statements 357 | (typep expression 'nodelist) 358 | ;; do nothing if a comment is present, see above (if-blocker comment) 359 | (not (eql (first force-braces) t)) 360 | ;; specific position in ast, 1st expr-statement in body. 361 | (and (first curr-level) ;; curr-level must be set 362 | (eql (- level (first curr-level)) 1)) 363 | ;; subtree has no expressions 364 | ;; this is a :after method, statement-cound already filled 365 | (eql (first statement-count) 0)) 366 | (setf force-semicolon t))))) 367 | 368 | 369 | ;;; This traveser removes ambiguous nested compound-statements in else-if 370 | ;;; to reduce indentation. 371 | (defclass else-if-traverser ()()) 372 | (with-proxynodes (else-if-proxy) 373 | "use proxy nodes for else-if occurences" 374 | 375 | (defmethod traverser :before ((eit else-if-traverser) (item if-statement) level) 376 | "add else-if-proxy to else-body" 377 | (declare (ignore level)) 378 | (with-slots (else-body) item 379 | (if else-body 380 | (make-proxy else-body else-if-proxy)))) 381 | 382 | (defmethod traverser :after ((eit else-if-traverser) (item if-statement) level) 383 | "clean up proxy nodes (else-if-proxy" 384 | (declare (ignore level)) 385 | (with-slots (else-body) item 386 | (if else-body 387 | (del-proxy else-body)))) 388 | 389 | (defproxymethod :before (eit else-if-traverser) else-if-proxy 390 | "check if only one single if-statement is present in else-body and remove compound-statement node" 391 | (with-slots (proxy-subnode) item 392 | (let ((subnode (slot-value (slot-value proxy-subnode 'statements) 'expression))) 393 | (when (typep subnode 'if-statement) 394 | (setf proxy-subnode subnode)))))) 395 | 396 | ;;; Remove nested nodelists (progn (progn (progn ...))) 397 | ;;; Required for proper placement of curly braces (esp. for if-else) 398 | (defclass nested-nodelist-remover ()()) 399 | (defmethod traverser :after ((nnr nested-nodelist-remover) (item nodelist) level) 400 | (with-slots (nodes) item 401 | (when (and (eql (length nodes) 1) 402 | (typep (first nodes) 'expression-statement) 403 | (typep (slot-value (first nodes) 'expression) 'nodelist)) 404 | (setf nodes (slot-value (slot-value (first nodes) 'expression) 'nodes))))) 405 | 406 | 407 | 408 | -------------------------------------------------------------------------------- /src/c/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Some helper functions 2 | 3 | (in-package :cm-c) 4 | 5 | (defun fix-case (parent child) 6 | "Fix case for dissected symbols. 7 | Required because of our inverted readtable." 8 | ;; check every single character's case 9 | (macrolet ((case-test (test string) 10 | `(eval `(and ,@(mapcar (lambda(x) (or (not (both-case-p x)) 11 | (,test x))) 12 | (coerce ,string 'list))))) 13 | (special-case (string) 14 | `(eval `(and ,@(mapcar (lambda(x) (not (both-case-p x))) 15 | (coerce ,string 'list)))))) 16 | (let 17 | ;; parent upper 18 | ((pu (case-test upper-case-p parent)) 19 | ;; parent lower 20 | (pl (case-test lower-case-p parent)) 21 | ;; child upper 22 | (cu (case-test upper-case-p child)) 23 | ;; child lower 24 | (cl (case-test lower-case-p child)) 25 | ;; child special 26 | (cs (special-case child))) 27 | ;; adjust cases 28 | (let ((parent 29 | ;; fix parent case if root symbol had mixed case 30 | (cond 31 | ;; special cases 32 | ((and pu cs) (intern (string-upcase parent))) 33 | ((and pl cs) (intern (string-downcase parent))) 34 | ;; parend upper case 35 | ;; child lower or mixed case 36 | ((or (and pu cl) (and pu (not (or cu cl)))) 37 | (intern (string-downcase parent))) 38 | ;; parent lower case 39 | ;; child upper or mixed case 40 | ((or (and pl cu) (and pl (not (or cu cl)))) 41 | (intern (string-upcase parent))) 42 | ;; default 43 | (t (intern parent)))) 44 | ;; fix child case if root symbol had mixed case 45 | (child 46 | (cond 47 | ;; child lower case 48 | ;; parent upper or mixed case 49 | ((or (and pu cl) (and (not (or pu pl)) cl)) 50 | (intern (string-upcase child))) 51 | ;; child upper case 52 | ;; parent loer or mixed case 53 | ((or (and pl cu) (and (not (or pu pl)) cu)) 54 | (intern (string-downcase child))) 55 | ;; default 56 | (t (intern child))))) 57 | (list parent child))))) 58 | -------------------------------------------------------------------------------- /src/cuda/cm-cuda.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-cuda) 2 | 3 | ;; Define a c-mera file reader with extra macro characters 4 | (define-reader 5 | :file-reader read-in-file 6 | :string-reader read-in-string 7 | :macro-character 8 | ((set-macro-character #\Space #'cm-c++::pre-process) 9 | (set-macro-character #\Tab #'cm-c++::pre-process) 10 | (set-macro-character #\Newline #'cm-c++::pre-process) 11 | (set-macro-character #\( #'cm-c++::pre-process-heads) 12 | (set-macro-character #\{ #'cm-c++::left-brace-reader) 13 | (set-macro-character #\} (get-macro-character #\) nil)) 14 | (set-dispatch-macro-character #\# #\: #'cm-c++::sharp-colon-reader))) 15 | 16 | ;; Define a start-up function 17 | (define-processor 18 | :name cuda-processor 19 | :file-reader read-in-file 20 | :string-reader read-in-string 21 | :extra-traverser 22 | (nested-nodelist-remover 23 | else-if-traverser 24 | if-blocker 25 | decl-blocker 26 | renamer)) 27 | 28 | ;; Define a save function 29 | (save-generator 30 | :name save 31 | :start-function cuda-processor 32 | :in-package :cmu-cuda) 33 | 34 | ;;; Define a reader switch with c++ pre-processing 35 | (define-switch 36 | :name switch-reader 37 | :macro-character 38 | ((set-macro-character #\Space #'cm-c++::pre-process) 39 | (set-macro-character #\Tab #'cm-c++::pre-process) 40 | (set-macro-character #\Newline #'cm-c++::pre-process) 41 | (set-macro-character #\( #'cm-c++::pre-process-heads) 42 | (set-macro-character #\{ #'cm-c++::left-brace-reader) 43 | (set-macro-character #\} (get-macro-character #\) nil)) 44 | (set-dispatch-macro-character #\# #\: #'cm-c++::sharp-colon-reader))) 45 | 46 | (define-switches 47 | :cl-reader cl-reader 48 | :cm-reader cm-reader 49 | :macro-character 50 | ((set-macro-character #\Space #'cm-c++::pre-process) 51 | (set-macro-character #\Tab #'cm-c++::pre-process) 52 | (set-macro-character #\Newline #'cm-c++::pre-process) 53 | (set-macro-character #\( #'cm-c++::pre-process-heads) 54 | (set-macro-character #\{ #'cm-c++::left-brace-reader) 55 | (set-macro-character #\} (get-macro-character #\) nil)) 56 | (set-dispatch-macro-character #\# #\: #'cm-c++::sharp-colon-reader))) 57 | -------------------------------------------------------------------------------- /src/cuda/nodes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-cuda) 2 | 3 | (defstatement cuda-funcall () (name blocks threads shared)) 4 | (defnode cuda-alignment () (size name)) 5 | -------------------------------------------------------------------------------- /src/cuda/pretty.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-cuda) 2 | 3 | ;;; ======================== 4 | ;;; cuda pretty printing 5 | ;;; ========================= 6 | 7 | (with-pp 8 | (with-proxynodes (arrow-bracket comma) 9 | 10 | (defprettymethod :before cuda-funcall 11 | (make-proxy blocks arrow-bracket) 12 | (make-proxy threads comma) 13 | (when (node-slot shared) 14 | (make-proxy shared comma))) 15 | 16 | (defprettymethod :after cuda-funcall 17 | (del-proxy blocks) 18 | (del-proxy threads) 19 | (when (node-slot shared) 20 | (del-proxy shared)) 21 | (format stream ">>>")) 22 | 23 | (defproxyprint :before arrow-bracket 24 | (format stream "<<<")) 25 | 26 | (defproxyprint :before comma 27 | (format stream ", ")))) 28 | 29 | 30 | (with-pp 31 | (with-proxynodes (size) 32 | 33 | (defprettymethod :before cuda-alignment 34 | (make-proxy size size) 35 | (format stream "__align__(")) 36 | 37 | (defprettymethod :after cuda-alignment 38 | (del-proxy size)) 39 | 40 | (defproxyprint :after size 41 | (format stream ") ")))) 42 | -------------------------------------------------------------------------------- /src/cuda/syntax.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-cuda) 2 | 3 | (defmacro cuda-syntax (tags lambda-list &body body) 4 | `(defsyntax ,tags (:cmu-cuda) ,lambda-list ,@body)) 5 | 6 | (cuda-syntax launch (kernel (&key blocks threads shared) &rest args) 7 | "Launch cuda kernels" 8 | `(function-call 9 | ;; put block threads an shard in name slot 10 | (cuda-funcall 11 | ;; kernel name 12 | (make-node ,kernel) 13 | ;; grid config 14 | (make-node ,blocks) 15 | ;; block config 16 | (make-node ,threads) 17 | ;; shared mem 18 | ,(when shared 19 | `(make-node ,shared))) 20 | ;; function agrs 21 | (make-nodelist ,args))) 22 | 23 | (cuda-syntax struct (name alignment &body body) 24 | "Struct with alignment" 25 | `(struct-definition 26 | ;; put name an alignment in name slot 27 | (cuda-alignment 28 | (make-node ,alignment) 29 | (make-node ,name)) 30 | ;; struct body 31 | (compound-statement 32 | ;; curly braces: t 33 | t 34 | ;; build subnodes 35 | (make-nodelist ,body)))) 36 | 37 | 38 | (build-context-switches 39 | :user-package :cmu-cuda 40 | :symbols cuda-symbols) 41 | 42 | (build-swap-package 43 | :user-package :cmu-cuda 44 | :swap-package :cms-cuda 45 | :symbols cuda-swap) 46 | -------------------------------------------------------------------------------- /src/cxx/cm-cxx.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c++) 2 | 3 | ;; Define a c-mera file reader with extra macro characters 4 | (define-reader 5 | :file-reader read-in-file 6 | :string-reader read-in-string 7 | :macro-character 8 | ((set-macro-character #\Space #'pre-process) 9 | (set-macro-character #\Tab #'pre-process) 10 | (set-macro-character #\Newline #'pre-process) 11 | (set-macro-character #\( #'pre-process-heads) 12 | (set-macro-character #\{ #'left-brace-reader) 13 | (set-macro-character #\} (get-macro-character #\) nil)) 14 | (set-dispatch-macro-character #\# #\: #'sharp-colon-reader))) 15 | 16 | ;; Define a start-up function 17 | (define-processor 18 | :name cxx-processor 19 | :file-reader read-in-file 20 | :string-reader read-in-string 21 | :extra-traverser 22 | (nested-nodelist-remover 23 | else-if-traverser 24 | if-blocker 25 | decl-blocker 26 | renamer 27 | virtualizer 28 | access-respecifier 29 | )) 30 | 31 | ;; Define a save function 32 | (save-generator 33 | :name save 34 | :start-function cxx-processor 35 | :in-package :cmu-c++) 36 | 37 | ;;; Define a reader switch with c++ pre-processing 38 | (define-switch 39 | :name switch-reader 40 | :macro-character 41 | ((set-macro-character #\Space #'pre-process) 42 | (set-macro-character #\Tab #'pre-process) 43 | (set-macro-character #\Newline #'pre-process) 44 | (set-macro-character #\( #'pre-process-heads) 45 | (set-macro-character #\{ #'left-brace-reader) 46 | (set-macro-character #\} (get-macro-character #\) nil)) 47 | (set-dispatch-macro-character #\# #\: #'sharp-colon-reader))) 48 | 49 | (define-switches 50 | :cl-reader cl-reader 51 | :cm-reader cm-reader 52 | :macro-character 53 | ((set-macro-character #\Space #'pre-process) 54 | (set-macro-character #\Tab #'pre-process) 55 | (set-macro-character #\Newline #'pre-process) 56 | (set-macro-character #\( #'pre-process-heads) 57 | (set-macro-character #\{ #'left-brace-reader) 58 | (set-macro-character #\} (get-macro-character #\) nil)) 59 | (set-dispatch-macro-character #\# #\: #'sharp-colon-reader))) 60 | -------------------------------------------------------------------------------- /src/cxx/cmu-cxx.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cmu-c++) 2 | 3 | (macrolet ((define-cast (command) 4 | `(defmacro ,command (&rest T-and-obj) 5 | `(funcall (instantiate ,',command ,(butlast T-and-obj)) ,(car (last T-and-obj)))))) 6 | "C++ cast operators" 7 | (define-cast dynamic-cast) 8 | (define-cast static-cast) 9 | (define-cast reinterpret-cast) 10 | (define-cast const-cast)) 11 | 12 | (defmacro for-each ((name container &key (iterator (gensym "ITERATOR"))) &body body) 13 | "Range-based iterator" 14 | `(for ((auto ,iterator = (funcall (oref ,container begin))) 15 | (!= ,iterator (funcall (oref ,container end))) 16 | (prefix++ ,iterator)) 17 | (decl ((auto ,name = (dref ,iterator))) 18 | ,@body))) 19 | -------------------------------------------------------------------------------- /src/cxx/nodes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c++) 2 | 3 | ;;; ==================== 4 | ;;; c++ nodes 5 | ;;; ==================== 6 | 7 | (defnode superclass () (attribute superclass)) 8 | (defnode declaration-list-initializer () (list-items)) 9 | (defnode function-definition (pure virtual) (item parameter tail-qualifiers body)) 10 | 11 | (defstatement class () (name superclasses body)) 12 | (defstatement constructor () (name parameter initializer body)) 13 | (defstatement destructor (virtual) (name body)) 14 | (defstatement access-specifier (specifier) (body)) 15 | (defstatement namespace () (namespace body)) 16 | (defstatement using-namespace () (namespace)) 17 | (defstatement using () (item)) 18 | (defstatement template () (parameters body)) 19 | (defstatement try-block () (body catches)) 20 | (defstatement catch (all) (decl-item body)) 21 | 22 | (defexpression from-namespace () (namespace name)) 23 | (defexpression instantiate () (template arguments)) 24 | (defexpression instantiate-explicit () (item)) 25 | (defexpression new (operator) (specifier type)) 26 | (defexpression delete (operator) (object)) 27 | (defexpression lambda-definition () (capture parameter tail-qualifiers type body)) 28 | -------------------------------------------------------------------------------- /src/cxx/pretty.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c++) 2 | 3 | ;;; ============================= 4 | ;;; cm-c pretty printing override 5 | ;;; ============================= 6 | 7 | ;; override function declaration 8 | ;; - empty parameter list from "(void)" to "()" 9 | ;; - move parameter parentheses to proxy-node 10 | ;; - emit ';' if body is set-node -> pure-virtual 11 | (with-pp 12 | (with-proxynodes (parameters parameter) 13 | 14 | ;; Begin new line and add proxy-nodes. 15 | (defprettymethod :before function-definition 16 | (make-proxy parameter parameters) 17 | (cond 18 | ((eql (top-info) 'template) (format stream "~&")) 19 | ((eql (top-info) 'template-explicit)) ; do nothing 20 | (t (format stream "~&~%"))) 21 | (push-info 'function-definition) 22 | (format stream "~a" indent) 23 | (if (node-slot virtual) 24 | (format stream "virtual "))) 25 | 26 | ;; Remove temporary proxy-nodes 27 | (defprettymethod :after function-definition 28 | (del-proxy parameter) 29 | (pop-info) 30 | (when (or (not (node-slot body)) 31 | (typep (node-slot body) 'assignment-expression)) 32 | (format stream ";"))) 33 | 34 | ;; Begin parameter-list. 35 | (defproxyprint :before parameters 36 | (format stream "(")) 37 | 38 | ;; Close parameter-list. 39 | (defproxyprint :after parameters 40 | (format stream ")") 41 | (when (slot-value parent 'tail-qualifiers) 42 | (format stream " "))) 43 | 44 | ;; Handle parameters 45 | ;; Add proxy-node and info-token. 46 | (defprettymethod :before parameter-list 47 | (push-sign 'skip-first-parameter) 48 | (make-proxy parameters parameter)) 49 | 50 | ;; Remove proxy node 51 | (defprettymethod :after parameter-list 52 | (del-proxy parameters) 53 | (when (eql (top-sign) 'skip-first-parameter) 54 | (pop-sign))) 55 | 56 | ;; Print parameters 57 | (defproxyprint :before parameter 58 | (if (eql (top-sign) 'skip-first-parameter) 59 | (pop-sign) 60 | (format stream ", "))))) 61 | 62 | ;;; list initializer 63 | (with-pp 64 | (with-proxynodes (value) 65 | 66 | (defprettymethod :before declaration-list-initializer 67 | (make-proxy list-items value) 68 | (push-sign 'skip-first-list-init) 69 | (format stream " { ")) 70 | 71 | (defprettymethod :after declaration-list-initializer 72 | (when (eql (top-sign) 'skip-first-list-init) 73 | (pop-sign)) 74 | (del-proxy list-items) 75 | (format stream " }")) 76 | 77 | (defproxyprint :before value 78 | (if (eql (top-sign) 'skip-first-list-init) 79 | (pop-sign) 80 | (format stream ", "))))) 81 | 82 | 83 | 84 | ;; Override c type 85 | 86 | ;; suppressses clozure warnings 87 | (delprettymethod :after type) 88 | 89 | ;; omit whitespace 90 | (with-pp 91 | 92 | (defprettymethod :after type 93 | (let ((info (top-info))) 94 | (when (and (node-slot type) 95 | (not (eql info 'cast-expression)) 96 | (not (eql info 'funcall)) 97 | (not (eql info 'declaration-item)) 98 | ;; extra: 99 | (not (eql info 'template-instantiation))) 100 | (format stream " "))))) 101 | 102 | 103 | ;; Override for-loop / support 'foreach' 104 | (with-pp 105 | (with-proxynodes (common-init default-init foreach-init test step container) 106 | 107 | (defprettymethod :before for-statement 108 | (push-info 'for) 109 | (make-proxy init common-init) ;; common init 110 | (if (node-slot step) 111 | (progn ;; default for-loop 112 | (make-proxy init default-init) 113 | (make-proxy test test) 114 | (make-proxy step step)) 115 | (progn ;; foreach 116 | (make-proxy init foreach-init) 117 | (make-proxy test container)))) 118 | 119 | (defprettymethod :after for-statement 120 | (pop-info) 121 | (del-proxy init) ;; default-init / foreach-init 122 | (del-proxy init) ;; common init 123 | (del-proxy test) 124 | (when (node-slot step) 125 | (del-proxy step))) 126 | 127 | (defproxyprint :before common-init 128 | (format stream "~&~afor(" indent)) 129 | 130 | (defproxyprint :after default-init 131 | (format stream "; ")) 132 | 133 | (defproxyprint :after foreach-init 134 | (format stream " : ")) 135 | 136 | (defproxyprint :after test 137 | (format stream "; ")) 138 | 139 | (defproxyprint :after container 140 | (format stream ")")) 141 | 142 | (defproxyprint :before step 143 | (push-info 'for-head)) 144 | 145 | (defproxyprint :after step 146 | (pop-info) 147 | (format stream ")")))) 148 | 149 | 150 | 151 | ;;; =================== 152 | ;;; c++ pretty printing 153 | ;;; =================== 154 | 155 | ;;; class 156 | (with-pp 157 | (with-proxynodes (attribute) 158 | 159 | (defprettymethod :before class 160 | (push-sign 'first-superclass) 161 | (cond 162 | ((eql (top-info) 'template) (format stream "~&")) 163 | ((eql (top-info) 'template-explicit)) ; do nothing 164 | (t (format stream "~&~%"))) 165 | (format stream "~aclass " indent)) 166 | 167 | (defprettymethod :after class 168 | (if (eql (top-sign) 'first-superclass) 169 | (pop-sign)) 170 | (format stream ";")) 171 | 172 | (defprettymethod :before superclass 173 | (make-proxy attribute attribute) 174 | (if (eql (top-sign) 'first-superclass) 175 | (progn (pop-sign) 176 | (format stream " : ")) 177 | (format stream ", "))) 178 | 179 | (defproxyprint :after attribute 180 | (format stream " ")) 181 | 182 | (defprettymethod :self access-specifier 183 | (let ((spec (node-slot specifier))) 184 | (when spec 185 | --indent 186 | (format stream "~&~a~a:" indent spec) 187 | ++indent))))) 188 | 189 | ;; constructor 190 | (with-pp 191 | (with-proxynodes (initializer parameters) 192 | 193 | (defprettymethod :before constructor 194 | (when (node-slot initializer) 195 | (make-proxy initializer initializer)) 196 | (make-proxy parameter parameters) 197 | (push-sign 'first-initializer) 198 | (format stream "~&~%~a" indent)) 199 | 200 | (defprettymethod :after constructor 201 | (when (node-slot initializer) 202 | (del-proxy initializer)) 203 | (del-proxy parameter) 204 | (when (eql (top-sign) 'first-initializer) 205 | (pop-sign)) 206 | (when (not (node-slot body)) 207 | (format stream ";"))) 208 | 209 | (defproxyprint :before parameters 210 | (format stream "(")) 211 | 212 | (defproxyprint :after parameters 213 | (format stream ")")) 214 | 215 | (defproxyprint :before initializer 216 | (push-info 'initializer) 217 | (if (eql (top-sign) 'first-initializer) 218 | (progn 219 | (pop-sign) 220 | (format stream "~&~a: " indent)) 221 | (format stream ", "))) 222 | 223 | (defproxyprint :after initializer 224 | (pop-info)))) 225 | 226 | ;; destructor 227 | (with-pp 228 | (with-proxynodes (name) 229 | 230 | (defprettymethod :before destructor 231 | (format stream "~&~%~a" indent) 232 | (when (node-slot virtual) 233 | (format stream "virtual ")) 234 | (when (typep (node-slot name) 'identifier) 235 | (format stream "~~")) 236 | (make-proxy name name) 237 | (push-info 'destructor)) 238 | 239 | (defprettymethod :after destructor 240 | (del-proxy name) 241 | (when (not (node-slot body)) 242 | (format stream ";"))) 243 | 244 | (defproxyprint :after name 245 | (pop-info) 246 | (format stream "()")))) 247 | 248 | 249 | (with-pp 250 | 251 | (defprettymethod :before using 252 | (format stream "~&~ausing " indent)) 253 | 254 | (defprettymethod :after using 255 | (format stream ";~%"))) 256 | 257 | (with-pp 258 | 259 | (defprettymethod :before using-namespace 260 | (format stream "~&~ausing namespace " indent)) 261 | 262 | (defprettymethod :after using-namespace 263 | (format stream ";~%"))) 264 | 265 | (with-pp 266 | 267 | (defprettymethod :before new 268 | (format stream "~a " (node-slot operator)))) 269 | 270 | (with-pp 271 | 272 | (defprettymethod :before delete 273 | (format stream "~&~a~a " indent (node-slot operator))) 274 | (defprettymethod :after delete 275 | (format stream ";~%"))) 276 | 277 | 278 | (with-pp 279 | 280 | (defprettymethod :before namespace 281 | (format stream "~&~anamespace " indent))) 282 | 283 | (with-pp 284 | (with-proxynodes (name) 285 | 286 | (defprettymethod :before from-namespace 287 | (make-proxy name name)) 288 | 289 | (defprettymethod :after from-namespace 290 | (del-proxy name)) 291 | 292 | (defproxyprint :before name 293 | (format stream "::") 294 | ;; tilde for destructors, 295 | ;; info set in destructor prettymethod 296 | (when (eql (top-info) 'destructor) 297 | (format stream "~~"))))) 298 | 299 | (with-pp 300 | (with-proxynodes (parameters) 301 | 302 | (defprettymethod :before template 303 | (push-info 'template) 304 | (make-proxy parameters parameters) 305 | (format stream "~&~%~atemplate " indent)) 306 | 307 | (defprettymethod :after template 308 | (pop-info) 309 | (del-proxy parameters)) 310 | 311 | (defproxyprint :before parameters 312 | (format stream "<")) 313 | 314 | (defproxyprint :after parameters 315 | (format stream ">")))) 316 | 317 | (with-pp 318 | (with-proxynodes (template arguments) 319 | 320 | (defprettymethod :before instantiate 321 | (push-info 'template-instantiation) 322 | (push-sign 'skip-first-template) 323 | (make-proxy template template) 324 | (make-proxy arguments arguments)) 325 | 326 | (defprettymethod :after instantiate 327 | (del-proxy template) 328 | (del-proxy arguments) 329 | (pop-info) 330 | (when (eql (top-sign) 'skip-first-template) 331 | (pop-sign)) 332 | (format stream ">")) 333 | 334 | (defproxyprint :after template 335 | (format stream "<")) 336 | 337 | (defproxyprint :before arguments 338 | (if (eql (top-sign) 'skip-first-template) 339 | (pop-sign) 340 | (format stream ", "))))) 341 | 342 | (with-pp 343 | (defprettymethod :before instantiate-explicit 344 | (push-info 'template-explicit) 345 | (format stream "~&template ")) 346 | (defprettymethod :after instantiate-explicit 347 | (pop-info))) 348 | 349 | 350 | (with-pp 351 | (defprettymethod :before try-block 352 | (format stream "~&~atry" indent))) 353 | 354 | 355 | (with-pp 356 | (with-proxynodes (decl-item) 357 | 358 | (defprettymethod :before catch 359 | (format stream "~&~acatch (" indent) 360 | (if (node-slot all) 361 | (format stream "...")) 362 | (make-proxy decl-item decl-item)) 363 | 364 | (defproxyprint :after decl-item 365 | (format stream ")")) 366 | 367 | (defprettymethod :after catch 368 | (del-proxy decl-item)))) 369 | 370 | 371 | ;; Lambda function // quite similar to function-definition 372 | (with-pp 373 | (with-proxynodes (captures parameters type) 374 | 375 | ;; Begin new line and add proxy-nodes. 376 | (defprettymethod :before lambda-definition 377 | (make-proxy parameter parameters) 378 | (make-proxy capture captures) 379 | (when (node-slot type) 380 | (make-proxy type type)) 381 | ++indent) 382 | 383 | ;; Remove temporary proxy-nodes 384 | (defprettymethod :after lambda-definition 385 | (del-proxy parameter) 386 | (del-proxy capture) 387 | (when (node-slot type) 388 | (del-proxy type)) 389 | --indent) 390 | 391 | ;; Begin capture-list 392 | (defproxyprint :before captures 393 | (if (or (eql (top-sign) 'skip-first-funcall) 394 | (eql (top-info) 'declaration-item)) 395 | (format stream "[") 396 | (format stream "~&~a[" indent))) 397 | 398 | ;; Close capture-list 399 | (defproxyprint :after captures 400 | (format stream "]")) 401 | 402 | ;; Begin parameter-list. 403 | (defproxyprint :before parameters 404 | (format stream "(")) 405 | 406 | ;; Close parameter-list. 407 | (defproxyprint :after parameters 408 | (format stream ")") 409 | (when (slot-value parent 'tail-qualifiers) 410 | (format stream " "))) 411 | 412 | ;; individual parameters already handled by function-definition 413 | ;; i.e. parameter-list and paramter 414 | 415 | ;; Print "->" 416 | (defproxyprint :before type 417 | (when (not (slot-value parent 'tail-qualifiers)) 418 | (format stream " ")) 419 | (format stream "-> ")))) 420 | 421 | 422 | 423 | -------------------------------------------------------------------------------- /src/cxx/reader.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c++) 2 | 3 | (defun dissect (item &key (quoty nil)) 4 | "extended c pre processor" 5 | (if (symbolp item) 6 | (cond ((or (eql item 'cmu-c++::new[]) 7 | (eql item 'cmu-c++::delete[]) 8 | (eql item 'cmu-c++::operator[])) 9 | item) 10 | ((and (> (length (symbol-name item)) 1) 11 | (not (eql (first (coerce (symbol-name item) 'list)) #\&)) 12 | (eql (first (reverse (coerce (symbol-name item) 'list))) #\&)) 13 | (split-reference item)) 14 | (t (cm-c::dissect item :quoty quoty))) 15 | (cm-c::dissect item :quoty quoty))) 16 | 17 | (defun split-reference (item) 18 | (let* ((name (symbol-name item)) 19 | (len (length name))) 20 | `(cmu-c++::reference-type ,(dissect (intern (subseq name 0 (- len 1))) :quoty t)))) 21 | 22 | ;; copy of c reader 23 | (defun pre-process (stream char) 24 | "Pre process symbols in stream and prepare actual node" 25 | (declare (ignore char)) 26 | (let ((peek (peek-char nil stream nil nil nil))) 27 | ;; skip multiple whitespace and comments 28 | (if (not (or (eql peek #\)) 29 | (eql peek #\;) 30 | (eql peek #\#) 31 | (eql peek #\}) 32 | (eql peek #\{) 33 | (eql peek #\Space) 34 | (eql peek #\Newline) 35 | (eql peek #\Tab))) 36 | (dissect (read stream nil nil nil)) 37 | (values)))) 38 | 39 | ;; copy of c reader 40 | (defun pre-process-heads (stream char) 41 | "Pre process list heads and prepare nodes" 42 | (declare (ignore char)) 43 | (let ((peek (peek-char nil stream nil nil nil)) 44 | (list (read-delimited-list #\) stream t))) 45 | (let ((first (first list))) 46 | ;; stop at whitespace and comments 47 | (if (not (or (eql peek #\() 48 | (eql peek #\)) 49 | (eql peek #\}) 50 | (eql peek #\{) 51 | (eql peek #\;) 52 | (eql peek #\#) 53 | (eql peek #\Space) 54 | (eql peek #\Newline) 55 | (eql peek #\Tab) 56 | (and (symbolp first) 57 | (fboundp! first)))) 58 | (append (list (dissect first)) (rest list)) 59 | list)))) 60 | 61 | 62 | (defun sharp-colon-reader (stream c1 c2) 63 | (declare (ignore c1 c2)) 64 | (flet ((valid-id-char (c) 65 | (not (or (char= #\( c) 66 | (char= #\) c) 67 | (char= #\} c) 68 | (char= #\{ c) 69 | (char= #\; c) 70 | (char= #\Space c) 71 | (char= #\Newline c) 72 | (char= #\Tab c))))) 73 | ;; accumulation target 74 | (let ((str (make-array 0 :element-type 'character 75 | :fill-pointer 0 76 | :adjustable t))) 77 | ;; read char-by-char, unread terminating char 78 | (loop for c = (read-char-no-hang stream) 79 | then (read-char-no-hang stream) 80 | while (valid-id-char c) 81 | do (vector-push-extend c str) 82 | finally (unread-char c stream)) 83 | ;; build fn-form by parsing the read string 84 | (let* ((raw-items 85 | ;; collect namespaces and skip ":" and "::" 86 | (loop for s in (loop for i = 0 then (1+ j) 87 | as j = (position #\: str :start i) 88 | collect (subseq str i j) 89 | while j) 90 | if (string/= s "") 91 | collect (dissect (cintern s) :quoty t))) 92 | ;; add a 'nil' if no namespace defined -> global scope 93 | (fixed-items (if (second raw-items) 94 | raw-items 95 | `(nil ,@raw-items)))) 96 | `(cmu-c++::from-namespace ,@fixed-items))))) 97 | 98 | (defun left-brace-reader (stream char) 99 | "Read cxx initializer list '{...}' and emit double list '((...))'" 100 | (declare (ignore char)) 101 | (let ((init-list (read-delimited-list #\} stream t))) 102 | (let ((first (car init-list)) 103 | (rest (rest init-list))) 104 | (list (list (append (list (dissect first)) rest)))))) 105 | -------------------------------------------------------------------------------- /src/cxx/syntax.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c++) 2 | 3 | ;;; ================= 4 | ;;; c++ syntax 5 | ;;; ================= 6 | 7 | (defmacro c++syntax (tags lambda-list &body body) 8 | `(defsyntax ,tags (:cmu-c++) ,lambda-list ,@body)) 9 | 10 | (defmacro decompose-superclass (item) 11 | ;; build superclass node 12 | `(superclass 13 | ;; access specifier 14 | (make-node ,(first item)) 15 | ;; class name 16 | (make-node ,(second item)))) 17 | 18 | (defmacro decompose-initializer (item) 19 | ;; build initalizer calls 20 | `(funcall 21 | ;; initializer name 22 | (make-node ,(first item)) 23 | ;; initialize with 24 | (make-node ,(second item)))) 25 | 26 | (defun decompose-declaration (item) 27 | "Decompose initializer list / quite like declaration item. The last 28 | value returnd specifies if the declaration actually used an 29 | initializer list or not." 30 | ;; check if initialization is present 31 | (let ((val (first (last item)))) 32 | (if (and (listp val) 33 | (eql (length val) 1) 34 | (listp (car val)) 35 | (eql (length (car val)) 1) 36 | (listp (caar val))) 37 | ;; decompose arg list with list initializer 38 | (let ((spec+type+id (butlast item)) 39 | (inits (caar val))) 40 | (let ((specifier (butlast spec+type+id 2)) 41 | (type+id (last spec+type+id 2))) 42 | (values specifier (first type+id) (second type+id) inits t))) 43 | 44 | ;; pass to standard declaration decomposition 45 | (multiple-value-bind (spec type name init) (cm-c:decompose-declaration item) 46 | (values spec type name init nil))))) 47 | 48 | (defmacro make-declaration-node/with-list-initializer (item) 49 | "Decompose initializer list and instantiate nodes / quite like declaration item" 50 | (multiple-value-bind (specifier type id init initializer-list-p) 51 | (decompose-declaration item) 52 | `(declaration-item 53 | ;; set specifiers 54 | ,(when specifier 55 | `(specifier 56 | (make-nodelist ,specifier))) 57 | ;; set type 58 | (type (make-node ,type)) 59 | ;; set identifier 60 | (make-node ,id) 61 | ;; set value 62 | ,(if init 63 | (if initializer-list-p 64 | `(declaration-list-initializer (make-nodelist ,init)) 65 | `(declaration-value (make-node ,init))) 66 | nil)))) 67 | 68 | (c++syntax decl (bindings &body body) 69 | "Declare variables" 70 | `(declaration-list 71 | ;; braces t, adjusted later by traverser 72 | t 73 | ;; make single declarations/bindings 74 | (make-nodelist 75 | ,(remove nil bindings) :prepend make-declaration-node/with-list-initializer) 76 | ;; make listnode with body 77 | ,(when body 78 | ;; make single expression statements 79 | `(make-expressions ,body)))) 80 | 81 | 82 | ;; function, lambda funciton helper 83 | (defun symbol-name-in-list (symbol list) 84 | (member-if (lambda(x) (when (symbolp x) (equal (symbol-name x) (string-upcase symbol)))) list)) 85 | 86 | 87 | ;; copy/extend for pure virtual functions 88 | (c++syntax function (name parameters &rest rest &environment env) 89 | "Define c++ function" 90 | (let ((qualifiers (reverse (rest (symbol-name-in-list "->" (reverse rest)))))) 91 | (destructuring-bind (type &body body) (rest (symbol-name-in-list "->" rest)) 92 | (flet ((qualifier-there (Q) 93 | (let ((there (symbol-name-in-list Q qualifiers))) 94 | (if there 95 | (setf qualifiers (remove-if (lambda (x) (eql x (first there))) 96 | qualifiers))) 97 | (if there t nil)))) 98 | (let* ((pure (qualifier-there "pure")) 99 | (virtual (or (qualifier-there "virtual") pure))) 100 | `(function-definition 101 | ,pure 102 | ,virtual 103 | ;; function name + type 104 | ,(if (listp type) 105 | ;; check if macro/function or list 106 | (let ((first (first type))) 107 | (if (and (not (listp first)) (fboundp! first env)) 108 | ;; type is macro or function 109 | `(make-declaration-node (,type ,name)) 110 | ;; type is list with type information 111 | `(make-declaration-node (,@type ,name)))) 112 | ;; type is single symbol 113 | `(make-declaration-node (,type ,name))) 114 | ;; parameter list 115 | (parameter-list 116 | (make-nodelist ,parameters :prepend make-declaration-node)) 117 | ,(if qualifiers 118 | `(specifier (make-nodelist ,qualifiers)) 119 | nil) 120 | ;; body 121 | ,(if pure 122 | `(cmu-c::set nil 0) 123 | (when body 124 | `(make-block ,body)))))))));) 125 | 126 | (c++syntax lambda-function (capture parameters &rest rest &environment env) 127 | "Define c++11 lambda function" 128 | (let ((qualifiers (reverse (rest (symbol-name-in-list "->" (reverse rest))))) 129 | (ret-body (rest (symbol-name-in-list "->" rest))) 130 | (body rest) 131 | (type nil)) 132 | (when ret-body 133 | (setf body (rest ret-body)) 134 | (setf type (first ret-body))) 135 | `(lambda-definition 136 | ;; caputre 137 | (parameter-list 138 | (make-nodelist 139 | ;; check if macro/function or list 140 | ,(loop for i in capture collect 141 | (if (and (listp i) (not (fboundp! (first i) env))) 142 | ;; element is is simple list and not bound 143 | i 144 | ;; element is bound 145 | `(,i))) 146 | :prepend make-declaration-node)) 147 | ;; parameter 148 | (parameter-list 149 | (make-nodelist ,parameters :prepend make-declaration-node)) 150 | ;; qualifiers 151 | ,(if qualifiers 152 | `(specifier (make-nodelist ,qualifiers)) 153 | nil) 154 | ;; return type 155 | ,(if type 156 | (if (listp type) 157 | ;; chedk if macro/funciton or list 158 | (let ((First (first type))) 159 | (if (and (not (listp first)) (fboundp! first env)) 160 | ;; type is macro or function 161 | `(make-declaration-node (,type nil)) 162 | ;; type is list with type information 163 | `(make-declaration-node (,@type nil)))) 164 | ;; type is single symbol 165 | `(make-declaration-node (,type nil))) ;; no name -> nil 166 | nil) 167 | ;; body 168 | ,(when body 169 | `(make-block ,body))))) 170 | 171 | (c++syntax constructor (name args &body body) 172 | "Constructor with initializer list" 173 | (let ((initializer nil)) 174 | (when (eql (first body) :init) 175 | (setf initializer (second body)) 176 | (setf body (rest (rest body)))) 177 | `(constructor 178 | ;; constructor name 179 | (make-node ,name) 180 | ;; parameter 181 | (parameter-list 182 | (make-nodelist ,args :prepend make-declaration-node)) 183 | ;; initializer 184 | ,(when initializer 185 | `(make-nodelist ,initializer)) 186 | ;; body 187 | ,(when (or body initializer) 188 | `(make-block ,body))))) 189 | 190 | (c++syntax destructor (name &body body) 191 | "Destructor" 192 | (let* ((first (first body)) 193 | (virtual (and (listp body) (symbolp first) (equal (symbol-name first) "VIRTUAL"))) 194 | (body (if virtual (rest body) body))) 195 | `(destructor 196 | ,virtual 197 | ;; destructor name 198 | (make-node ,name) 199 | ;; body 200 | ,(when body 201 | `(make-block ,body))))) 202 | 203 | (defun wrap-statements (list) 204 | "Wrap all elements in list in expression-statement and 205 | access-specifier, apply quoty and combine into nodelist" 206 | `(make-nodelist 207 | ,(loop for i in list collect 208 | `(access-specifier nil 209 | (expression-statement nil 210 | (quoty ,i)))))) 211 | 212 | (c++syntax class (name superclasses &body body) 213 | "Define a c++ class with c'tor and d'ctor mactoler" 214 | ;; macrolet for locally defined c'tor and d'tor 215 | `(macrolet ((cmu-c++::constructor (args &body body) 216 | `(cms-c++::constructor ,',name ,args ,@body)) 217 | (cmu-c++::destructor (&body body) 218 | `(cms-c++::destructor ,',name ,@body))) 219 | (class 220 | ;; class name 221 | (make-node ,name) 222 | ;; superclasses 223 | (make-nodelist 224 | ,superclasses :prepend decompose-superclass) 225 | ;; compund statement with individual expr statements 226 | ,(if body 227 | `(compound-statement 228 | ;; curly braces 229 | t 230 | ;; prepared body 231 | ,(wrap-statements body)) 232 | nil)))) 233 | 234 | (c++syntax struct (name &body body) 235 | "Struct redefinition, required for access specifiers" 236 | `(struct-definition 237 | ;; struct name 238 | (make-node ,name) 239 | ,(when body 240 | `(compound-statement 241 | ;; curly braces 242 | t 243 | ;; modified body 244 | ,(wrap-statements body))))) 245 | 246 | (c++syntax (private public protected) (&body body) 247 | "Class access specifier" 248 | `(access-specifier ',tag ,(wrap-statements body))) 249 | 250 | (c++syntax namespace (namespace &body body) 251 | "Make new namespace" 252 | `(namespace 253 | ;; namespace name 254 | (make-node ,namespace) 255 | ;; make namespace body 256 | (make-block ,body))) 257 | 258 | (c++syntax using (item) 259 | "Using something" 260 | `(using (make-node ,item))) 261 | 262 | (c++syntax using-namespace (item) 263 | "Using namespace" 264 | `(using-namespace (make-node ,item))) 265 | 266 | (c++syntax (new new[]) (&rest object) 267 | "Make new object" 268 | (let ((specifier (butlast object)) 269 | (object (first (last object)))) 270 | `(new 271 | ;; new / new[] 272 | ',tag 273 | ;;specifier 274 | ,(when specifier 275 | `(specifier 276 | (make-nodelist ,specifier))) 277 | ;; type/object 278 | (make-node ,object)))) 279 | 280 | (c++syntax (delete delete[]) (item) 281 | "Delete object" 282 | `(delete 283 | ;; delete / delete[] 284 | ',tag 285 | (make-node ,item))) 286 | 287 | (c++syntax throw (item) 288 | "Throw is just a jump statement" 289 | `(jump-statement 290 | (make-node ,tag) 291 | ,(when item `(make-node ,item)))) 292 | 293 | (defmacro make-catch-decl-item ((args &body body)) 294 | (let ((all (eq args t))) 295 | `(catch 296 | ,all 297 | ,(if (not all) 298 | `(make-declaration-node ,args)) 299 | (make-block ,body)))) 300 | 301 | (c++syntax catching (clauses &body body) 302 | `(try-block 303 | (make-block ,body) 304 | (make-nodelist ,clauses :prepend make-catch-decl-item))) 305 | 306 | (c++syntax from-namespace (&rest rest) 307 | "From namesapce ::foo // foo::bar" 308 | ;; set last item 309 | (let ((namespace-cascade `(make-node ,(first (last rest))))) 310 | ;; loop form back to front collect namespaces 311 | (loop for i in (rest (reverse rest)) do 312 | (setf namespace-cascade 313 | `(from-namespace 314 | (make-node ,i) 315 | ,namespace-cascade))) 316 | namespace-cascade)) 317 | 318 | (c++syntax template (parameters item) 319 | "C++ templates" 320 | `(template 321 | ;; set parameters 322 | (parameter-list 323 | (make-nodelist ,parameters :prepend make-declaration-node)) 324 | ;; body 325 | (make-node ,item))) 326 | 327 | (c++syntax instantiate (name &rest arguments) 328 | "Intantiate template" 329 | `(instantiate 330 | ;; name 331 | (make-node ,name) 332 | ;; 333 | (make-nodelist 334 | ,arguments :prepend cm-c:decompose-type))) 335 | 336 | (c++syntax instantiate-explicit (item) 337 | "Explicit template instantiateio" 338 | `(instantiate-explicit ,item)) 339 | 340 | (c++syntax reference-type (item) 341 | "Postfix & operator (reference" 342 | `(postfix-expression '& (make-node ,item))) 343 | 344 | (c++syntax for (init &body body) 345 | "Similar to c version but with foreach support" 346 | `(for-statement 347 | ;; check if initialization present 348 | ,(when (first init) 349 | ;; set init 350 | `(make-declaration-node ,(first init))) 351 | ;; test / foreach container 352 | (make-node ,(second init)) 353 | ;; check if step present 354 | ,(when (third init) 355 | ;; set step 356 | `(make-node ,(third init))) 357 | ;; the loop body 358 | (make-block ,body))) 359 | 360 | (build-context-switches 361 | :user-package :cmu-c++ 362 | :symbols c++symbols) 363 | 364 | (build-swap-package 365 | :user-package :cmu-c++ 366 | :swap-package :cms-c++ 367 | :symbols c++swap) 368 | -------------------------------------------------------------------------------- /src/cxx/traverser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-c++) 2 | 3 | ;;; Add clean lists to decl-blocker stacks 4 | ;;; avoid extra braces in class defintion 5 | (decl-blocker-extra-nodes constructor) 6 | ;;; avoid extra braces in if lambdas occur 7 | (decl-blocker-extra-nodes lambda-definition) 8 | 9 | 10 | ;;; Check if identifier is of type "operatorXX" 11 | ;;; and prevent renaming of cxx operator definition 12 | (defmethod check-and-get-name :before ((item renamer) check-name) 13 | (with-slots (name-map) item 14 | ;; put unmodified operator into name-map 15 | ;; -> this will be used later directly without check 16 | (let ((operatorXX (symbol-name check-name))) 17 | (when (and (>= (length operatorXX) 8) 18 | (string-equal "operator" operatorXX :start2 0 :end2 8)) 19 | (when (not (gethash operatorXX name-map))) 20 | (setf (gethash operatorXX name-map) check-name))) 21 | 22 | ;; put unmodified '=' and '&' into name-map -> used for labda captures 23 | (let ((x (symbol-name check-name))) 24 | (when (or (string-equal "=" x) (string-equal "&" x)) 25 | (when (not (gethash x name-map)) 26 | (setf (gethash x name-map) check-name)))))) 27 | 28 | 29 | ;;; Insert virtual for functions declared as pure 30 | ;;; Probably breaks in weird cases where virtual functions define local classes with virtual functions, because we don't keep a stack. We find this is reasonable :) 31 | (defclass virtualizer () 32 | ((function :initform nil) 33 | (in-return-part :initform nil) 34 | (node-to-delete :initform nil))) 35 | 36 | 37 | (with-proxynodes (return-type-node) 38 | 39 | (defmethod traverser :before ((v virtualizer) (f function-definition) level) 40 | "Insert a proxy node to caputre the return type, called ITEM 41 | also store reference to the function being traversed" 42 | (setf (slot-value v 'function) f) 43 | (with-slots (item) f 44 | (make-proxy item return-type-node :node-name f))) 45 | 46 | (defmethod traverser :after ((v virtualizer) (f function-definition) level) 47 | "Remove the proxy (as well as the function-reference) created in the previous method" 48 | (setf (slot-value v 'function) nil) 49 | (with-slots (item) f 50 | (del-proxy item :node-name f))) 51 | 52 | (defproxymethod :before (v virtualizer) return-type-node 53 | "Set virtualizer flag that we are inside the return-type branch of the function node" 54 | (setf (slot-value v 'in-return-part) t)) 55 | 56 | (defproxymethod :after (v virtualizer) return-type-node 57 | "Reset flag: we are not longer inside the return-branch" 58 | (setf (slot-value v 'in-return-part) nil) 59 | (setf (slot-value v 'node-to-delete) nil)) 60 | 61 | (defmethod traverser :before ((v virtualizer) (i identifier) level) 62 | "We use a before method to not overwrite the traversal code in the actual method" 63 | (when (equal (symbol-name (slot-value i 'identifier)) "VIRTUAL") 64 | (setf (slot-value (slot-value v 'function) 65 | 'virtual) 66 | t) 67 | (setf (slot-value v 'node-to-delete) i))) 68 | 69 | (defmethod traverser :after ((v virtualizer) (list nodelist) level) 70 | "Remove the virtual marker from the list of return 'types'" 71 | (with-slots (in-return-part node-to-delete) v 72 | (when in-return-part 73 | (with-slots (nodes) list 74 | (setf nodes (remove-if (lambda (x) (eql x node-to-delete)) nodes))))))) 75 | 76 | 77 | ;;; Identify nested or cascaded sets of access specifiers and resolve 78 | (defclass access-respecifier () 79 | ((parent-spec :initform '(nil)) 80 | (sibling-spec :initform '(nil)))) 81 | 82 | 83 | (defmethod traverser :before ((ar access-respecifier) (cd class) level) 84 | "Push parrent and sibling specifiers" 85 | (with-slots (parent-spec sibling-spec) ar 86 | (push 'private parent-spec) 87 | (push 'private sibling-spec))) 88 | 89 | (defmethod traverser :after ((ar access-respecifier) (cd class) level) 90 | "Pop hints" 91 | (with-slots (parent-spec sibling-spec) ar 92 | (pop parent-spec) 93 | (pop sibling-spec))) 94 | 95 | (defmethod traverser :before ((ar access-respecifier) (sd struct-definition) level) 96 | "Push parent and sibling specifiers" 97 | (with-slots (parent-spec sibling-spec) ar 98 | (push 'public parent-spec) 99 | (push 'public sibling-spec))) 100 | 101 | (defmethod traverser :after ((ar access-respecifier) (sd struct-definition) level) 102 | "Pop hints" 103 | (with-slots (parent-spec sibling-spec) ar 104 | (pop parent-spec) 105 | (pop sibling-spec))) 106 | 107 | (defmethod traverser :before ((ar access-respecifier) (as access-specifier) level) 108 | "Push current parent and sibling according to own specifier" 109 | (with-slots (parent-spec sibling-spec) ar 110 | (with-slots (specifier) as 111 | (when (not specifier) 112 | (when (not (eql (first sibling-spec) (first parent-spec))) 113 | (setf specifier (first parent-spec)))) 114 | (when specifier 115 | (push specifier parent-spec) 116 | (setf (first sibling-spec) specifier))))) 117 | 118 | (defmethod traverser :after ((ar access-respecifier) (as access-specifier) level) 119 | "Pop parent/sibling and set current sibling for subsequent nodes" 120 | (with-slots (specifier) as 121 | (when specifier 122 | (with-slots (parent-spec sibling-spec) ar 123 | (pop parent-spec))))) 124 | -------------------------------------------------------------------------------- /src/front/cm.c: -------------------------------------------------------------------------------- 1 | #define _GNU_SOURCE 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | int main(int argc, char **argv) 10 | { 11 | char *prog = NULL; 12 | char *gen = NULL; 13 | int len = 0; 14 | bool help = false, version=false; 15 | 16 | if (argc == 1) { 17 | printf("C-Mera generator selection frontend.\n" 18 | "Please specify generator type as c, c++, cxx, glsl, ocl, cuda or use --help.\n" 19 | "Generator abbreviations are ok and checked in the order given above.\n"); 20 | return 1; 21 | } 22 | 23 | len = strlen(argv[1]); 24 | if (strncmp(argv[1], "c", len) == 0) gen = "cm-c"; 25 | else if (strncmp(argv[1], "c++", len) == 0) gen = "cm-cxx"; 26 | else if (strncmp(argv[1], "cxx", len) == 0) gen = "cm-cxx"; 27 | else if (strncmp(argv[1], "glsl", len) == 0) gen = "cm-glsl"; 28 | else if (strncmp(argv[1], "ocl", len) == 0) gen = "cm-opgencl"; 29 | else if (strncmp(argv[1], "opencl", len) == 0) gen = "cm-opencl"; 30 | else if (strncmp(argv[1], "cuda", len) == 0) gen = "cm-cuda"; 31 | else if (strncmp(argv[1], "--version", len) == 0) { gen = "cm-c"; version = true; } 32 | else if (strncmp(argv[1], "-V", len) == 0) { gen = "cm-c"; version = true; } 33 | else { gen = "cm-c"; help = true; } 34 | 35 | int n = asprintf(&prog, "%s/%s", BINDIR, gen); 36 | if (n <= 0) { 37 | fprintf(stderr, "Allocation error, cannot start generator.\n"); 38 | return 1; 39 | } 40 | 41 | if (help) 42 | execl(prog, "cm ", "--help", NULL); 43 | else if (version) 44 | execl(prog, "cm ", "--version", NULL); 45 | else { 46 | argv[1] = gen; 47 | execv(prog, argv+1); 48 | } 49 | fprintf(stderr, "Cannot spawn generator process: %s\n", strerror(errno)); 50 | return 1; 51 | } 52 | 53 | 54 | -------------------------------------------------------------------------------- /src/glsl/cm-glsl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-glsl) 2 | 3 | ;; Define a c-mera file reader with extra macro characters 4 | (define-reader 5 | :file-reader read-in-file 6 | :string-reader read-in-string 7 | :macro-character 8 | ((set-macro-character #\Space #'cm-c::pre-process) 9 | (set-macro-character #\Tab #'cm-c::pre-process) 10 | (set-macro-character #\Newline #'cm-c::pre-process) 11 | (set-macro-character #\( #'cm-c::pre-process-heads))) 12 | 13 | ;; Define a start-up function 14 | (define-processor 15 | :name glsl-processor 16 | :file-reader read-in-file 17 | :string-reader read-in-string 18 | :extra-traverser 19 | (nested-nodelist-remover 20 | else-if-traverser 21 | if-blocker 22 | decl-blocker 23 | renamer)) 24 | 25 | ;; Define a save function 26 | (save-generator 27 | :name save 28 | :start-function glsl-processor 29 | :in-package :cmu-glsl) 30 | 31 | ;;; Define a reader switch with c++ pre-processing 32 | (define-switch 33 | :name switch-reader 34 | :macro-character 35 | ((set-macro-character #\Space #'cm-c::pre-process) 36 | (set-macro-character #\Tab #'cm-c::pre-process) 37 | (set-macro-character #\Newline #'cm-c::pre-process) 38 | (set-macro-character #\( #'cm-c::pre-process-heads))) 39 | 40 | (define-switches 41 | :cl-reader cl-reader 42 | :cm-reader cm-reader 43 | :macro-character 44 | ((set-macro-character #\Space #'cm-c::pre-process) 45 | (set-macro-character #\Tab #'cm-c::pre-process) 46 | (set-macro-character #\Newline #'cm-c::pre-process) 47 | (set-macro-character #\( #'cm-c::pre-process-heads))) 48 | -------------------------------------------------------------------------------- /src/glsl/nodes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-glsl) 2 | 3 | (defnode layout () (parameters)) 4 | -------------------------------------------------------------------------------- /src/glsl/pretty.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-glsl) 2 | 3 | (with-pp 4 | (with-proxynodes (normal special) 5 | 6 | (defprettymethod :before layout 7 | (push-info 'layout) 8 | (format stream "layout(")) 9 | 10 | (defprettymethod :after layout 11 | (pop-info) 12 | (format stream ")")) 13 | 14 | ;; override specifier item for layout 15 | (defprettymethod :before specifier 16 | (if (eql (top-info) 'layout) 17 | (progn 18 | (push-sign 'skip-first-specifier) 19 | (make-proxy specifier special)) 20 | (make-proxy specifier normal))) 21 | 22 | (defprettymethod :after specifier 23 | (when (eql (top-sign) 'skip-first-specifier) 24 | (pop-sign)) 25 | (del-proxy specifier)) 26 | 27 | (defproxyprint :after normal 28 | (format stream " ")) 29 | 30 | (defproxyprint :before special 31 | (if (eql (top-sign) 'skip-first-specifier) 32 | (pop-sign) 33 | (format stream " "))))) 34 | 35 | 36 | -------------------------------------------------------------------------------- /src/glsl/syntax.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-glsl) 2 | 3 | (defmacro glsl-syntax (tags lambda-list &body body) 4 | `(defsyntax ,tags (:cmu-glsl) ,lambda-list ,@body)) 5 | 6 | (defmacro decompose-specifier (item) 7 | (if (let ((symbol (first (last (butlast item))))) 8 | (and (symbolp symbol) 9 | (equal (symbol-name symbol) "="))) 10 | ;; specifier with value, without type nor identifier 11 | `(make-declaration-node 12 | ;; specifiers 13 | (,@(butlast item 2) 14 | ;; type: none 15 | nil 16 | ;; identifier:: none 17 | nil 18 | ;; value and "=" 19 | ,@(last item 2))) 20 | ;; only specifier 21 | `(make-declaration-node 22 | ;; specifier 23 | (,@item 24 | ;; type: none 25 | nil 26 | ;; identifier: none 27 | nil 28 | ;; value: none 29 | nil)))) 30 | 31 | (glsl-syntax layout (&rest parameters) 32 | "glsl layout qualifier" 33 | `(layout 34 | ;; qualifiers 35 | (parameter-list 36 | (make-nodelist 37 | ,parameters :prepend decompose-specifier)))) 38 | 39 | 40 | (build-context-switches 41 | :user-package :cmu-glsl 42 | :symbols glsl-symbols) 43 | 44 | (build-swap-package 45 | :user-package :cmu-glsl 46 | :swap-package :cms-glsl 47 | :symbols glsl-swap) 48 | 49 | 50 | -------------------------------------------------------------------------------- /src/opencl/cm-opencl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-opencl) 2 | 3 | ;; Define a c-mera file reader with extra macro characters 4 | (define-reader 5 | :file-reader read-in-file 6 | :string-reader read-in-string 7 | :macro-character 8 | ((set-macro-character #\Space #'cm-c::pre-process) 9 | (set-macro-character #\Tab #'cm-c::pre-process) 10 | (set-macro-character #\Newline #'cm-c::pre-process) 11 | (set-macro-character #\( #'cm-c::pre-process-heads))) 12 | 13 | ;; Define a start-up function 14 | (define-processor 15 | :name opencl-processor 16 | :file-reader read-in-file 17 | :string-reader read-in-string 18 | :extra-traverser 19 | (nested-nodelist-remover 20 | else-if-traverser 21 | if-blocker 22 | decl-blocker 23 | renamer)) 24 | 25 | ;; Define a save function 26 | (save-generator 27 | :name save 28 | :start-function opencl-processor 29 | :in-package :cmu-opencl) 30 | 31 | ;;; Define a reader switch with c++ pre-processing 32 | (define-switch 33 | :name switch-reader 34 | :macro-character 35 | ((set-macro-character #\Space #'cm-c::pre-process) 36 | (set-macro-character #\Tab #'cm-c::pre-process) 37 | (set-macro-character #\Newline #'cm-c::pre-process) 38 | (set-macro-character #\( #'cm-c::pre-process-heads))) 39 | -------------------------------------------------------------------------------- /src/opencl/nodes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-opencl) 2 | 3 | (defnode vector-initialization (tag) (parameter)) 4 | -------------------------------------------------------------------------------- /src/opencl/pretty.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-opencl) 2 | 3 | ;;; pretty print override/restore 4 | 5 | ;;; copy from ast-pretty.lisp 6 | ;;; restores original behaviour 7 | ;;; Declaration item 8 | ;;; Handle declaration assignment. 9 | (with-pp 10 | (with-proxynodes (value) 11 | 12 | (defprettymethod :before declaration-item 13 | (make-proxy value value)) 14 | 15 | (defprettymethod :after declaration-item 16 | (del-proxy value)) 17 | 18 | (defproxyprint :before value 19 | (if (slot-value item 'proxy-subnode) 20 | (format stream " = "))))) 21 | 22 | ;;; copy from ast-pretty.lisp 23 | ;;; restores original behavious 24 | ;;; C-list / vectors 25 | (with-pp 26 | (with-proxynodes (list-item) 27 | 28 | (defprettymethod :before clist 29 | (make-proxy items list-item) 30 | (push-sign 'skip-first-list) 31 | (format stream "{ ")) 32 | 33 | (defprettymethod :after clist 34 | (when (eql (top-sign) 'skip-first-list) 35 | (pop-sign)) 36 | (del-proxy items) 37 | (format stream " }")) 38 | 39 | (defproxyprint :before list-item 40 | (if (eql (top-sign) 'skip-first-list) 41 | (pop-sign) 42 | (format stream ", "))))) 43 | 44 | 45 | ;;; opencl vector initialization 46 | 47 | (with-pp 48 | (with-proxynodes (parameter) 49 | 50 | (defprettymethod :before vector-initialization 51 | (make-proxy parameter parameter) 52 | (push-sign 'skip-first-vector-init) 53 | (format stream "(~a)(" (node-slot tag))) 54 | 55 | (defprettymethod :after vector-initialization 56 | (when (eql (top-sign) 'skip-first-vector-init) 57 | (pop-sign)) 58 | (del-proxy parameter) 59 | (format stream ")")) 60 | 61 | (defproxyprint :before parameter 62 | (if (eql (top-sign) 'skip-first-vector-init) 63 | (pop-sign) 64 | (format stream ", "))))) 65 | -------------------------------------------------------------------------------- /src/opencl/syntax.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cm-opencl) 2 | 3 | (defmacro opencl-syntax (tags lambda-list &body body) 4 | `(defsyntax ,tags (:cmu-opencl) ,lambda-list ,@body)) 5 | 6 | (let ((vectors (loop for i in '(char uchar short ushort int uint long ulong half float double) append 7 | (loop for k in '(2 3 4 8 16) collect 8 | (intern (format nil "~a~a" i k)))))) 9 | (eval 10 | `(opencl-syntax ,vectors (&rest parameter) 11 | "OpenCl vector initialization" 12 | `(vector-initialization 13 | ;;vector type 14 | ',tag 15 | ;; args 16 | (make-nodelist ,parameter))))) 17 | 18 | (build-context-switches 19 | :user-package :cmu-opencl 20 | :symbols opencl-symbols) 21 | 22 | (build-swap-package 23 | :user-package :cmu-opencl 24 | :swap-package :cms-opencl 25 | :symbols opencl-swap) 26 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | all: message clean c-tests cxx-tests count clean-post 2 | 3 | .PHONY: c-tests cxx-tests count clean clean-post message 4 | 5 | 6 | message: 7 | @echo 8 | @echo "Running C-Mera tests" 9 | 10 | ### c tests 11 | ### all tests start with c. and end with .lisp 12 | 13 | .PHONY: c-tests-pre 14 | c-tests-pre: 15 | @echo 16 | @echo "For C" 17 | c-test-files = $(shell ls c.decl.*.lisp c.for.*.lisp c.while.*.lisp c.when.*.lisp c.misc.*.lisp c.meta.*.lisp \ 18 | c.cond.*.lisp c.switch.*.lisp c.renaming.*.lisp c.comment.*.lisp c.goto.*.lisp c.do.*.lisp) 19 | c-test-results = $(c-test-files:%.lisp=%.ok) 20 | c-tests: c-tests-pre $(c-test-results) 21 | # ... 22 | 23 | 24 | 25 | ### c++ tests 26 | ### all tests start with cxx. and end with .lisp 27 | 28 | .PHONY: cxx-tests-pre cxx-ns-tests-pre cxx-misc-tests-pre cxx-decl-tests-pre cxx-meta-tests-pref 29 | 30 | cxx-ns-test-files = $(shell ls cxx.namespace.*.lisp) 31 | cxx-ns-results = $(cxx-ns-test-files:%.lisp=%.ok) 32 | cxx-ns-tests-pre: 33 | @echo "- Namespaces:" 34 | cxx-ns-tests: cxx-ns-tests-pre $(cxx-ns-results) 35 | 36 | cxx-cls-test-files = $(shell ls cxx.class.*.lisp) 37 | cxx-cls-results = $(cxx-cls-test-files:%.lisp=%.ok) 38 | cxx-cls-tests-pre: 39 | @echo "- Classes:" 40 | cxx-cls-tests: cxx-cls-tests-pre $(cxx-cls-results) 41 | 42 | cxx-decl-test-files = $(shell ls cxx.decl.*.lisp) 43 | cxx-decl-results = $(cxx-decl-test-files:%.lisp=%.ok) 44 | cxx-decl-tests-pre: 45 | @echo "- Declarations:" 46 | cxx-decl-tests: cxx-decl-tests-pre $(cxx-decl-results) 47 | 48 | cxx-misc-test-files = $(shell ls cxx.misc.*.lisp) 49 | cxx-misc-results = $(cxx-misc-test-files:%.lisp=%.ok) 50 | cxx-misc-tests-pre: 51 | @echo "- Misc:" 52 | cxx-misc-tests: cxx-misc-tests-pre $(cxx-misc-results) 53 | 54 | cxx-meta-test-files = $(shell ls cxx.meta.*.lisp) 55 | cxx-meta-results = $(cxx-meta-test-files:%.lisp=%.ok) 56 | cxx-meta-tests-pre: 57 | @echo "- Meta:" 58 | cxx-meta-tests: cxx-meta-tests-pre $(cxx-meta-results) 59 | 60 | cxx-templ-test-files = $(shell ls cxx.templates.*.lisp) 61 | cxx-templ-results = $(cxx-templ-test-files:%.lisp=%.ok) 62 | cxx-templ-tests-pre: 63 | @echo "- Templates:" 64 | cxx-templ-tests: cxx-templ-tests-pre $(cxx-templ-results) 65 | 66 | cxx-tests-pre: 67 | @echo 68 | @echo "For C++" 69 | 70 | cxx-tests: cxx-tests-pre \ 71 | cxx-decl-tests \ 72 | cxx-ns-tests \ 73 | cxx-cls-tests \ 74 | cxx-misc-tests \ 75 | cxx-meta-tests \ 76 | cxx-templ-tests 77 | 78 | cxx-test-files = $(cxx-ns-test-files) \ 79 | $(cxx-decl-test-files) \ 80 | $(cxx-cls-test-files) \ 81 | $(cxx-misc-test-files) \ 82 | $(cxx-meta-test-files) \ 83 | $(cxx-templ-test-files) 84 | 85 | 86 | ### 87 | 88 | all-test-files = $(c-test-files) $(cxx-test-files) 89 | 90 | 91 | ### c 92 | 93 | c.%.c: c.%.lisp 94 | @../cm-c $< -o $@ 2>/dev/null || ( ( echo "#include "; echo "int main() { printf(\"cm compile error\"); return 0; }" ) > $@; chmod +x $@ ) 95 | 96 | c.%.run: c.%.c 97 | @gcc -std=c99 $< -o $@ 2> $(basename $<).clog || (echo 'echo ""' > $@; chmod +x $@) 98 | 99 | 100 | ### c++ 101 | 102 | cxx.%.cpp: cxx.%.lisp 103 | @../cm-cxx $< -o $@ 2>/dev/null || ( ( echo "#include "; echo "int main() { printf(\"cm compile error\"); return 0; }" ) > $@; chmod +x $@ ) 104 | 105 | cxx.%.run: cxx.%.cpp 106 | @g++ -std=c++11 $< -o $@ 2> $(basename $<).clog || (echo 'echo ""' > $@; chmod +x $@) 107 | 108 | ### run & compare 109 | 110 | %.res: %.run 111 | @./$< > $@ 112 | 113 | %.exp: %.lisp 114 | @grep ';;## ' $< | sed -e 's/;;## //' > $@ 115 | 116 | %.ok: %.res %.exp 117 | @diff $^ > $$(basename $< .res).diff; ( if test "$$?" = "0" ; then echo " ok "; else touch .$$(basename $< .res).fail; echo " FAIL"; fi ) > $@ 118 | @echo "$$(cat $@) $$(basename $@ .ok)" 119 | 120 | count: 121 | @echo 122 | @N=$$(ls -1 .*.fail 2>/dev/null | wc -l); if test "$$N" = "0" ; then echo "All good!" ; else echo "$$N tests failed!"; fi 123 | 124 | ### clean 125 | 126 | clean_files = $(all-test-files:%.lisp=%.exp) \ 127 | $(all-test-files:%.lisp=%.run) \ 128 | $(all-test-files:%.lisp=%.res) \ 129 | $(all-test-files:%.lisp=%.diff) \ 130 | $(all-test-files:%.lisp=%.ok) \ 131 | $(all-test-files:%.lisp=%.c) \ 132 | $(all-test-files:%.lisp=%.cpp) \ 133 | $(all-test-files:%.lisp=%.clog) \ 134 | $(all-test-files:%.lisp=.%.fail) 135 | 136 | clean: 137 | @echo Cleaning test directory 138 | @rm -f $(clean_files) 139 | clean-post: 140 | @echo Cleaning test directory 141 | @rm -f $(clean_files) 142 | -------------------------------------------------------------------------------- /tests/c.comment.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function test ((int i)) -> int 4 | (cond ((== i 0)) 5 | ((== i 1) (comment "do nothing")) 6 | ((== i 2) (return 2)) 7 | ((== i 3) (comment "do nohting"))) 8 | 9 | (comment "first block") 10 | 11 | 12 | (if (== i 4) 13 | (return 4) 14 | (comment "do nothing")) 15 | 16 | (comment "second block") 17 | 18 | (if (!= i 5) 19 | (comment "do noghting") 20 | (return 5)) 21 | 22 | (return 0)) 23 | 24 | (function main () -> int 25 | (printf "%i\\n" (test 0 )) 26 | (printf "%i\\n" (test 1 )) 27 | (printf "%i\\n" (test 2 )) 28 | (printf "%i\\n" (test 3 )) 29 | (printf "%i\\n" (test 4 )) 30 | (printf "%i\\n" (test 5 )) 31 | (return 0)) 32 | 33 | ;;## 0 34 | ;;## 0 35 | ;;## 2 36 | ;;## 0 37 | ;;## 4 38 | ;;## 5 39 | -------------------------------------------------------------------------------- /tests/c.cond.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function test ((int i)(int k)) -> int 4 | (cond ((== i 1) 5 | (return 1)) 6 | ((== i 2) 7 | (printf "%i\\n" 2) 8 | (return 2)) 9 | ((== i 3) 10 | (progn (return 3))) 11 | ((== i 4) 12 | (progn (progn (progn (progn (return 4)))))) 13 | ((== i 5) 14 | (progn (progn (progn (progn (printf "%i\\n" 5) 15 | (return 5)))))) 16 | ((and (> i 5) 17 | (< i 9)) 18 | (if (> i 6) 19 | (if (> i 7) 20 | (return 8)) 21 | (return 6)) 22 | (if (== i 7) 23 | (return 7))) 24 | 25 | ((== i 9) 26 | (if (== i 9) 27 | (return 9))) 28 | ((== i 0)) 29 | (t 30 | (return (* i k)))) 31 | (return 0)) 32 | 33 | 34 | 35 | 36 | 37 | 38 | (function main () -> int 39 | (printf "%i\\n" (test 0 0)) 40 | (printf "%i\\n" (test 1 -1)) 41 | (printf "%i\\n" (test 2 -1)) 42 | (printf "%i\\n" (test 3 -1)) 43 | (printf "%i\\n" (test 4 -1)) 44 | (printf "%i\\n" (test 5 -1)) 45 | (printf "%i\\n" (test 6 -1)) 46 | (printf "%i\\n" (test 7 -1)) 47 | (printf "%i\\n" (test 8 -1)) 48 | (printf "%i\\n" (test 9 -1)) 49 | (printf "%i\\n" (test 10 -1)) 50 | (return 0)) 51 | 52 | ;;## 0 53 | ;;## 1 54 | ;;## 2 55 | ;;## 2 56 | ;;## 3 57 | ;;## 4 58 | ;;## 5 59 | ;;## 5 60 | ;;## 6 61 | ;;## 7 62 | ;;## 8 63 | ;;## 9 64 | ;;## -10 65 | -------------------------------------------------------------------------------- /tests/c.cond.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function test ((int test)) -> int 4 | (decl ((int i = 0)) 5 | (if test 6 | (progn (set)) 7 | (progn (set))) 8 | 9 | (if test 10 | (progn (set i 1)) 11 | (progn)) 12 | 13 | (if test 14 | (progn (set)) 15 | (progn (set i 2))) 16 | 17 | (return i))) 18 | 19 | 20 | (function main () -> int 21 | (printf "0\\n") 22 | (printf "%i\\n" (test 1)) 23 | (printf "%i\\n" (test 0)) 24 | (return 0)) 25 | 26 | ;;## 0 27 | ;;## 1 28 | ;;## 2 29 | -------------------------------------------------------------------------------- /tests/c.decl.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function foo () -> void 4 | (printf "1\\n")) 5 | 6 | (function foo2 ((int i)) -> void 7 | (printf "%d\\n" i)) 8 | 9 | (function foo3 ((unsigned int i) (unsigned int k)) -> void 10 | (printf "%u\\n%u\\n" i k)) 11 | 12 | (function main () -> int 13 | (printf "0\\n") 14 | 15 | (decl ((void (fpointer fp1 ()) = foo) 16 | (void (fpointer fp2 ((int))) = foo2) 17 | (void (fpointer fp3 ((int i))) = foo2) 18 | (void (fpointer fp4 ((unsigned int) (unsigned int))) = foo3) 19 | (void (fpointer fp5 ((unsigned int i) (unsigned int k))) = foo3)) 20 | (fp1) 21 | (fp2 2) 22 | (fp3 3) 23 | (fp4 4 5) 24 | (fp5 6 7)) 25 | 26 | (return 0)) 27 | 28 | ;;## 0 29 | ;;## 1 30 | ;;## 2 31 | ;;## 3 32 | ;;## 4 33 | ;;## 5 34 | ;;## 6 35 | ;;## 7 36 | -------------------------------------------------------------------------------- /tests/c.decl.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (decl ((const char* args[2][3] = (clist (clist "f" "o" "o") 4 | (clist "b" "a" "r"))))) 5 | 6 | (function main () -> int (printf "0\\n") (return 0)) 7 | 8 | ;;## 0 9 | -------------------------------------------------------------------------------- /tests/c.decl.02.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function main () -> int 4 | (decl ((unsigned int x = 0) 5 | (unsigned int y = (cast unsigned int x)))) 6 | (printf "0\\n") (return 0)) 7 | 8 | ;;## 0 9 | -------------------------------------------------------------------------------- /tests/c.do.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function strcatx ((char p[]) (char q[])) -> void 4 | (decl ((int i = 0) (int j = 0)) 5 | (while (!= p[i] #\null) 6 | i++) 7 | (do-while (!= (set p[i++] q[j++]) #\null)))) 8 | 9 | (function main ((int argc) (char **argv)) -> int 10 | (decl ((char str[10])) 11 | (set str[0] #\a) 12 | (set str[1] #\b) 13 | (set str[2] #\c) 14 | (set str[3] #\null) 15 | (strcatx str "foo") 16 | (printf "%s\\n" str) 17 | (return 0))) 18 | 19 | ;;## abcfoo 20 | -------------------------------------------------------------------------------- /tests/c.for.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (function main () -> int 3 | (for ((int i = 0) (< i 10) ++i)) 4 | (printf "should appear only once.\\n") 5 | (return 0)) 6 | 7 | ;;## should appear only once. 8 | -------------------------------------------------------------------------------- /tests/c.for.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (function main () -> int 3 | (for ((int i = 0) (< i 10) (set i (+ i 1))) 4 | (printf "should appear only once.\\n") 5 | (return 0))) 6 | 7 | ;;## should appear only once. 8 | -------------------------------------------------------------------------------- /tests/c.goto.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function main () -> int 4 | 5 | (goto two) 6 | 7 | (label zero) 8 | (printf "0\\n") 9 | (goto four) 10 | 11 | (label (cintern "one")) 12 | (printf "1\\n") 13 | (goto zero) 14 | 15 | (label (cintern (format nil "~a" 'two))) 16 | (printf "2\\n") 17 | (goto one) 18 | 19 | (label three-and-a-half) 20 | (printf "3.5\\n") 21 | (return 0) 22 | 23 | (label three) 24 | (printf "3\\n") 25 | (goto three-and-a-half) 26 | 27 | (label (cintern #.(format nil "~a~a" 'fo 'ur))) 28 | (printf "4\\n") 29 | (goto three)) 30 | 31 | ;;## 2 32 | ;;## 1 33 | ;;## 0 34 | ;;## 4 35 | ;;## 3 36 | ;;## 3.5 37 | -------------------------------------------------------------------------------- /tests/c.meta.01.decompose-decl.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (defmacro foo (&body body) 4 | (multiple-value-bind (spec type name init) 5 | (cm-c:decompose-declaration body) 6 | `(funcall printf ,(format nil "[~a] [~a] [~a] [~a]\\n" spec type name init)))) 7 | 8 | (function main () -> int 9 | (foo int i) 10 | (foo unsigned long int *p = 0) 11 | (foo int arr[] = (clist 1 2 3)) 12 | (foo int arr[] { 1 2 3 }) 13 | (return 0)) 14 | 15 | ;;## [nil] [int] [i] [nil] 16 | ;;## [(unsigned long)] [int] [(targ-of (quoty p))] [0] 17 | ;;## [nil] [int] [(aref (quoty arr))] [(clist 1 2 3)] 18 | ;;## [(int (aref (quoty arr)) { 1 2)] [3] [}] [nil] 19 | 20 | -------------------------------------------------------------------------------- /tests/c.misc.01.sizeof.lisp: -------------------------------------------------------------------------------- 1 | ;; broken sizeof 2 | (include ) 3 | 4 | (function main ((int argc) (char **argv)) -> int 5 | (decl ((int s = (sizeof unsigned int))) 6 | (printf "0\\n") 7 | (return 0))) 8 | 9 | ;;## 0 10 | -------------------------------------------------------------------------------- /tests/c.misc.02.usevar.lisp: -------------------------------------------------------------------------------- 1 | ;; after use-variables the symbol no longer maps to itself, but to the symbol i. 2 | (include ) 3 | (use-variables FOO) 4 | 5 | (function main ((int argc) (char **argv)) -> int 6 | (decl ((int FOO = 1)) 7 | (decl ((int i = 2)) 8 | (printf "%d\\n" FOO) 9 | (return 0)))) 10 | 11 | ;;## 1 12 | -------------------------------------------------------------------------------- /tests/c.misc.03.macrolet.defmacro.lisp: -------------------------------------------------------------------------------- 1 | ;; shows two bugs: 2 | ;; 1. printf is no known function in the quoted expression (but it is outside) 3 | ;; 2. only the last statement of the macrolet's body is found in the output 4 | 5 | ;;(include ) 6 | ;;(function main () -> int 7 | ;; (printf "test\\n") 8 | ;; (macrolet ((foo (x) `(printf "foo: %d\\n" ,x))) 9 | ;; (foo 1) 10 | ;; (foo 2) 11 | ;; (foo 3)) 12 | ;; (return 0)) 13 | 14 | ;; Regarding 1: A global redefinition of macrolet (and defmacrr) might break lisp itsef. 15 | ;; Therefore, we propose a user version of macrolet and defmacro. 16 | ;; As an alternative, 'funcall' can be used to circument the issue 17 | 18 | ;; Regarding 2: That is the intendet behaviour of Lisp's macrolet 19 | ;; generating multiple statements reqquires 'progn'. 20 | 21 | (defmacro c-defmacro (name lambda-list &body body) 22 | `(defmacro ,name ,lambda-list `(cmu-c:progn ,,@body))) 23 | 24 | (defmacro c-macrolet (definitions &rest body) 25 | `(macrolet ,(loop for def in definitions collect 26 | `(,(first def) ,(second def) `(cmu-c:progn ,,(third def)))) 27 | (cmu-c:progn ,@body))) 28 | 29 | 30 | (c-defmacro bar (x) `(printf "bar: %d\\n" ,x)) 31 | 32 | (include ) 33 | (function main () -> int 34 | (printf "test\\n") 35 | (c-macrolet ((foo (x) `(printf "foo: %d\\n" ,x))) 36 | (foo 1) 37 | (foo 2) 38 | (foo 3) 39 | (bar 4)) 40 | (macrolet ((baz (x) `(funcall printf "baz: %d\\n", x))) 41 | (baz 5)) 42 | (return 0)) 43 | 44 | ;;## test 45 | ;;## foo: 1 46 | ;;## foo: 2 47 | ;;## foo: 3 48 | ;;## bar: 4 49 | ;;## baz: 5 50 | -------------------------------------------------------------------------------- /tests/c.misc.04.hex.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function main () -> int 4 | (printf "%d\\n" 0x01) 5 | (printf "%d\\n" 012) 6 | (return 0)) 7 | 8 | ;;## 1 9 | ;;## 12 10 | -------------------------------------------------------------------------------- /tests/c.misc.05.unary.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function main () -> int 4 | (decl ((int x = 10)) 5 | (printf "%d\\n" +x) 6 | (printf "%d\\n" -x)) 7 | (return 0)) 8 | 9 | ;;## 10 10 | ;;## -10 11 | -------------------------------------------------------------------------------- /tests/c.misc.06.macrolet2.lisp: -------------------------------------------------------------------------------- 1 | (defmacro with-bindings (&body body) 2 | `(macrolet ((foo (x) `(set ,x (+ ,x 1)))) 3 | (progn 4 | ,@body))) 5 | 6 | (function main () -> int 7 | (decl ((int x = 1)) 8 | (with-bindings 9 | (foo x) 10 | (foo x)) 11 | (printf "%d\\n" x)) 12 | (return 0)) 13 | 14 | ;;## 3 15 | -------------------------------------------------------------------------------- /tests/c.misc.07.reader.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function test1 (#+nil (int a) #-nil (int b)) -> int 4 | #+nil 5 | (return a) 6 | #-nil 7 | (return b)) 8 | 9 | (function test2 (#-nil (int a) #+nil (int b)) -> int 10 | #-nil 11 | (return a) 12 | #+nil 13 | (return b)) 14 | 15 | 16 | (function main () -> int 17 | (printf "%i\\n" (test1 0)) 18 | (printf "%i\\n" (test2 1)) 19 | (return 0)) 20 | 21 | ;;## 0 22 | ;;## 1 23 | -------------------------------------------------------------------------------- /tests/c.misc.09.struct.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (struct x) 4 | (struct x 5 | (decl ((int y)))) 6 | 7 | (function main ((int argc) (char **argv)) -> int 8 | (printf "0\\n") 9 | (return 0)) 10 | 11 | ;;## 0 12 | -------------------------------------------------------------------------------- /tests/c.misc.10.cpp.lisp: -------------------------------------------------------------------------------- 1 | (cpp include ) 2 | (cpp ifndef MY_H) 3 | (cpp define MY_H) 4 | 5 | ;; not the best example, since non-standard 6 | (pragma once) 7 | 8 | (function main ((int argc) (char **argv)) -> int 9 | (printf "0\\n") 10 | (return 0)) 11 | 12 | (cpp endif) 13 | 14 | ;;## 0 15 | -------------------------------------------------------------------------------- /tests/c.misc.11.funcall.oref.funcall.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | ;; simple function returning int 4 | (function foo-fn () -> int (return 0)) 5 | 6 | ;; typedef for a function returning int, taking no arguments 7 | (typedef int (fpointer foo-fn-ptr ())) 8 | 9 | ;; function that takes one (useless) argument and returns a function such as foo-fn. 10 | (function bar-fn1 ((int x)) -> foo-fn-ptr (return foo-fn)) 11 | 12 | ;; function that takes two (useless) arguments and returns a function such as foo-fn. 13 | (function bar-fn2 ((int x) (int y)) -> foo-fn-ptr (return foo-fn)) 14 | 15 | (function main ((int argc) (char **argv)) -> int 16 | (decl ((int x = 0) 17 | (int y = 0) 18 | (int a = (funcall (funcall bar-fn1 x))) 19 | (int b = (funcall (funcall bar-fn2 x y))))) 20 | (printf "0\\n") 21 | (return 0)) 22 | 23 | ;;## 0 24 | -------------------------------------------------------------------------------- /tests/c.misc.12.varargs.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | 4 | (function foo ((int a) (int b) &rest) -> int 5 | (decl ((va_list ap)) 6 | (va_start ap b) 7 | (for ((int i = 0) (< i b) ++i) 8 | (printf "%d\\n" (va_arg ap int))) 9 | (va_end ap) 10 | (return a))) 11 | 12 | (function main () -> int 13 | (decl ((int a = (foo 0 4 11 22 33 44))) 14 | (return a))) 15 | 16 | ;;## 11 17 | ;;## 22 18 | ;;## 33 19 | ;;## 44 20 | -------------------------------------------------------------------------------- /tests/c.renaming.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | 4 | (function main () -> int 5 | (decl ((int a-b) 6 | (int a*b) 7 | (int a~b) 8 | (int 4a) 9 | (int 5a)) 10 | (set a-b 1 11 | a_b 1 12 | a*b 2 13 | a~b 3 14 | 4a 4 15 | 5a 5) 16 | 17 | (decl ((int a-b) 18 | (int a*b) 19 | (int a~b) 20 | (int 4a) 21 | (int 5a)) 22 | (set a-b 5 23 | a_b 5 24 | a*b 4 25 | a~b 3 26 | 4a 2 27 | 5a 1) 28 | (printf "%i\\n" a-b) 29 | (printf "%i\\n" a_b) 30 | (printf "%i\\n" a*b) 31 | (printf "%i\\n" a~b) 32 | (printf "%i\\n" 4a) 33 | (printf "%i\\n" 5a)) 34 | 35 | (printf "%i\\n" a-b) 36 | (printf "%i\\n" a_b) 37 | (printf "%i\\n" a*b) 38 | (printf "%i\\n" a~b) 39 | (printf "%i\\n" 4a) 40 | (printf "%i\\n" 5a) 41 | (return 0))) 42 | 43 | ;;## 5 44 | ;;## 5 45 | ;;## 4 46 | ;;## 3 47 | ;;## 2 48 | ;;## 1 49 | ;;## 1 50 | ;;## 1 51 | ;;## 2 52 | ;;## 3 53 | ;;## 4 54 | ;;## 5 55 | -------------------------------------------------------------------------------- /tests/c.switch.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function test ((int x)) -> int 4 | (decl ((int i = 0)) 5 | (switch x 6 | ((1 2 3) 7 | (set i 1) 8 | (break)) 9 | (4 (set i 4)) 10 | (5 11 | (set i 5) 12 | (break)) 13 | ((6 7 8) 14 | (set i 6) 15 | (break)) 16 | (t (set i -1))) 17 | (return i))) 18 | 19 | (function main () -> int 20 | (printf "%i\\n" (test 1)) 21 | (printf "%i\\n" (test 2)) 22 | (printf "%i\\n" (test 3)) 23 | (printf "%i\\n" (test 4)) 24 | (printf "%i\\n" (test 5)) 25 | (printf "%i\\n" (test 6)) 26 | (printf "%i\\n" (test 7)) 27 | (printf "%i\\n" (test 8)) 28 | (printf "%i\\n" (test 9)) 29 | (printf "%i\\n" (test 10)) 30 | (return 0)) 31 | 32 | ;;## 1 33 | ;;## 1 34 | ;;## 1 35 | ;;## 5 36 | ;;## 5 37 | ;;## 6 38 | ;;## 6 39 | ;;## 6 40 | ;;## -1 41 | ;;## -1 42 | -------------------------------------------------------------------------------- /tests/c.when.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function foo ((int x) (int y)) -> void 4 | (decl ((int a = 0) 5 | (int b = 0)) 6 | (when (and (> x y) (< x 10)) 7 | (set a x) 8 | (set b y)) 9 | (printf "%d %d\\n" a b))) 10 | 11 | (function main () -> int 12 | (foo 4 2) 13 | (foo 1 2) 14 | (return 0)) 15 | 16 | ;;## 4 2 17 | ;;## 0 0 18 | -------------------------------------------------------------------------------- /tests/c.when.02.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function foo ((int x) (int y)) -> void 4 | (decl ((int a = 0) 5 | (int b = 0)) 6 | (when (and (> x y) (< x 10)) 7 | (set a x 8 | b y)) 9 | (printf "%d %d\\n" a b))) 10 | 11 | (function main () -> int 12 | (foo 4 2) 13 | (foo 1 2) 14 | (return 0)) 15 | 16 | ;;## 4 2 17 | ;;## 0 0 18 | -------------------------------------------------------------------------------- /tests/c.while.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function strcatx ((char p[]) (char q[])) -> void 4 | (decl ((int i = 0) (int j = 0)) 5 | (while (!= p[i] #\null) 6 | i++) 7 | (while (!= (set p[i++] q[j++]) #\null)))) 8 | 9 | (function main ((int argc) (char **argv)) -> int 10 | (decl ((char str[10])) 11 | (set str[0] #\a) 12 | (set str[0] #\b) 13 | (set str[0] #\c) 14 | (set str[0] #\null) 15 | (strcatx str "foo") 16 | (printf "%s\\n" str) 17 | (return 0))) 18 | 19 | ;;## foo 20 | -------------------------------------------------------------------------------- /tests/cxx.class.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (defmacro cout (item) 4 | `(<< #:std::cout ,item #:std::endl)) 5 | 6 | ;; constructor/desctructor mactolet within class 7 | (class A () 8 | (private 9 | (decl ((bool switch1) 10 | (bool switch2)))) 11 | (public 12 | (constructor () 13 | (set switch1 true 14 | switch2 false) 15 | (cout 10)) 16 | 17 | (constructor ((bool in)) :init ((switch1 in) (switch2 false)) 18 | (cout 11)) 19 | 20 | (constructor ((bool in) (bool out)) :init ((switch1 in) (switch2 out)) 21 | (cout 12)) 22 | 23 | (destructor 24 | (if (and switch1 switch2) 25 | (cout 21) 26 | (cout 20))))) 27 | 28 | ;; costructor/destructor macros with explicit name 29 | (class B () 30 | (public 31 | (constructor ()) 32 | (destructor))) 33 | 34 | (constructor #:B::B () 35 | (cout 30)) 36 | 37 | (destructor #:B::B 38 | (cout 31)) 39 | 40 | 41 | ;; quoty tests 42 | (defmacro className (name) 43 | `(cintern (format nil "~a" ',name))) 44 | 45 | (class (className foobar) () 46 | (public 47 | (constructor () (cout 40)) 48 | (destructor (cout 41)))) 49 | 50 | (defparameter *foo* (className bar)) 51 | (class *foo* () 52 | (public 53 | (constructor () (cout 50)) 54 | (destructor (cout 51)))) 55 | 56 | 57 | 58 | 59 | (function main () -> int 60 | (<< #:std:cout 0 #:std:endl) ; 0 61 | 62 | (decl ((A* a1 = (new (A))) ; 10 63 | (A* a2 = (new (A true))) ; 11 64 | (A* a3 = (new (A false))) ; 11 65 | (A* a4 = (new (A true true)))) ; 12 66 | (delete a1) ; 20 67 | (delete a2) ; 20 68 | (delete a3) ; 20 69 | (delete a4)) ; 21 70 | 71 | (decl ((B b1[3]) ; 30,30,30 72 | (B* b2 = (new B[2]))) ; 30,30 73 | (delete[] b2)) ; 31,31 74 | 75 | ;; quoty tests 76 | (decl (((className foobar) *fb1 = 77 | (new ((className foobar))))) ; 40 78 | (delete fb1)) ; 41 79 | 80 | (let ((foo *foo*)) 81 | (decl ((foo *fb2 = 82 | (new (foo)))) ; 50 83 | (delete fb2))) ; 51 84 | 85 | (return 0)) ; 31, 31, 31 86 | 87 | 88 | ;;## 0 89 | ;;## 10 90 | ;;## 11 91 | ;;## 11 92 | ;;## 12 93 | ;;## 20 94 | ;;## 20 95 | ;;## 20 96 | ;;## 21 97 | ;;## 30 98 | ;;## 30 99 | ;;## 30 100 | ;;## 30 101 | ;;## 30 102 | ;;## 31 103 | ;;## 31 104 | ;;## 40 105 | ;;## 41 106 | ;;## 50 107 | ;;## 51 108 | ;;## 31 109 | ;;## 31 110 | ;;## 31 111 | -------------------------------------------------------------------------------- /tests/cxx.class.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (defmacro cout (item) 4 | `(<< #:std::cout ,item #:std::endl)) 5 | 6 | (class A () 7 | (public 8 | (constructor () nil) 9 | (destructor nil) 10 | (function test () pure -> (void)))) 11 | 12 | (class B ((public A)) 13 | (public 14 | (function test () -> (virtual void) 15 | (cout 1)))) 16 | 17 | (class C ((public B)) 18 | (public 19 | (function test () -> void 20 | (cout 2)))) 21 | 22 | ;; ---- 23 | 24 | (class D () 25 | (public 26 | (function test2 () virtual -> void 27 | (cout 1)))) 28 | 29 | (class E ((public D)) 30 | (public 31 | (function test2 () -> void 32 | (cout 3)))) 33 | 34 | ;; ---- 35 | 36 | (class F () 37 | (public 38 | (function test3 () pure -> void 39 | (cout 1)))) 40 | 41 | (class G ((public F)) 42 | (public 43 | (function test3 () -> void 44 | (cout 4)))) 45 | 46 | ;; ---- 47 | 48 | (function main () -> int 49 | (cout 0) ; 0 50 | (decl ((B* b1 = (new (B))) 51 | (B* b2 = (new (C))) 52 | (D* d = (new (E))) 53 | (F* f = (new (G)))) 54 | (b1->test) ; 1 55 | (b2->test) ; 2 56 | (d->test2) ; 3 57 | (f->test3) ; 4 58 | (delete b1) 59 | (delete b2) 60 | (delete d) 61 | (delete f) 62 | (return 0))) 63 | 64 | ;;## 0 65 | ;;## 1 66 | ;;## 2 67 | ;;## 3 68 | ;;## 4 69 | -------------------------------------------------------------------------------- /tests/cxx.class.02.lisp: -------------------------------------------------------------------------------- 1 | (class foo () 2 | (public 3 | (decl ((int a)))) 4 | (decl ((int b)))) ;; addendum to #62: missing access specifier for outer layer 5 | 6 | (function main () -> int 7 | (decl ((foo f)) 8 | (set f.b 0))) 9 | 10 | ;;## 11 | -------------------------------------------------------------------------------- /tests/cxx.class.03.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | 4 | (class foo1 () 5 | (public 6 | (destructor 7 | (<< cout "~foo1" endl)))) 8 | 9 | (class foo2 () 10 | (public 11 | (destructor virtual 12 | (<< cout "~foo2" endl)))) 13 | 14 | (class bar1 ((public foo1)) 15 | (public 16 | (destructor (<< cout "~bar1" endl)))) 17 | 18 | (class bar2 ((public foo2)) 19 | (public 20 | (destructor (<< cout "~bar2" endl)))) 21 | 22 | (function main () -> int 23 | (decl ((foo1 *f1 = (new bar1)) 24 | (foo2 *f2 = (new bar2))) 25 | (delete f1) 26 | (delete f2)) 27 | (return 0)) 28 | 29 | ;;## ~foo1 30 | ;;## ~bar2 31 | ;;## ~foo2 32 | -------------------------------------------------------------------------------- /tests/cxx.class.04.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (class A () 4 | (public 5 | (private 6 | (protected 7 | (decl ((int a)))) 8 | (decl ((int b)))) 9 | (decl ((int c)))) 10 | (decl ((int d))) 11 | (public 12 | (private 13 | (protected 14 | (decl ((int e))))))) 15 | 16 | (struct B 17 | (private 18 | (decl ((int a)) 19 | (public 20 | (decl ((int b)))))) 21 | (decl ((int c)))) 22 | 23 | (struct C 24 | (private 25 | (decl ((int a)))) 26 | (decl ((int b)))) 27 | 28 | (class D () 29 | (struct DD 30 | (decl ((int a)))) 31 | (decl ((int b))) 32 | (struct DDD 33 | (private 34 | (decl ((int c))))) 35 | (decl ((int d))) 36 | (public 37 | (decl ((int e)))) 38 | (decl ((int f)))) 39 | 40 | 41 | 42 | 43 | (function main () -> int 44 | (decl ((A a) 45 | (B b) 46 | (C c) 47 | (D d)) 48 | 49 | (set a.c 1 50 | b.c 2 51 | c.b 3 52 | d.e 4) 53 | 54 | (printf "%d\\n" a.c) 55 | (printf "%d\\n" b.c) 56 | (printf "%d\\n" c.b) 57 | (printf "%d\\n" d.e) 58 | (return 0))) 59 | 60 | ;;## 1 61 | ;;## 2 62 | ;;## 3 63 | ;;## 4 64 | -------------------------------------------------------------------------------- /tests/cxx.decl.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (decl ((const char* args[2][3] = (clist (clist "f" "o" "o") 4 | (clist "b" "a" "r"))))) 5 | 6 | (function main () -> int (printf "0\\n") (return 0)) 7 | 8 | ;;## 0 9 | -------------------------------------------------------------------------------- /tests/cxx.decl.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (decl ((int *arr1 = (new (array int 100))) 4 | (unsigned int *arr2 = (new (array (unsigned int) 100))))) 5 | 6 | (function main () -> int (printf "0\\n") (return 0)) 7 | 8 | ;;## 0 9 | -------------------------------------------------------------------------------- /tests/cxx.decl.02.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | 4 | (comment "#define FOO 2" :prefix "") 5 | 6 | (function main () -> int 7 | (decl ((int arr[3] {1 1 1}) 8 | (int brr[3] {-1 -1 -1}) 9 | (int crr[3] {FOO FOO FOO}) 10 | (int drr[3] {-FOO -FOO -FOO}) 11 | (int err[3] {arr[1]})) 12 | (printf "%d %d\\n" arr[0] brr[0]) 13 | (printf "%d %d\\n" crr[0] drr[0]) 14 | (printf "%d %d\\n" drr[2] err[0]) 15 | (return 0))) 16 | 17 | ;;## 1 -1 18 | ;;## 2 -2 19 | ;;## -2 1 20 | -------------------------------------------------------------------------------- /tests/cxx.decl.03.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | 4 | (struct Foo 5 | (function bar () -> int (return 29081997))) 6 | 7 | (function main () -> int 8 | (decl ((Foo foo) 9 | (int bar = (foo.bar))) 10 | (<< cout bar endl) 11 | (return 0))) 12 | 13 | ;;## 29081997 14 | -------------------------------------------------------------------------------- /tests/cxx.meta.01.decompose-decl.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (defmacro foo (&body body) 4 | (multiple-value-bind (spec type name init) 5 | (cm-cxx:decompose-declaration body) 6 | `(funcall printf ,(format nil "[~a] [~a] [~a] [~a]\\n" spec type name init)))) 7 | 8 | (function main () -> int 9 | (foo int i) 10 | (foo unsigned long int *p = 0) 11 | (foo int arr[] = (clist 1 2 3)) 12 | (foo int arr[] { 1 2 3 }) 13 | (return 0)) 14 | 15 | ;;## [nil] [int] [i] [nil] 16 | ;;## [(unsigned long)] [int] [(targ-of (quoty p))] [0] 17 | ;;## [nil] [int] [(aref (quoty arr))] [(clist 1 2 3)] 18 | ;;## [nil] [int] [(aref (quoty arr))] [(1 2 3)] 19 | 20 | -------------------------------------------------------------------------------- /tests/cxx.misc.cast.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | (using-namespace std) 4 | 5 | (class A () 6 | (decl ((int a)))) 7 | 8 | (class B ((public A)) 9 | (decl ((int b)))) 10 | 11 | (function main () -> int 12 | (decl ((int foo = 0) 13 | (const int* bar = (const-cast const int* &foo)) 14 | (float foo2 = 3.14) 15 | (B* foo3 = (new B)) 16 | (A* foo4 = (dynamic-cast A* foo3))) 17 | (set (dref (const-cast int* bar)) 1) 18 | (<< cout foo endl) 19 | (<< cout (static-cast int foo2) endl) 20 | (<< cout (oref (typeid foo3) (name)) endl) 21 | (<< cout (oref (typeid foo4) (name)) endl) 22 | (return 0))) 23 | 24 | ;;## 1 25 | ;;## 3 26 | ;;## P1B 27 | ;;## P1A 28 | -------------------------------------------------------------------------------- /tests/cxx.misc.foreach.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (defmacro cout (item) 4 | `(<< #:std::cout ,item #:std::endl)) 5 | 6 | (function main () -> int 7 | (for ((int i = 0) (< i 10) ++i)) 8 | (cout "should appear only once.") 9 | (decl ((int i = 0)) 10 | (for (() (< i 10) ++i) 11 | (cout i))) 12 | (for ((int i = 0) (< i 10) i++) 13 | (cout i)) 14 | (decl ((int arr[] = (clist 1 2 3 4))) 15 | (for ((int elem) arr) 16 | (cout elem)) 17 | (for ((const int& elem) arr) 18 | (cout elem))) 19 | (decl ((int arr[4][4] = (clist (clist 0) 20 | (clist 0) 21 | (clist 4 3 2 1) 22 | (clist 0)))) 23 | (for ((const int& elem) arr[2]) 24 | (cout elem))) 25 | (return 0)) 26 | 27 | ;;## should appear only once. 28 | ;;## 0 29 | ;;## 1 30 | ;;## 2 31 | ;;## 3 32 | ;;## 4 33 | ;;## 5 34 | ;;## 6 35 | ;;## 7 36 | ;;## 8 37 | ;;## 9 38 | ;;## 0 39 | ;;## 1 40 | ;;## 2 41 | ;;## 3 42 | ;;## 4 43 | ;;## 5 44 | ;;## 6 45 | ;;## 7 46 | ;;## 8 47 | ;;## 9 48 | ;;## 1 49 | ;;## 2 50 | ;;## 3 51 | ;;## 4 52 | ;;## 1 53 | ;;## 2 54 | ;;## 3 55 | ;;## 4 56 | ;;## 4 57 | ;;## 3 58 | ;;## 2 59 | ;;## 1 60 | -------------------------------------------------------------------------------- /tests/cxx.misc.lambda.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | (include ) 4 | 5 | (using-namespace std) 6 | 7 | (defmacro cout (item) 8 | `(<< cout ,item endl)) 9 | 10 | (defmacro arr () 11 | `(instantiate array (int) (3))) 12 | 13 | (defmacro vec-print (vec) 14 | `(for ((auto it = (funcall (oref ,vec begin))) 15 | (!= it (funcall (oref ,vec end))) 16 | ++it) 17 | (cout *it))) 18 | 19 | 20 | (class bar () 21 | (public 22 | (decl ((int i)) 23 | (constructor ((int i)) (= this->i i)) 24 | (function test ((int i)) -> int 25 | (decl ((auto l = (lambda-function (this i) () (progn 26 | (set this->i i) 27 | (return (+ i 1)))))) 28 | (return (l))))))) 29 | 30 | 31 | (function main () -> int 32 | (decl ((int i = 1) 33 | (int k = 2) 34 | (auto l = (lambda-function (=) ;; capture 35 | ((const int& a) (const int& b)) ;; parameter 36 | mutable ;; qualifier 37 | -> ;; sentinel 38 | (const int) ;; return type 39 | (progn 40 | ++i 41 | ++k 42 | (return (* i k a b))))) ;; body 43 | (auto ll = (lambda-function (&) ((const int & a)(const int& b)) -> int 44 | (progn ++i ++k (return (l a b))))) 45 | (auto lll = (lambda-function (i k) () -> int (return (+ i k))))) 46 | (cout "init") 47 | (cout i) 48 | (cout k) 49 | (cout "copy capture") 50 | (cout (l 2 3)) 51 | (cout i) 52 | (cout k) 53 | (cout "ref capture") 54 | (cout (ll 2 3)) 55 | (cout i) 56 | (cout k) 57 | (cout "pre modification copy capture") 58 | (cout (lll)) 59 | (cout "curr i and k") 60 | (cout i) 61 | (cout k)) 62 | 63 | 64 | (cout "this capture") 65 | (decl ((bar (b 10))) 66 | (cout b.i) 67 | (cout (b.test 20)) 68 | (cout b.i)) 69 | 70 | (cout "no capture") 71 | (decl (((arr) foo = { 300 100 200 })) 72 | (funcall sort (foo.begin) 73 | (foo.end) 74 | (lambda-function () ((const int& a)(const int& b)) (return (< a b)))) 75 | (vec-print foo)) 76 | 77 | (return 0)) 78 | 79 | ;;## init 80 | ;;## 1 81 | ;;## 2 82 | ;;## copy capture 83 | ;;## 36 84 | ;;## 1 85 | ;;## 2 86 | ;;## ref capture 87 | ;;## 72 88 | ;;## 2 89 | ;;## 3 90 | ;;## pre modification copy capture 91 | ;;## 3 92 | ;;## curr i and k 93 | ;;## 2 94 | ;;## 3 95 | ;;## this capture 96 | ;;## 10 97 | ;;## 21 98 | ;;## 20 99 | ;;## no capture 100 | ;;## 100 101 | ;;## 200 102 | ;;## 300 103 | -------------------------------------------------------------------------------- /tests/cxx.misc.operators.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (defmacro cout (item) 4 | `(<< #:std::cout ,item #:std::endl)) 5 | 6 | (class A () 7 | (public 8 | (function operator[] ((int i)) -> int 9 | (cout i) 10 | (return 0)))) 11 | 12 | 13 | (function main () -> int 14 | (cout 0) ; 0 15 | (decl ((A a) 16 | (int i = a[1])) ; 1 17 | (return 0))) 18 | 19 | ;;## 0 20 | ;;## 1 21 | -------------------------------------------------------------------------------- /tests/cxx.misc.reader.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (function test1 (#+nil (int a) #-nil (int b)) -> int 4 | #+nil 5 | (return a) 6 | #-nil 7 | (return b)) 8 | 9 | (function test2 (#-nil (int a) #+nil (int b)) -> int 10 | #-nil 11 | (return a) 12 | #+nil 13 | (return b)) 14 | 15 | 16 | (function main () -> int 17 | (printf "%i\\n" (test1 0)) 18 | (printf "%i\\n" (test2 1)) 19 | (return 0)) 20 | 21 | ;;## 0 22 | ;;## 1 23 | -------------------------------------------------------------------------------- /tests/cxx.misc.stmt-expr.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | 4 | (function main () -> int 5 | (<< cout "foo" endl) 6 | (if 1 7 | (<< cout 0 endl)) 8 | (return 0)) 9 | 10 | ;;## foo 11 | ;;## 0 12 | -------------------------------------------------------------------------------- /tests/cxx.misc.trycatch.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | (using-namespace std) 4 | 5 | (function bar1 () -> int 6 | (throw 1)) 7 | 8 | (function bar2 () -> int 9 | (throw (logic_error "not logical"))) 10 | 11 | (function bar3 () -> int 12 | (throw (runtime_error "error"))) 13 | 14 | (function bar4 () -> int 15 | (return 123)) 16 | 17 | (function bar5 () -> int 18 | (throw 0.0f)) 19 | 20 | (typedef int (fpointer fn ())) 21 | 22 | (function foo ((fn f)) -> int 23 | (catching (((int i) 24 | (<< cout "caught int: " i endl)) 25 | ((runtime_error &e) 26 | (<< cout "runtime error: " (e.what) endl)) 27 | ((exception &e) 28 | (<< cout "base exception: " (e.what) endl)) 29 | (t 30 | (<< cout "whatever!" endl))) 31 | (decl ((int got = (f))) 32 | (<< cout "got value: " got endl) 33 | (return got)))) 34 | 35 | (function main () -> int 36 | (foo bar1) 37 | (foo bar2) 38 | (foo bar3) 39 | (foo bar4) 40 | (foo bar5) 41 | (return 0)) 42 | 43 | ;;## caught int: 1 44 | ;;## base exception: not logical 45 | ;;## runtime error: error 46 | ;;## got value: 123 47 | ;;## whatever! 48 | -------------------------------------------------------------------------------- /tests/cxx.namespace.00.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | (namespace 'foo 4 | (typedef int bar)) 5 | (decl (((from-namespace 'foo 'bar) x = 9)) 6 | (function main () -> int 7 | (<< cout x endl) 8 | (return 0))) 9 | 10 | ;;## 9 11 | -------------------------------------------------------------------------------- /tests/cxx.namespace.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | (namespace 'foo 4 | (namespace 'fuu 5 | (namespace 'foh 6 | (typedef int bar)))) 7 | (decl (((from-namespace 'foo 'fuu 'foh 'bar) x = 9)) 8 | (function main () -> int 9 | (<< cout x endl) 10 | (return 0))) 11 | 12 | ;;## 9 13 | -------------------------------------------------------------------------------- /tests/cxx.namespace.02.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | (namespace 'foo 4 | (typedef int bar)) 5 | (decl (((from-namespace 'foo 'bar) x = 9)) 6 | (function test (((from-namespace 'foo 'bar) y)) -> int 7 | (return y)) 8 | (function main () -> int 9 | (<< cout (test x) endl) 10 | (return 0))) 11 | 12 | ;;## 9 13 | -------------------------------------------------------------------------------- /tests/cxx.namespace.03.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | (namespace 'foo 4 | (typedef int bar)) 5 | (decl (((from-namespace 'foo 'bar) x = 9)) 6 | (function test ((const (from-namespace 'foo 'bar) y)) -> int 7 | (return y)) 8 | (function main () -> int 9 | (<< cout (test x) endl) 10 | (return 0))) 11 | 12 | ;;## 9 13 | -------------------------------------------------------------------------------- /tests/cxx.namespace.04.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | (namespace 'foo 4 | (typedef int bar)) 5 | (decl (((from-namespace 'foo 'bar) x = 9)) 6 | (function test ((const (from-namespace 'foo 'bar) y)) -> (from-namespace 'foo 'bar) 7 | (return y)) 8 | (function main () -> int 9 | (<< cout (test x) endl) 10 | (return 0))) 11 | 12 | ;;## 9 13 | -------------------------------------------------------------------------------- /tests/cxx.namespace.05.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (using-namespace std) 3 | (namespace 'foo 4 | (typedef int bar)) 5 | (decl (((from-namespace 'foo 'bar) x = 9)) 6 | (function test ((const (from-namespace 'foo 'bar) y)) -> (const (from-namespace 'foo 'bar)) 7 | (return y)) 8 | (function main () -> int 9 | (<< cout (test x) endl) 10 | (return 0))) 11 | 12 | ;;## 9 13 | -------------------------------------------------------------------------------- /tests/cxx.namespace.06.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (decl ((#:std:string x = "fooo") 3 | (int y = #:std:string:npos)) 4 | (function main () -> int 5 | (<< #:std:cout 0 #:std:endl) 6 | (return 0))) 7 | 8 | ;;## 0 9 | -------------------------------------------------------------------------------- /tests/cxx.namespace.07.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (namespace glm 4 | (decl ((int value-ptr)))) 5 | (decl ((int x = #:glm:value-ptr))) 6 | (function main () -> int 7 | (<< #:std:cout 0 #:std:endl) 8 | (return 0)) 9 | 10 | ;;## 0 11 | -------------------------------------------------------------------------------- /tests/cxx.namespace.08.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | 3 | (namespace foo-bar 4 | (decl ((int x-y = 0))) 5 | (function bla-blub ((int x)) -> int (return 0))) 6 | 7 | (decl ((int x = #:foo-bar:x-y) 8 | (int y = (#:foo-bar:bla-blub x)) 9 | (int z = (funcall #:foo-bar:bla-blub #:foo-bar:x-y))) 10 | (function foo () -> int 11 | (<< #:std:cout x y z #:std:endl) 12 | (return (#:foo-bar:bla-blub #:foo_bar:x_y)))) 13 | 14 | (decl ((int xx = #:foo_bar:x_y) 15 | (int yy = (#:foo_bar:bla_blub xx)) 16 | (int zz = (funcall #:foo_bar:bla_blub #:foo_bar:x_y))) 17 | (function main () -> int 18 | (<< #:std:cout xx yy zz #:std:endl) 19 | (return (foo)))) 20 | 21 | ;;## 000 22 | ;;## 000 23 | -------------------------------------------------------------------------------- /tests/cxx.namespace.09.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | 4 | (function test1 ((const #:std:string &x)) -> void 5 | (<< #:std:cout x #:std:endl)) 6 | 7 | (function test2 ((const #:std:string& x)) -> void 8 | (<< #:std:cout x #:std:endl)) 9 | 10 | (function main () -> int 11 | (decl ((#:std:string foo = "foo")) 12 | (test1 foo) 13 | (test2 foo) 14 | (return 0))) 15 | 16 | ;;## foo 17 | ;;## foo 18 | -------------------------------------------------------------------------------- /tests/cxx.namespace.10.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | 4 | (function test () -> void 5 | (<< #:std:cout "global" #:std:endl)) 6 | 7 | (namespace local 8 | (namespace nested 9 | (function test () -> void 10 | (<< #:std:cout "nested" #:std:endl))) 11 | (function test () -> void 12 | (<< #:std:cout "local" #:std:endl)) 13 | 14 | (function foo () -> void 15 | ;; current namespace 16 | (test) 17 | (funcall (from-namespace local test)) 18 | 19 | ;; global scope 20 | (#::test) 21 | (#:nil:test) 22 | (funcall (from-namespace nil test)) 23 | 24 | ;; nested namespace 25 | (#:nested:test) 26 | (#:local:nested:test) 27 | (funcall (from-namespace local nested test)))) 28 | 29 | (function main () -> int 30 | (#:local:foo) 31 | (return 0)) 32 | 33 | ;;## local 34 | ;;## local 35 | ;;## global 36 | ;;## global 37 | ;;## global 38 | ;;## nested 39 | ;;## nested 40 | ;;## nested 41 | -------------------------------------------------------------------------------- /tests/cxx.templates.01.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | (include ) 4 | (using-namespace std) 5 | 6 | (function foo () -> (const (reference-type (instantiate vector (string))))) 7 | 8 | (function main () -> int 9 | (<< cout 0 endl) 10 | (return 0)) 11 | 12 | ;;## 0 13 | -------------------------------------------------------------------------------- /tests/cxx.templates.02.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | (using-namespace std) 4 | 5 | (template ((typename T) (typename T2)) 6 | (function foo ((T a) (T2 b)) -> T 7 | (return (+ a((instantiate static_cast (float)) b))))) 8 | 9 | 10 | (function main () -> int 11 | (<< cout (foo 1.1f 1) endl) 12 | (return 0)) 13 | 14 | ;;## 2.1 15 | -------------------------------------------------------------------------------- /tests/cxx.templates.03.lisp: -------------------------------------------------------------------------------- 1 | (include ) 2 | (include ) 3 | (using-namespace std) 4 | 5 | (template ((typename foo)) 6 | (class test () 7 | (public 8 | (decl (((instantiate vector (int)) veci)))))) 9 | 10 | (instantiate-explicit (class (instantiate test (int)) ())) 11 | 12 | 13 | (function main () -> int 14 | (decl (((instantiate test (int)) foo)) 15 | (foo.veci.push_back 1) 16 | (<< cout (foo.veci.back) endl) 17 | (return 0))) 18 | 19 | ;;## 1 20 | -------------------------------------------------------------------------------- /util/build/dump-c.lisp.in: -------------------------------------------------------------------------------- 1 | ;; @configure_input@ 2 | (require :asdf) 3 | (let ((asdf:*central-registry* (cons #P"@abs_top_srcdir@/" asdf:*central-registry*))) 4 | (require :c-mera) 5 | (require :cms-c)) 6 | (push :cm-c *features*) 7 | (setf c-mera:*generator* :c) 8 | (cm-c::save "cm-c") 9 | (quit) 10 | -------------------------------------------------------------------------------- /util/build/dump-cuda.lisp.in: -------------------------------------------------------------------------------- 1 | ;; @configure_input@ 2 | (require :asdf) 3 | (let ((asdf:*central-registry* (cons #P"@abs_top_srcdir@/" asdf:*central-registry*))) 4 | (require :c-mera) 5 | (require :cms-cuda)) 6 | (push :cm-cuda *features*) 7 | (setf c-mera:*generator* :cuda) 8 | (cm-cuda::save "cm-cuda") 9 | (quit) 10 | -------------------------------------------------------------------------------- /util/build/dump-cxx.lisp.in: -------------------------------------------------------------------------------- 1 | ;; @configure_input@ 2 | (require :asdf) 3 | (let ((asdf:*central-registry* (cons #P"@abs_top_srcdir@/" asdf:*central-registry*))) 4 | (require :c-mera) 5 | (require :cm-c) 6 | (require :cmu-c) 7 | (require :cm-c++) 8 | (require :cmu-c++) 9 | (require :cms-c++)) 10 | (push :cm-c++ *features*) 11 | (push :cm-cxx *features*) 12 | (setf c-mera:*generator* :cxx) 13 | (cm-c++::save "cm-cxx") 14 | (quit) 15 | -------------------------------------------------------------------------------- /util/build/dump-glsl.lisp.in: -------------------------------------------------------------------------------- 1 | ;; @configure_input@ 2 | (require :asdf) 3 | (let ((asdf:*central-registry* (cons #P"@abs_top_srcdir@/" asdf:*central-registry*))) 4 | (require :c-mera) 5 | (require :cms-glsl)) 6 | (push :cm-glsl *features*) 7 | (setf c-mera:*generator* :glsl) 8 | (cm-glsl::save "cm-glsl") 9 | (quit) 10 | -------------------------------------------------------------------------------- /util/build/dump-opencl.lisp.in: -------------------------------------------------------------------------------- 1 | ;; @configure_input@ 2 | (require :asdf) 3 | (let ((asdf:*central-registry* (cons #P"@abs_top_srcdir@/" asdf:*central-registry*))) 4 | (require :c-mera) 5 | (require :cms-opencl)) 6 | (push :cm-opencl *features*) 7 | (push :cm-ocl *features*) 8 | (setf c-mera:*generator* :ocl) 9 | (cm-opencl::save "cm-opencl") 10 | (quit) 11 | -------------------------------------------------------------------------------- /util/emacs/cm-mode.el: -------------------------------------------------------------------------------- 1 | (defvar cm-mode-kwlist nil) 2 | (defvar cm-mode-kwexp nil) 3 | 4 | ;; Loading of indent symbols inspired by Pascal Bourguignon 5 | ;; http://lists.gnu.org/archive/html/help-gnu-emacs/2008-08/msg00050.html 6 | ;; Keyword handling inspired by 7 | ;; http://www.emacswiki.org/emacs/AddKeywords 8 | ;; http://www.gnu.org/software/emacs/manual/html_node/elisp/Customizing-Keywords.html 9 | ;; Mode layout by Chris Wellons 10 | ;; http://nullprogram.com/blog/2013/02/06 11 | 12 | (defun read-expressions () 13 | (while (ignore-errors 14 | (let ((exp (read (current-buffer)))) 15 | (if (eq exp :keywords) 16 | (setq cm-mode-kwlist (append cm-mode-kwlist (read (current-buffer)))) 17 | (when (and (listp exp) 18 | (symbolp (car exp)) 19 | (numberp (cadr exp)) 20 | (= (length exp) 2)) 21 | ;; prior to 2022 lisp-mode relied on 'lisp-indent-function 22 | (put (car exp) 'common-lisp-indent-function (cadr exp)))) 23 | t)))) 24 | 25 | (defun load-indent-kw-file-if-exists (filename) 26 | (if (file-exists-p filename) 27 | (progn 28 | (message "cm-mode: reading indent file %s." filename) 29 | (with-temp-buffer 30 | (insert-file-literally filename) 31 | (read-expressions))) 32 | (message "cm-mode: indent file %s not found." filename))) 33 | 34 | ;;;###autoload 35 | (define-minor-mode cm-mode 36 | "C-Mera minor mode that provides somd indentation and keyword support." 37 | :lighter " c-mera" 38 | (load-indent-kw-file-if-exists "~/.emacs.d/cm.indent") 39 | (load-indent-kw-file-if-exists "cm.indent") 40 | (load-indent-kw-file-if-exists "cgen.indent") ; backwards compatibility 41 | (when cm-mode-kwlist 42 | (let ((tail (apply #'concat (mapcar #'(lambda (s) (concat "\\|" (symbol-name s))) (cdr cm-mode-kwlist))))) 43 | (setq cm-mode-kwexp (concat "\\<\\(" (symbol-name (car cm-mode-kwlist)) tail "\\)\\>")) 44 | (font-lock-fontify-buffer))) 45 | (message "Loaded C-Mera minor mode.")) 46 | 47 | (provide 'cm-mode) 48 | 49 | ;;;###autoload 50 | (add-hook 'cm-mode-hook 51 | (lambda () 52 | (when cm-mode-kwexp 53 | (font-lock-add-keywords nil 54 | `((,cm-mode-kwexp . font-lock-keyword-face)))))) 55 | -------------------------------------------------------------------------------- /util/emacs/cm.indent: -------------------------------------------------------------------------------- 1 | (decl 1) 2 | (function 4) 3 | (implement 2) 4 | (for 1) 5 | 6 | (class 2) 7 | (struct 1) 8 | (union 1) 9 | (constructor 1) 10 | (destructor 0) 11 | 12 | :keywords (for decl function continue return sizeof typedef 13 | void int float double long char unsigned signed short auto bool enum struct while 14 | switch 15 | include pragma comment 16 | inline const volatile 17 | true false 18 | private protected public 19 | class template instantiate constructor destructor typename virtual pure cout endl 20 | using-namespace from-namespace :init 21 | main printf) 22 | -------------------------------------------------------------------------------- /util/vim/lisp_cmera.vim: -------------------------------------------------------------------------------- 1 | " force plugin-order 2 | call vlime#plugin#Setup() 3 | 4 | syntax enable 5 | set nolisp 6 | set ts=8 7 | 8 | if exists('g:CmeraPluginLoaded') 9 | finish 10 | endif 11 | let g:CmeraPluginLoaded = 1 12 | 13 | if !exists('g:CmeraPluginVerbose') 14 | let g:CmeraPluginVerbose = 0 15 | endif 16 | 17 | if !exists('g:vlime_indent_keywords') 18 | if !exists('g:vlime_default_indent_keywords') 19 | echoerr "Cmera-Plugin requires Vlime" 20 | finish 21 | endif 22 | let g:vlime_indent_keywords = g:vlime_default_indent_keywords 23 | endif 24 | 25 | function! Cmera_read_indent_file(file) 26 | if g:CmeraPluginVerbose 27 | echo "Reading indent from " . a:file 28 | endif 29 | " generate a list of extensions for vlime_indent_keywords 30 | let cat_and_remove_comments = 'cat "'.a:file.'" | sed -e "s/;.*//"' 31 | " let build_indent_map = 'sed -e "s/[^(]*(\(\S\+\)\s\+\([0-9]\+\)).*/let g:vlime_indent_keywords.\1 = \2/"' 32 | let build_indent_map = 'sed -e "s/[^(]*(\(\S\+\)\s\+\([0-9]\+\)).*/let g:vlime_indent_keywords[\"\1\"] = \2/"' 33 | let limit_to_indent_map = 'grep vlime_indent_keywords' 34 | let indent_forms = split(system(cat_and_remove_comments.' | '.build_indent_map.' | '.limit_to_indent_map), '\n') 35 | if g:CmeraPluginVerbose > 1 36 | for stmt in indent_forms 37 | echo " - ".stmt 38 | endfor 39 | endif 40 | " apply it 41 | for stmt in indent_forms 42 | execute(stmt) 43 | endfor 44 | " get a list of keywords to highlight 45 | let remove_linebreaks = "tr -d '\n'" 46 | let empty_if_no_keywords = "grep ':keywords'" 47 | let keywords_only = 'sed -e "s/.*:keywords\s\+(\([^)]\+\))/\1/"' 48 | let collapse_ws = 'sed -e "s/\s\+/ /g"' 49 | let keywords = split(system(cat_and_remove_comments.' | '.remove_linebreaks.' | '.empty_if_no_keywords.' | '.keywords_only.' | '.collapse_ws), ' ') 50 | let kw_list = "" 51 | " build a list of keywords for autocommand and register it" 52 | if g:CmeraPluginVerbose > 1 53 | for keyword in keywords 54 | echo " + ".keyword 55 | endfor 56 | endif 57 | for keyword in keywords 58 | let kw_list = kw_list . " " . keyword 59 | endfor 60 | if kw_list != "" 61 | execute("syn keyword lispFunc" . kw_list) 62 | endif 63 | endfunction 64 | 65 | function! Cmera_find_indent_file(...) 66 | let dir = (a:0 >= 1) ? a:1 : getcwd() 67 | let file = dir . "/cm.indent" 68 | if filereadable(file) 69 | if g:CmeraPluginVerbose 70 | echo "There is a CM indent file: " . file 71 | endif 72 | call Cmera_read_indent_file(file) 73 | else 74 | if g:CmeraPluginVerbose 75 | echo "There is NO CM indent file in " . dir 76 | endif 77 | endif 78 | if dir != "/" 79 | call Cmera_find_indent_file(fnamemodify(dir, ':h:p')) 80 | endif 81 | endfunction 82 | 83 | function! Cmera_load_files() 84 | if exists('g:cmera_base_indent_file') 85 | if filereadable(g:cmera_base_indent_file) 86 | call Cmera_read_indent_file(g:cmera_base_indent_file) 87 | else 88 | echoerr "Cannot open c-mera base indent file: " . g:cmera_base_indent_file 89 | endif 90 | else 91 | if g:CmeraPluginVerbose 92 | echo "No base indent file specified" 93 | endif 94 | endif 95 | call Cmera_find_indent_file() 96 | endfunction 97 | 98 | call Cmera_load_files() 99 | 100 | au BufEnter *.lisp call Cmera_load_files() 101 | --------------------------------------------------------------------------------