├── LICENSE.txt ├── README.org ├── bare-metal.lisp ├── cl-cpp-generator.asd ├── cover └── cover-index.html ├── cp.lisp ├── doc ├── ex1.lisp ├── makefile ├── screen_dsp_fsm_diagrams.png └── screen_emitted_code.png ├── linker-cmd-file.lisp └── test.lisp /LICENSE.txt: -------------------------------------------------------------------------------- 1 | cl-cpp-generator is by Martin Kielhorn , 2016-2017. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 12 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 13 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 14 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 15 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 16 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 17 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 18 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * CL-CPP-GENERATOR 2 | 3 | ** Introduction 4 | 5 | Note: This code is obsolete. I work on https://github.com/plops/cl-cpp-generator2 now. 6 | 7 | 8 | The purpose of this Lisp package is to bring the power of Common Lisp 9 | macros to C or C++ source code. 10 | 11 | This project provides the Common Lisp function ~emit-cpp &key code 12 | str~. It receives a list of special s-expressions and emits 13 | corresponding C++ code into a string. 14 | 15 | Please look at test.lisp in order to learn how to use these 16 | s-expressions. 17 | 18 | The semantics of the s-expressions are very close to C or C++. This is 19 | not a transpiler like parenscript that converts s-expressions to 20 | javascript or varjo that converts s-expressions to OpenGL shading 21 | language. This means it is entirely up to you if you generate C or C++ 22 | code. The lisp package knows nothing about the functions you use or 23 | define, it can't check the validity of your type assignments. 24 | 25 | There are two advantage compared to parenscript and varjo. The 26 | generated code can be easy to read and you can always fall back to 27 | dumping a string if you can't figure out how a certain language 28 | feature should be expressed as s-expressions. In particular I gave up 29 | very early on writing C++ template types with s-expressions. They are 30 | just too much of a mess already. 31 | 32 | I feel the s-expressions of cl-cpp-generator give me still a lot of 33 | power to generate lot's of boring, repetetive code. 34 | 35 | A tiny bit of 'intelligence' is in the function write-source. This 36 | function only keeps track of hashes writes code into a C source when 37 | the contents have changed. 38 | 39 | Recently, I experimented with a code generator for Golang ( 40 | https://github.com/plops/cl-golang-generator) that has a bit of 41 | cleverness to keep track of variable types. 42 | 43 | This is the first in a series of code generators. 44 | 45 | - https://github.com/plops/cl-cpp-generator I tried this generator 46 | with C/C++/ISPC/OpenCL/Cuda. It was my first attempt. The largest 47 | project with this is a firmware for a microcontroller. The difficult 48 | part is to get placement of semicolons right. I'm not terribly happy 49 | with the current solution. People don't like that every function 50 | call has to be explicitly stated as such. Initially I thought it 51 | would help me to add function parameter completion in emacs. But I 52 | never figured out how to do that and in later code generators I 53 | simplified the lisp syntax. 54 | 55 | - https://github.com/plops/cl-ada-generator (abandoned) I always 56 | wanted to have a VHDL code generator and thought that ADA would be a 57 | good target to support a similar language. Unfortunately ADA and 58 | VHDL have a lot of syntactic constructs which I find difficult to 59 | express in Lisp semantics that I can remember. So I stopped working 60 | in this direction. 61 | 62 | - https://github.com/plops/cl-py-generator At a new job I generated 63 | LOTS of python code (75k lines) with this generator. The difficult 64 | part was to get indents right. It works really well. I should 65 | backport some features from cl-golang-generator: Variable type 66 | declaration, when, unless, unitary - and unitary /, logior, logand, 67 | incf, decf. 68 | 69 | - https://github.com/plops/cl-js-generator I played around with webrtc 70 | and webgl in the browser. I used parenscript before and I really 71 | like the way it upholds lisp semantics (every expression returns a 72 | value). However, the generated javascript can be difficult to read 73 | (and compare to s-expressions). For this project my goal was to have 74 | a very minimal mapping from s-expressions to javascript. Turns out 75 | converting lisp to javascript is very straightforward. 76 | 77 | - https://github.com/plops/cl-wolfram-generator (abandoned) At some 78 | point I was able to download a wolfram language license. I think 79 | this language is very close to Lisp. I tried some code generation 80 | but the free license would only work on one computer which is not 81 | how I work. 82 | 83 | - https://github.com/plops/cl-yasm-golang (abandoned for now, FIXME I 84 | accidentally called this golang and not generator). I was playing 85 | with the idea to program bare to the metal with either LLVM IR or 86 | amd64 assembly. Some prototyping indicated that this has extra 87 | challenges that can't be easily addressed in my 88 | 'single-function-code-generator' approach. These are distributing 89 | variables on registers, memory handling. Also I'm not sure how much 90 | or if I could immediatly profit from existing tooling if I dump 91 | assembly or machine code. 92 | 93 | - https://github.com/plops/cl-golang-generator I used this to learn a 94 | bit of Go. I implemented quite a few examples of the Golang 95 | Programming book. In particular I like how straight forward it was 96 | to add common lisp type declarations. I'm very happy with how this 97 | experiment turned out. Golang is an expressive, simple 98 | language. Implementing the code generator was much faster than my C 99 | generator (because I don't have to think about 100 | semicolons). Distributing the binaries is much easier than Python 101 | code. They are however so large (>20Mb) that I wonder if writing 102 | Common Lisp directly wouldn't be the better approach. 103 | 104 | - https://github.com/plops/cl-kotlin-generator I just started 105 | that. The language looks very similar to python or golang but 106 | interacting with the android build environment seems to be rather 107 | cumbersome. 108 | 109 | I'm not happy with differences that currently exist between the code 110 | generators. Currently, a conditional in cl-py-generator code looks 111 | like this: 112 | 113 | #+BEGIN_QUOTE 114 | (if (< a 0) 115 | (do0 (print "bla"))) 116 | #+END_QUOTE 117 | 118 | Whereas cl-cpp-generator expects this: 119 | 120 | #+BEGIN_QUOTE 121 | (if (< a 0) 122 | (statements (print "bla"))) 123 | #+END_QUOTE 124 | 125 | My hope is that eventually all these code generators converge to have 126 | the same s-expressions with semantics that are as close as possible to 127 | Common Lisp. 128 | 129 | 130 | Occasionally, I add small repositories with self-contained example 131 | programs that use cl-cpp-generator. They all contain a gen.lisp file 132 | that contains the s-expressions to generates C++ code. Even though the 133 | C++ code is automatically generated I keep them in the source/ folder 134 | of the repositories. 135 | 136 | 137 | - https://github.com/plops/cl-gen-glfw Interactive programming example: Open a GLFW window and dlopens a library that emits OpenGL calls. This library source can be modified/recompiled/reloaded while the program keeps running. 138 | 139 | - https://github.com/plops/cl-gen-ispc-mandelbrot Emit C++ code with Intel Threading Building Blocks and Intel ISPC SIMD compiler that computes the mandelbrot set. 140 | 141 | - https://github.com/plops/cl-gen-opencv Simple example of how to call the C++ image processing library OpenCV. This example shows how to do 2D interpolation. It loads a PNG image and displays a distorted version. 142 | 143 | - https://github.com/plops/cl-gen-cufft Call Nvidia CUFFT library to perform a multi-dimensional Fourier transform on the GPU. The code draws a spherical shell into a 3D volume. 144 | 145 | - https://github.com/plops/cl-gen-fft Implementation of a one-dimensional power-of-two Fourier Transform. The algorithm is from Wikipedia. I use Lisp to unroll the C++ code more than it is usually done. I find the function bit_reverse_copy in https://github.com/plops/cl-gen-fft/blob/master/source/main.cpp particularly instructive. 146 | 147 | - https://github.com/plops/cl-gen-qt-thing A small GUI program that uses a QT canvas. When writing this I learned that writing GUIs with QT takes quite some effort. Too much, in my opinion. 148 | 149 | - https://github.com/plops/cl-gen-cpp-wasm Spin up a web server in 150 | Common Lisp and host a web assembly program that sums up an array of 151 | numbers. I deliberately use a very low level approach 152 | https://dassur.ma/things/c-to-webassembly/ to learn about web 153 | assembly. 154 | 155 | - https://github.com/plops/cl-gen-cuda-try Code generators for 1d and 156 | 2d fast fourier transforms on CPU and CUDA. For CUDA I used Google's 157 | free colab GPU instances. I really like how the CPU implementation 158 | turned out. I actually understood the algorithm better by looking at 159 | the generated code. I'm not happy with the verboseness of CUDA's 160 | complex variables. The SIMD version is a nightmare. 161 | 162 | ** Installation 163 | 164 | Clone the repository into Quicklisps local-projects folder: 165 | 166 | #+BEGIN_SRC 167 | cd ~/quicklisp/local-projects 168 | git clone https://github.com/plops/cl-cpp-generator 169 | #+END_SRC 170 | 171 | If you want to add the code to a lisp that is alreay running, you will have to call: 172 | 173 | #+BEGIN_SRC common-lisp 174 | (ql:register-local-projects) 175 | #+END_SRC 176 | 177 | I don't think this is required if you start a new instance of Common 178 | Lisp. In that case quicklisp will find the new folder during its 179 | initialization. 180 | 181 | I develop with SBCL, so for now that is the only supported implementation. 182 | 183 | Place the following code into a .lisp file and execute the file, i.e. in Slime press C-c C-k. 184 | 185 | 186 | #+BEGIN_SRC common-lisp 187 | (eval-when (:compile-toplevel :execute :load-toplevel) 188 | (ql:quickload :cl-cpp-generator)) 189 | 190 | (in-package :cl-cpp-generator) 191 | 192 | (with-open-file (s "emitted_code.cpp" 193 | :direction :output 194 | :if-exists :supersede 195 | :if-does-not-exist :create) 196 | (emit-cpp 197 | :str s 198 | :clear-env t 199 | :code 200 | `(with-compilation-unit 201 | (include )))) 202 | #+END_SRC 203 | 204 | This will output a line with an include statement into the file 205 | emitted_code.cpp. To write more you can add additional code in in the 206 | with-compilation-unit expression and re-execute the surrounding 207 | with-open-file with C-M-x. 208 | 209 | 210 | ** Using macros 211 | 212 | This an example to that defines and uses a macro. emit-cpp calls the 213 | macroexpand of the host compiler. That is why either defmacro or 214 | macrolet can be used to define the macro. 215 | 216 | #+BEGIN_SRC common-lisp 217 | (eval-when (:compile-toplevel :execute :load-toplevel) 218 | (ql:quickload :cl-cpp-generator)) 219 | 220 | (in-package :cl-cpp-generator) 221 | 222 | (defmacro with-glfw-window ((win &key (w 512) (h 512) (title "glfw")) &body body) 223 | `(let ((,win :type GLFWwindow*)) 224 | (if (! (funcall glfwInit)) 225 | (statements (return -1))) 226 | (setf ,win (funcall glfwCreateWindow ,w ,h (string ,title) NULL NULL)) 227 | (if (! ,win) 228 | (statements (funcall glfwTerminate) 229 | (return -1))) 230 | (funcall glfwMakeContextCurrent ,win) 231 | ,@body 232 | (funcall glfwTerminate))) 233 | 234 | 235 | (with-open-file (s "emitted_code.cpp" 236 | :direction :output 237 | :if-exists :supersede 238 | :if-does-not-exist :create) 239 | (emit-cpp 240 | :str s 241 | :clear-env t 242 | :code 243 | `(with-compilation-unit 244 | 245 | (function (main ((argc :type int) 246 | (argv :type char**)) 247 | int) 248 | (decl ((argc :type (void)))) 249 | (decl ((argv :type (void)))) 250 | (macroexpand 251 | (with-glfw-window (main_window :w 512 :h 512) 252 | (for (() (! (funcall glfwWindowShouldClose main_window)) ()) 253 | 254 | (funcall glClear GL_COLOR_BUFFER_BIT) 255 | 256 | 257 | (funcall glfwSwapBuffers main_window) 258 | 259 | (funcall glfwPollEvents)))) 260 | (return 0))))) 261 | #+END_SRC 262 | 263 | ** Support for ISPC (Intel SPMD Program Compiler) 264 | 265 | If you add the keyword ispc to `*features*`, you can use the ispc 266 | specific control expressions (foreach, foreach_unique, foreach_tiled, 267 | foreach_active, cif, bit). 268 | 269 | #+BEGIN_SRC common-lisp 270 | (push :ispc *features*) 271 | (eval-when (:compile-toplevel :execute :load-toplevel) 272 | (ql:quickload :cl-cpp-generator)) 273 | 274 | (in-package :cl-cpp-generator) 275 | (with-output-to-string (s) 276 | (emit-cpp 277 | :str s 278 | :clear-env t 279 | 280 | :code 281 | `(with-compilation-unit 282 | (dotimes (i (funcall max 2 3)) 283 | (funcall bla)) 284 | (foreach (i (funcall max 1 0) (funcall min m n)) 285 | (funcall ata)) 286 | (foreach ((i (funcall max 1 0) (funcall min m n)) 287 | (j 0 n)) 288 | (funcall ata)) 289 | (foreach-active (i) 290 | (+= (aref a index) (bit #b0110))) 291 | (function (func ((v :type "uniform int")) "extern void")) 292 | (foreach-unique (val x) 293 | (funcall func val))))) 294 | #+END_SRC 295 | 296 | #+BEGIN_SRC c++ 297 | for(int i = 0; (i < max(2,3)); i += 1) { 298 | bla(); 299 | } 300 | 301 | foreach(i = max(1,0) ... min(m,n)) { 302 | ata(); 303 | } 304 | 305 | foreach(i = max(1,0) ... min(m,n),j = 0 ... n) { 306 | ata(); 307 | } 308 | 309 | foreach_active(i) { 310 | a[index] += 0b110; 311 | } 312 | 313 | extern void func(uniform int v); 314 | foreach_uniq(val in x) { 315 | func(val); 316 | } 317 | #+END_SRC 318 | 319 | 320 | 321 | ** Example 322 | 323 | #+BEGIN_SRC common-lisp 324 | (with-open-file (s "o.cpp" 325 | :direction :output 326 | :if-exists :supersede 327 | :if-does-not-exist :create) 328 | (emit-cpp :str s :code 329 | '(with-compilation-unit 330 | (include ) 331 | (include "org_types.h") 332 | (with-namespace N 333 | (class CommandsHandler () 334 | (access-specifier public) 335 | (constructord CommandsHandler ((callbacks :type "const DeviceCallbacks"))) 336 | (functiond HandleRxBlock ((data :type "const uint16_t")) void)) 337 | (function HandleRxBlock ((data :type "const uint16_t")) void 338 | (decl ((a :type uint16_t :init 3) 339 | (b :type uint16_t))) 340 | (+= a data)))))) 341 | #+END_SRC 342 | 343 | #+BEGIN_SRC c++ 344 | #include "org_types.h" 345 | #include 346 | namespace N { 347 | class CommandsHandler { 348 | public: 349 | CommandsHandler(const DeviceCallbacks callbacks); 350 | void HandleRxBlock(const uint16_t data); 351 | 352 | } 353 | 354 | void HandleRxBlock(const uint16_t data){ 355 | uint16_t a = 3; 356 | uint16_t b; 357 | ; 358 | a += data; 359 | } 360 | }; 361 | #+END_SRC 362 | 363 | include arg 364 | arg either keyword like or a string 365 | 366 | function name params* ret expr1 expr2 ... 367 | name .. function name 368 | parameters .. 0 or more but always a list 369 | ret .. return value 370 | 371 | 372 | constructord name params* 373 | functiond name params* ret expr .. 374 | 375 | 376 | 377 | struct 378 | union 379 | class identifier base-clause 380 | identifier .. class name like dfa%%flash 381 | base-clause .. (()) or ((public virtual buh%%fcsdf)) or ((public virtual buh%%fcsdf) (private B::C)) 382 | 383 | with-namespace name &rest cmds 384 | 385 | with-compilation-unit &rest cmds 386 | 387 | binary operator (+ a b c) 388 | a + b + c 389 | 390 | setf a b c d 391 | a = b; c = d 392 | 393 | computed assignemnt a b 394 | a += b 395 | 396 | logical operator == 397 | a == b 398 | 399 | compound-statement (a b c) 400 | { 401 | a; 402 | b; 403 | c; 404 | } 405 | 406 | decl ((name :type type :init 0) ( .. ) (.. ) .. ) 407 | 408 | type name = 0; 409 | 410 | 411 | let 412 | just like lisp, expands into block with decl inside 413 | 414 | if cond yes [no] 415 | 416 | for 417 | (for ((i a :type int) (< i n) (+= i 1))) 418 | for(int i=a;i) 481 | (class CustomItemGridGroup ("public QGraphicsItemGroup") 482 | (access-specifier public) 483 | (function (CustomItemGridGroup ((dx :type int) 484 | (dy :type int) 485 | (nx :type int) 486 | (ny :type int)) 487 | explicit)) 488 | 489 | (access-specifier private) 490 | (decl ((m_dx :type "unsigned int") 491 | (m_dy :type "unsigned int") 492 | (m_nx :type "unsigned int") 493 | (m_ny :type "unsigned int")))))) 494 | (code `(with-compilation-unit 495 | (include "CustomItemGridGroup.h") 496 | (function ("CustomItemGridGroup::CustomItemGridGroup" ((dx :type int) 497 | (dy :type int) 498 | (nx :type int) 499 | (ny :type int)) 500 | nil 501 | :ctor 502 | ((m_dx dx) 503 | (m_dy dy) 504 | (m_nx nx) 505 | (m_ny ny))) 506 | (with-compilation-unit 507 | (raw "// draw grid") 508 | (let ((dx :init m_dx) 509 | (dy :init m_dy) 510 | (nx :init m_nx) 511 | (ny :init m_ny)) 512 | (dotimes (i ny) 513 | (let ((x1 :init (* dx i)) 514 | (y1 :init (* dy 0)) 515 | (x2 :init x1) 516 | (y2 :init (* dy (- ny 1)))) 517 | (funcall this->addToGroup (new (funcall QGraphicsLineItem (funcall QLineF x1 y1 x2 y2)))))) 518 | (dotimes (i nx) 519 | (let ((y1 :init (* dy i)) 520 | (x1 :init (* dx 0)) 521 | (y2 :init y1) 522 | (x2 :init (* dx (- nx 1)))) 523 | (funcall this->addToGroup (new (funcall QGraphicsLineItem (funcall QLineF x1 y1 x2 y2)))))))))))) 524 | (write-source "CustomItemGridGroup" "h" header) 525 | (write-source "CustomItemGridGroup" "cpp" code)) 526 | #+END_SRC 527 | 528 | This is how the emitted code in 529 | `~/CustomItemGridGroup.cpp` and `~/CustomItemGridGroup.h` looks like: 530 | 531 | #+BEGIN_SRC c++ 532 | // cpp 533 | #include "CustomItemGridGroup.h" 534 | CustomItemGridGroup::CustomItemGridGroup(int dx, int dy, int nx, int ny) 535 | : m_dx(dx), m_dy(dy), m_nx(nx), m_ny(ny) { 536 | // draw grid 537 | { 538 | auto dx = m_dx; 539 | auto dy = m_dy; 540 | auto nx = m_nx; 541 | auto ny = m_ny; 542 | 543 | for (unsigned int i = 0; (i < ny); i += 1) { 544 | { 545 | auto x1 = (dx * i); 546 | auto y1 = (dy * 0); 547 | auto x2 = x1; 548 | auto y2 = (dy * (ny - 1)); 549 | 550 | this->addToGroup(new QGraphicsLineItem(QLineF(x1, y1, x2, y2))); 551 | } 552 | } 553 | 554 | for (unsigned int i = 0; (i < nx); i += 1) { 555 | { 556 | auto y1 = (dy * i); 557 | auto x1 = (dx * 0); 558 | auto y2 = y1; 559 | auto x2 = (dx * (nx - 1)); 560 | 561 | this->addToGroup(new QGraphicsLineItem(QLineF(x1, y1, x2, y2))); 562 | } 563 | } 564 | } 565 | } 566 | 567 | // header 568 | #include 569 | class CustomItemGridGroup : public QGraphicsItemGroup { 570 | public: 571 | explicit CustomItemGridGroup(int dx, int dy, int nx, int ny); 572 | 573 | private: 574 | unsigned int m_dx; 575 | unsigned int m_dy; 576 | unsigned int m_nx; 577 | unsigned int m_ny; 578 | }; 579 | #+END_SRC 580 | 581 | 582 | ** Implementation of tests 583 | 584 | In order to verify that the code emitted by emit-cpp is valid I 585 | implemented unit tests in test.lisp. I also use sb-cover to create an 586 | HTML code coverage report. 587 | 588 | The function (test ) will emit C code as 589 | defined by the s-expression in using the emit-cpp function into 590 | /dev/shm/1. 591 | 592 | The expected output is given to the test function as the third 593 | parameter and is written into /dev/shm/2. 594 | 595 | Both files are then indented with clang-format so that the test is 596 | less independent on the exact white space. Then the files are compared 597 | using the diff command. 598 | 599 | *** How to fix a broke test 600 | 601 | If the emit-cpp output is not the same as the expected , an 602 | assertion error like this will show up: 603 | 604 | #+BEGIN_SRC 605 | The assertion 606 | (eq nil 607 | #1=(with-output-to-string (s) 608 | (sb-ext:run-program "/usr/bin/diff" 609 | '("/dev/shm/1" "/dev/shm/2") 610 | :output s))) 611 | failed with #1# = "2,5c2,5 612 | < float f = (3.2e-7); 613 | < double d = (7.2e-31); 614 | < complex float z = ((2.f+0) + (1.f+0i)); 615 | < complex double w = ((2.e+0) + (1.e+0i)); 616 | --- 617 | > float f = (3.2000000000f-7); 618 | > double d = (7.200000000000000000e-31); 619 | > complex float z = ((2.0000000000f+0) + (1.0000000000f+0i)); 620 | > complex double w = ((2.000000000000000000e+0) + (1.000000000000000000e+0i)); 621 | ". 622 | #+END_SRC 623 | 624 | In this case I modified the printing of floating point numbers in 625 | emit-cpp, so that the least amount of digits are printed without 626 | loosing precision. Of course this broke the previous test. If the code 627 | in /dev/shm/1 is correct, just place it into the third argument 628 | of test. Don't forget to quote quotes. 629 | 630 | ** Problem 631 | 632 | #+BEGIN_SRC 633 | (if (== current_pattern_number pattern_number) ... 634 | 635 | source/libview.cpp:265:41: warning: equality comparison with extraneous parentheses 636 | [-Wparentheses-equality] 637 | if ((current_pattern_number == pattern_number)) { 638 | ~~~~~~~~~~~~~~~~~~~~~~~^~~~~~~~~~~~~~~~~ 639 | source/libview.cpp:265:41: note: remove extraneous parentheses around the comparison to silence this 640 | warning 641 | if ((current_pattern_number == pattern_number)) { 642 | ~ ^ ~ 643 | source/libview.cpp:265:41: note: use '=' to turn this equality comparison into an assignment 644 | if ((current_pattern_number == pattern_number)) { 645 | ^~ 646 | = 647 | 648 | #+END_SRC 649 | 650 | 651 | ** Ideas 652 | 653 | *** Destructuring 654 | 655 | - http://stackoverflow.com/questions/31394507/how-can-i-emulate-destructuring-in-c 656 | 657 | #+BEGIN_SRC 658 | struct animal { 659 | std::string species; 660 | int weight; 661 | std::string sound; 662 | }; 663 | 664 | int main() 665 | { 666 | auto pluto = animal { "dog", 23, "woof" }; 667 | 668 | auto [ species, weight, sound ] = pluto; 669 | 670 | std::cout << "species=" << species << " weight=" << weight << " sound=" << sound << "\n"; 671 | } 672 | #+END_SRC 673 | 674 | ** References 675 | 676 | 677 | 678 | - how to write a dsl in lisp: https://www.youtube.com/watch?v=5FlHq_iiDW0 679 | 680 | - https://github.com/deplinenoise/c-amplify (CL) 681 | http://voodoo-slide.blogspot.de/2010/01/amplifying-c.html 682 | 683 | 684 | - https://github.com/burtonsamograd/sxc (CL) 685 | https://news.ycombinator.com/item?id=13199610 686 | the syntax is structured in a way that, though it resembles C, so that 687 | it is quickly readable if you know C, seems to be hard to analyze 688 | for rudimentary structure in a way that follows semantics. 689 | 690 | [he] wrote the syntax as [he] went along going through the examples and 691 | problems of K&R. The syntax is more like C as this is more of a tool 692 | that is meant to bring C programmers into the Lisp world rather than 693 | pulling Lisp programmers into the C world 694 | 695 | The expander of a macro is Lisp; its output is SXC. 696 | 697 | 698 | 699 | - http://super.para.media.kyoto-u.ac.jp/~tasuku/sc/index.html (CL) 700 | https://bitbucket.org/tasuku/sc-tascell 701 | http://super.para.media.kyoto-u.ac.jp/%7Etasuku/sc/pub/ppopp09.pdf 702 | 703 | 704 | 705 | - https://github.com/kiselgra/c-mera 706 | 707 | - https://github.com/eratosthenesia/lispc 708 | 709 | - https://github.com/cbaggers/varjo 710 | Baggers: Khronos Meetup Oslo: Lisping on the GPU https://www.youtube.com/watch?v=XEtlxJsPR40 711 | 712 | - https://github.com/ghollisjr/makeres-cpp looks like a quite limited s-expression representation for c++, to speed up dataprocessing 713 | 714 | - https://github.com/takagi/cl-cuda 715 | 716 | - https://github.com/angavrilov/cl-gpu 717 | 718 | 719 | - https://bitbucket.org/ktg/l (Racket, very concise/nice documentation) 720 | 721 | - https://github.com/shirok/Gauche/blob/master/lib/gauche/cgen/cise.scm 722 | 723 | - https://github.com/vsedach/Parenscript 724 | 725 | - https://software.intel.com/en-us/articles/the-ultimate-question-of-programming-refactoring-and-everything 726 | 727 | - clang tooling https://clang.llvm.org/docs/LibASTMatchersTutorial.html 728 | 729 | - clangd https://reviews.llvm.org/rL302191#725d97b4 730 | 731 | - language server protocol https://github.com/Microsoft/language-server-protocol 732 | 733 | - Rust/Haskell/Ada Microcontroller https://news.ycombinator.com/item?id=14071282 734 | 735 | - Haskel DSL http://ivorylang.org/ 736 | 737 | - Lisp flavoured C https://github.com/tomhrr/dale 738 | 739 | 740 | - Clojure to C++ compiler http://ferret-lang.org/ 741 | 742 | - Using optima will result in code that is looks much more maintainable Phttp://enthusiasm.cozy.org/archives/2013/07/optima https://github.com/bhyde/backward-parenscript/blob/master/main.lisp#L70 743 | 744 | - checked c https://github.com/Microsoft/checkedc 745 | 746 | - https://fennel-lang.org/ 747 | 748 | - https://norvig.com/ltd/doc/tool.html Peter Norvig's Lisp to Dylan translator from 1994 seems to solve a similar problem 749 | 750 | - https://github.com/ghollisjr/makeres-cpp 751 | - https://github.com/3b/3bgl-shader 752 | 753 | - https://github.com/mvollmer/zollern 754 | 755 | - https://jonathan.protzenko.fr/2019/01/04/behind-the-scenes.html F* Kremlin for verified HTTPS stack 756 | - how to handle parens 757 | - argument eval order 758 | - struct arguments only when small 759 | - no recursion (not all c compilers can handle tail call optimization) 760 | - dsl to combine multiple source files, static inline 761 | - reproducible build of a docker image with the toolchain 762 | - some ugly bug with a windows header 763 | - clang sanitizer found unaligned pointer dereference 764 | - https://www.youtube.com/watch?v=aiJxkaxMBVE A Pile of Parens - Episode 4 - Optimization Passes 765 | - https://mpov.timmorgan.org/i-built-a-lisp-compiler/ https://news.ycombinator.com/item?id=19508616 766 | - https://github.com/ryos36/verilisp/ lisp to verilog 767 | - https://ftp.belnet.be/mirror/FOSDEM/2015/devroom-network_management_and_sdn/packet_filtering_pflua__CAM_ONLY.mp4 use luajit as compiler 768 | 769 | - https://irclog.tymoon.eu/freenode/%23lisp?around=1560731971#1560731971 770 | - https://news.ycombinator.com/item?id=20195740 discussion about this project 771 | - http://informatimago.com/develop/lisp/com/informatimago/languages/linc/README linc 772 | - https://github.com/google/navc index and navigate c code, watches file changes 773 | - https://c9x.me/qscm/ blend of scheme and c 774 | 775 | -------------------------------------------------------------------------------- /bare-metal.lisp: -------------------------------------------------------------------------------- 1 | (in-package :g) 2 | 3 | (compile-cpp "/home/martin/stage/cl-cpp-generator/out/simple" ;; simple 4 | '(with-compilation-unit 5 | (function (main ((argc :type int) 6 | (argv :type "const char**")) 7 | int) 8 | 9 | (for (() () ()) 10 | ) 11 | (return 0)))) 12 | 13 | (compile-cpp "/home/martin/stage/cl-cpp-generator/out/simple_vec" ;; dynamic memory allocation 14 | '(with-compilation-unit 15 | (include ) 16 | (include ) 17 | (function (main ((argc :type int) 18 | (argv :type "const char**")) 19 | int) 20 | (decl ((v :type "std::vector") 21 | (max-vec-size :type "static const int" :init 256))) 22 | 23 | (for ((i 0 :type int) (< i max-vec-size) (+= i 1)) 24 | (funcall v.push-back i)) 25 | (return 0)))) 26 | 27 | (compile-cpp "/home/martin/stage/cl-cpp-generator/out/simple_vec_c_heap" ;; replace C++ heap with C 28 | '(with-compilation-unit 29 | (include ) 30 | (include ) 31 | (include ) 32 | (include ) 33 | ;; beware of third party C++ libraries that count on 34 | ;; exception been thrown and do not check return value 35 | ;; from perator new 36 | (function (new ((size :type size_t)) "void* operator" :specifier noexcept) 37 | (return (funcall malloc size))) 38 | (function (delete ((p :type void*)) "void operator" :specifier noexcept) 39 | (return (funcall free p))) 40 | (function (new[] ((size :type size_t)) "void* operator" :specifier noexcept) 41 | (return (funcall malloc size))) 42 | (function (delete[] ((p :type void*)) "void operator" :specifier noexcept) 43 | (return (funcall free p))) 44 | (function (new ((size :type size_t) (b :type "std::nothrow_t")) "void* operator" :specifier noexcept) 45 | (return (funcall malloc size))) 46 | (function (delete ((p :type void*) (b :type "std::nothrow_t")) "void operator" :specifier noexcept) 47 | (return (funcall free p))) 48 | (function (new[] ((size :type size_t) (b :type "std::nothrow_t")) "void* operator" :specifier noexcept) 49 | (return (funcall malloc size))) 50 | (function (delete[] ((p :type void*) (b :type "std::nothrow_t")) "void operator" :specifier noexcept) 51 | (return (funcall free p))) 52 | 53 | (function (main ((argc :type int) 54 | (argv :type "const char**")) 55 | int) 56 | (decl ((v :type "std::vector") 57 | (max-vec-size :type "static const int" :init 256))) 58 | 59 | (for ((i 0 :type int) (< i max-vec-size) (+= i 1)) 60 | (funcall v.push-back i)) 61 | (return 0)))) 62 | ;; removing standard library and c++ runtime 63 | ;; update interrupt vector table 64 | ;; set up stack pointers for all modes of execution 65 | ;; zero .bss section 66 | ;; call initialisation functions for global objects 67 | ;; call main 68 | ;; perhaps define memcpy and memset 69 | 70 | 71 | (compile-cpp "/home/martin/stage/cl-cpp-generator/out/test_cpp_statics" ;; static objects 72 | 73 | '(with-compilation-unit 74 | (class SomeObj () 75 | 76 | (access-specifier public) 77 | (function (instanceGlobal () "static SomeObj&")) 78 | (function (instanceLocal () "static SomeObj&")) 79 | (access-specifier private) 80 | (function (SomeObj ((v1 :type int) 81 | (v2 :type int)))) 82 | (decl ((m_v1 :type int) 83 | (m_v2 :type int) 84 | (globalObj :type "static SomeObj")))) 85 | (decl (("SomeObj::globalObj(1,2)" :type SomeObj))) 86 | (function ("SomeObj::instanceGlobal" () SomeObj&) 87 | (return globalObj)) 88 | (function ("SomeObj::instanceLocal" () SomeObj&) 89 | (decl (("localObj(3,4)" :type "static SomeObj"))) 90 | (return localObj)) 91 | (function ("SomeObj::SomeObj" ((v1 :type int) 92 | (v2 :type int)) 93 | () :ctor ((m_v1 v1) (m_v2 v2))) 94 | (decl ((a :type int)))) 95 | 96 | (function (main ((argc :type int) 97 | (argv :type "const char**")) 98 | int) 99 | (decl ((glob :type "auto&" :init "SomeObj::instanceGlobal()") 100 | (local :type "auto&" :init "SomeObj::instanceLocal()"))) 101 | (for (() () ())) 102 | (return 0)) 103 | (raw "#pragma CODE_SECTION(\"AppRamFuncs\")") 104 | (function (_start () "extern \"C\" void") 105 | (funcall main 0 0))) 106 | 107 | ;; this code should be split into different files to 108 | ;; prevent inlining. cxa_guard_acquire is used for 109 | ;; thread safe static variable initialization. the 110 | ;; following flag turns this off. in that case make sure 111 | ;; not to access statics in the interrupt context, 112 | ;; btw. initialize objects in main() before enabling 113 | ;; interrupts 114 | :options '("-fno-threadsafe-statics")) 115 | -------------------------------------------------------------------------------- /cl-cpp-generator.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem cl-cpp-generator 2 | :version "0" 3 | :description "Emit C++ code" 4 | :maintainer " " 5 | :author " " 6 | :licence "GPL" 7 | :depends-on () 8 | ;:serial t 9 | :components ((:file "cp")) ) 10 | -------------------------------------------------------------------------------- /cover/cover-index.html: -------------------------------------------------------------------------------- 1 |

No code coverage data found.

-------------------------------------------------------------------------------- /cp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; by Martin Kielhorn , 2016-2017. 2 | ;;;; 3 | ;;;; Permission is hereby granted, free of charge, to any person 4 | ;;;; obtaining a copy of this software and associated documentation files 5 | ;;;; (the "Software"), to deal in the Software without restriction, 6 | ;;;; including without limitation the rights to use, copy, modify, merge, 7 | ;;;; publish, distribute, sublicense, and/or sell copies of the Software, 8 | ;;;; and to permit persons to whom the Software is furnished to do so, 9 | ;;;; subject to the following conditions: 10 | ;;;; 11 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 12 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 13 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 14 | ;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 15 | ;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 16 | ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 17 | ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 18 | 19 | 20 | 21 | (defpackage :cl-cpp-generator 22 | (:use :cl) 23 | (:export 24 | #:include 25 | #:compound-statement 26 | #:single-float-to-c-hex-string 27 | #:statements 28 | #:tagbody 29 | #:go 30 | #:defmacro 31 | #:macroexpand 32 | #:function 33 | #:access-specifier 34 | #:with-namespace 35 | #:with-compilation-unit 36 | #:enum 37 | #:decl 38 | #:break 39 | #:extern-c 40 | #:raw 41 | #:cast 42 | #:ns 43 | #:slot->value 44 | #:ref 45 | #:deref 46 | #:hex 47 | #:comma-list 48 | #:lisp 49 | #:statement)) 50 | 51 | (defpackage :cl-cpp-generator-macros 52 | (:use :cl :cl-cpp-generator)) 53 | (in-package :cl-cpp-generator) 54 | 55 | (setf (readtable-case *readtable*) :invert) 56 | 57 | 58 | (defparameter *file-hashes* (make-hash-table)) 59 | 60 | 61 | (defun beautify-source (code) 62 | (let* ((code-str (emit-cpp 63 | :clear-env t 64 | :code code))) 65 | (with-input-from-string (s code-str) 66 | (with-output-to-string (o) 67 | (sb-ext:run-program "/usr/bin/clang-format" (list "-") :input s :output o :wait t))))) 68 | 69 | (defun single-float-to-c-hex-string (f) 70 | (declare (type (single-float 0) f)) 71 | (multiple-value-bind (a b c) (integer-decode-float f) 72 | (let ((significand (ash a 1))) 73 | (format nil "0x~x.~xp~d" 74 | (ldb (byte 4 (* 6 4)) significand) 75 | (ldb (byte (* 6 4) 0) significand) 76 | (+ 23 b))))) 77 | 78 | (defun write-source (name extension code &optional (dir (user-homedir-pathname))) 79 | (let* ((fn (merge-pathnames (format nil "~a.~a" name extension) 80 | dir)) 81 | (code-str (emit-cpp 82 | :clear-env t 83 | :code code)) 84 | (fn-hash (sxhash fn)) 85 | (code-hash (sxhash code-str))) 86 | (multiple-value-bind (old-code-hash exists) (gethash fn-hash *file-hashes*) 87 | (when (or (not exists) (/= code-hash old-code-hash)) 88 | ;; store the sxhash of the c source in the hash table 89 | ;; *file-hashes* with the key formed by the sxhash of the full 90 | ;; pathname 91 | (setf (gethash fn-hash *file-hashes*) code-hash) 92 | (with-open-file (s fn 93 | :direction :output 94 | :if-exists :supersede 95 | :if-does-not-exist :create) 96 | (write-sequence code-str s)) 97 | (sb-ext:run-program "/usr/bin/clang-format" (list "-i" (namestring fn))))))) 98 | 99 | ;; OOP A%3A C++-Grammatik (mit Links).html 100 | (defparameter *special-symbol* 101 | '(! &= ++ -> /= <<= >> |\|| 102 | != |(| += ->* |:| <= >>= |\|=| 103 | % |)| |,| |.| |::| = ? |\|\|| 104 | %= * - |.*| |;| == ^ } 105 | & *= -- |...| < > ^= ~ 106 | && + -= / << >= {)) 107 | 108 | (defparameter *unary-operator-symbol* 109 | '(+ - ~ !)) 110 | 111 | (defparameter *binary-operator-symbol* 112 | '(* / % + - ^ & |\|| << >>)) 113 | 114 | (defparameter *logical-operator-symbol* 115 | '(== != < > <= >= && |\|\||)) 116 | 117 | (defparameter *computed-assignment-operator-symbol* 118 | '(*= /= %= += -= ^= &= |\|=| <<= >>=)) 119 | 120 | (defparameter *class-key* 121 | '(class struct union)) 122 | 123 | (defun print-sufficient-digits-f32 (f) 124 | "print a single floating point number as a string with a given nr. of 125 | digits. parse it again and increase nr. of digits until the same bit 126 | pattern." 127 | (let* ((ff (coerce f 'single-float)) 128 | (s (format nil "~E" ff))) 129 | #+nil (assert (= 0s0 (- ff 130 | (read-from-string s)))) 131 | (assert (< (abs (- ff 132 | (read-from-string s))) 133 | 1d-4)) 134 | (format nil "~af" s))) 135 | 136 | #+nil 137 | (print-sufficient-digits-f32 1s0) 138 | 139 | (defun print-sufficient-digits-f64 (f) 140 | "print a double floating point number as a string with a given nr. of 141 | digits. parse it again and increase nr. of digits until the same bit 142 | pattern." 143 | (let* ((ff (coerce f 'double-float)) 144 | (s (format nil "~E" ff))) 145 | #+nil (assert (= 0d0 (- ff 146 | (read-from-string s)))) 147 | (assert (< (abs (- ff 148 | (read-from-string s))) 149 | 1d-12)) 150 | (substitute #\e #\d s))) 151 | 152 | #+nil 153 | (print-sufficient-digits-f64 1d0) 154 | 155 | 156 | 157 | 158 | 159 | (defparameter *env-functions* nil) 160 | (defparameter *env-macros* nil) 161 | 162 | (defun emit-cpp (&key code (str nil) (clear-env nil) ) 163 | (when clear-env 164 | (setf *env-functions* nil 165 | *env-macros* nil)) 166 | (if code 167 | (if (listp code) 168 | (case (car code) 169 | (:params (loop for e in (cadr code) collect 170 | (destructuring-bind (name &key type default) e 171 | (if default 172 | (format str "~a ~a = ~a" type name (emit-cpp :code default)) 173 | (format str "~a ~a" type name))))) 174 | (include (format str "#include ~s" (cadr code))) 175 | (compound-statement (with-output-to-string (s) 176 | (format s "{~%") 177 | (loop for e in (cdr code) do 178 | (format s "~& ~a" (emit-cpp :code (append '(statement) e)))) 179 | (format s "}"))) 180 | (statements (with-output-to-string (s) 181 | (loop for e in (cdr code) do 182 | (format s "~& ~a" (emit-cpp :code (append '(statement) e)))))) 183 | (tagbody (with-output-to-string (s) 184 | (format s "{~%") 185 | (loop for e in (cdr code) do 186 | (if (symbolp e) 187 | (format s " ~a:~%" e) 188 | (format s " ~a~%" (emit-cpp :code (append '(statement) e))))) 189 | (format s "}~%"))) 190 | (go (destructuring-bind (name) (cdr code) 191 | (format str "goto ~a" name))) 192 | (defmacro (destructuring-bind ((name params) &rest macro-body) (cdr code) 193 | (push (list :name name 194 | :params params 195 | :body macro-body) 196 | *env-macros*))) 197 | (macroexpand (destructuring-bind (macro &rest rest) (cdr code) 198 | (format str "~a" #+nil (intern (string-upcase (format nil "~a" macro)) :cl-cpp-generator-macros) 199 | (emit-cpp :code (macroexpand-1 macro) 200 | 201 | )))) 202 | (function (destructuring-bind ((name params &optional ret &key ctor specifier parent-ctor) &rest function-body) (cdr code) 203 | (let ((header (concatenate 'string 204 | (when ret (format nil "~a " ret)) 205 | (format nil "~a(~{~a~^,~})" 206 | name 207 | (emit-cpp :code `(:params ,params))) 208 | (when specifier 209 | (format nil " ~a" specifier)) 210 | (when (or ctor parent-ctor) 211 | (format nil ":~{~a~^,~}~%" 212 | (append 213 | (loop for (e f) in ctor collect 214 | (format nil " ~a( ~a )" e f)) 215 | (loop for e in parent-ctor collect 216 | (destructuring-bind (name &rest params) e 217 | (format nil "~a" 218 | (emit-cpp :code `(with-compilation-unit 219 | (funcall ,name ,@params)))))))))))) 220 | (if function-body 221 | (progn 222 | (push (list :name name 223 | :params params 224 | :ret ret 225 | :ctor ctor 226 | :specifier specifier 227 | :parent-ctor parent-ctor 228 | :body function-body) 229 | *env-functions*) 230 | (concatenate 'string 231 | header 232 | (emit-cpp :code `(compound-statement ,@function-body)))) 233 | (concatenate 'string header ";"))))) 234 | (lambda (destructuring-bind ((params &key captures ret specifiers) &rest function-body) (cdr code) 235 | (let ((header (concatenate 'string 236 | 237 | (format nil "[~{~a~^,~}](~{~a~^,~})" 238 | captures 239 | (emit-cpp :code `(:params ,params))) 240 | (when specifiers 241 | (format nil "~{ ~a~}" specifiers)) 242 | (when ret (format nil "~a " ret))))) 243 | (concatenate 'string 244 | header 245 | (emit-cpp :code `(compound-statement ,@function-body)))))) 246 | (access-specifier (format str "~a:~%" (cadr code)) 247 | ;; public, private or protected 248 | ) 249 | (with-namespace (destructuring-bind (ns &rest compound-statement) (cdr code) 250 | (format str "namespace ~a {~%~{~a~%~} } // namespace ~a ~%" 251 | ns (loop for e in compound-statement collect 252 | (emit-cpp :code e)) 253 | ns))) 254 | (with-compilation-unit (format str "~{~a~^~%~}" 255 | (loop for e in (cdr code) collect 256 | (emit-cpp :code e)))) 257 | (enum (destructuring-bind (name &rest rest) (cdr code) 258 | ;; enum bla (normal 1) power-on (error (+ 1 2)) 259 | (with-output-to-string (s) 260 | (format s "enum ~a {~{ ~a~^,~}};~%" 261 | (if name name "") 262 | (loop for e in rest collect 263 | (if (listp e) 264 | (format nil "~a = ~a" (first e) (emit-cpp :code (second e))) 265 | (format nil "~a" e))))))) 266 | (enum-class (destructuring-bind ((name &key type) &rest rest) (cdr code) 267 | ;; C++11 268 | (with-output-to-string (s) 269 | (format s "enum class ~a ~a {~{ ~a~^,~}};~%" 270 | (if name name "") 271 | (if type (format nil ": ~a" type) "") 272 | (loop for e in rest collect 273 | (if (listp e) 274 | (format nil "~a = ~a" (first e) (emit-cpp :code (second e))) 275 | (format nil "~a" e))))))) 276 | (new (format str "new ~a" (emit-cpp :code (cadr code)))) 277 | (delete (format str "delete ~a" (emit-cpp :code (cadr code)))) 278 | (delete[] (format str "delete [] ~a" (emit-cpp :code (cadr code)))) 279 | (decl (destructuring-bind (bindings) (cdr code) 280 | (with-output-to-string (s) 281 | (loop for e in bindings do 282 | (destructuring-bind (name &key (type 'auto) init ctor extra) e 283 | (format s "~a ~a" 284 | type (emit-cpp :code name)) 285 | (if extra 286 | (format s "~a" (emit-cpp :code extra))) 287 | (if init 288 | (format s " = ~a" (emit-cpp :code init)) 289 | (if ctor 290 | (format s "( ~a )" (emit-cpp :code ctor)) 291 | )) 292 | (format s ";~%") 293 | ))))) 294 | (let (destructuring-bind (bindings &rest rest) (cdr code) 295 | (emit-cpp :code `(compound-statement 296 | (decl ,bindings) 297 | ,@rest)))) 298 | (for (destructuring-bind ((for-init-statement &optional condition-opt update-expression-opt) &rest statement-list) 299 | (cdr code) 300 | (format str "for(~a; ~a; ~a) ~a" 301 | (if for-init-statement 302 | (destructuring-bind (name init &key (type 'auto)) for-init-statement 303 | (format nil "~a ~a = ~a" type name (emit-cpp :code init))) 304 | "") 305 | (if condition-opt 306 | (emit-cpp :code condition-opt) 307 | "") 308 | (if update-expression-opt 309 | (emit-cpp :code update-expression-opt) 310 | "") 311 | (emit-cpp :code `(compound-statement ,@statement-list))))) 312 | 313 | (while (destructuring-bind (condition &rest statement-list) 314 | (cdr code) 315 | (format str "while(~a) ~a" 316 | (emit-cpp :code condition) 317 | (emit-cpp :code `(compound-statement ,@statement-list))))) 318 | (do-while (destructuring-bind (condition &rest statement-list) 319 | (cdr code) 320 | (format str "do ~a while ( ~a )" 321 | (emit-cpp :code `(compound-statement ,@statement-list)) 322 | (emit-cpp :code condition) 323 | ))) 324 | 325 | #-conly 326 | (for-range (destructuring-bind ((var-decl range) &rest statement-list) 327 | (cdr code) 328 | (format str "for(~a : ~a) ~a" 329 | (if (atom var-decl) 330 | (format nil "auto ~a" var-decl) 331 | (destructuring-bind (name &key (type 'auto)) var-decl 332 | (format nil "~a ~a" type name))) 333 | (emit-cpp :code range) 334 | (emit-cpp :code `(compound-statement ,@statement-list))))) 335 | ;#+ispc 336 | (foreach (destructuring-bind (head &rest body) (cdr code) 337 | (if (listp (car head)) 338 | (progn ;; foreach (i = 0 ... width, j = 1 .. height) { 339 | (format str "foreach(~{~a~^,~}) ~a" 340 | (loop for (var start n) in head collect 341 | (format nil "~a = ~a ... ~a" 342 | var (emit-cpp :code start) (emit-cpp :code n))) 343 | (emit-cpp :code `(compound-statement ,@body))) 344 | ) 345 | (destructuring-bind (var start n) head ;; foreach (i = 0 ... width) { 346 | (format str "foreach(~a = ~a ... ~a) ~a" 347 | var (emit-cpp :code start) (emit-cpp :code n) 348 | (emit-cpp :code `(compound-statement ,@body))))))) 349 | ;#+ispc 350 | (foreach-tiled (destructuring-bind (head &rest body) (cdr code) ;; same semantics as foreach 351 | (if (listp (car head)) 352 | (progn ;; foreach_tiled (i = 0 ... width, j = 1 .. height) { 353 | (format str "foreach_tiled(~{~a~^,~}) ~a" 354 | (loop for (var start n) in head collect 355 | (format nil "~a = ~a ... ~a" 356 | var (emit-cpp :code start) (emit-cpp :code n))) 357 | (emit-cpp :code `(compound-statement ,@body))) 358 | ) 359 | (destructuring-bind (var start n) head ;; foreach_tiled (i = 0 ... width) { 360 | (format str "foreach_tiled(~a = ~a ... ~a) ~a" 361 | var (emit-cpp :code start) (emit-cpp :code n) 362 | (emit-cpp :code `(compound-statement ,@body))))))) 363 | ;#+ispc 364 | (foreach-active (destructuring-bind ((var) &rest body) (cdr code) ;; foreach_active (i) { 365 | (format str "foreach_active(~a) ~a" 366 | var 367 | (emit-cpp :code `(compound-statement ,@body))))) 368 | 369 | ;#+ispc 370 | (foreach-unique (destructuring-bind ((var seq) &rest body) (cdr code) ;; foreach_unique (val in x) { 371 | (format str "foreach_uniq(~a in ~a) ~a" 372 | var 373 | (emit-cpp :code seq) 374 | (emit-cpp :code `(compound-statement ,@body))))) 375 | 376 | 377 | (dotimes (destructuring-bind ((var n) &rest body) (cdr code) 378 | (emit-cpp :code `(for ((,var 0 :type int) (< ,var ,(emit-cpp :code n)) (+= ,var 1)) 379 | ,@body)))) 380 | (if (destructuring-bind (condition true-statement &optional false-statement) (cdr code) 381 | (with-output-to-string (s) 382 | (format s "if ( ~a ) ~a" 383 | (emit-cpp :code condition) 384 | (emit-cpp :code `(compound-statement ,true-statement))) 385 | (when false-statement 386 | (format s "else ~a" 387 | (emit-cpp :code `(compound-statement ,false-statement))))))) 388 | (? (destructuring-bind (condition true-statement &optional false-statement) (cdr code) ;; ternery if, note: user should supply multiple statements as a comma-list 389 | (with-output-to-string (s) 390 | (format s "( ~a ) ? ( ~a )" 391 | (emit-cpp :code condition) 392 | (emit-cpp :code true-statement)) 393 | (when false-statement 394 | (format s ": ( ~a )" 395 | (emit-cpp :code false-statement)))))) 396 | ;#+ispc 397 | (cif (destructuring-bind (condition true-statement &optional false-statement) (cdr code) 398 | (with-output-to-string (s) 399 | (format s "if ( ~a ) ~a" 400 | (emit-cpp :code condition) 401 | (emit-cpp :code `(compound-statement ,true-statement))) 402 | (when false-statement 403 | (format s "else ~a" 404 | (emit-cpp :code `(compound-statement ,false-statement))))))) 405 | (break (format str "break")) 406 | (case (destructuring-bind (expr &rest cases) (cdr code) 407 | (with-output-to-string (s) 408 | (format s "switch ( ~a ) {~%" (emit-cpp :code expr)) 409 | (loop for e in cases do 410 | (destructuring-bind (const-expr &rest statements) e 411 | (if (eq const-expr t) 412 | (format s "default : ~a" (emit-cpp :code `(compound-statement ,@statements (break)))) 413 | (format s "case ~a : ~a" 414 | (emit-cpp :code const-expr) 415 | (emit-cpp :code `(compound-statement ,@statements (break)))))) 416 | (format s "")) 417 | (format s "}~%")))) 418 | (setf (destructuring-bind (&rest args) (cdr code) 419 | (with-output-to-string (s) 420 | ;; handle multiple assignments 421 | (loop for i below (length args) by 2 do 422 | (format s "~a" 423 | (emit-cpp :code `(statement = ,(elt args i) ,(elt args (1+ i)))))) 424 | (if (< 2 (length args)) 425 | (format s "~%"))))) 426 | #+nil (aref (destructuring-bind (name &optional n) (cdr code) 427 | (if n 428 | (format str "~a[~a]" name (emit-cpp :code n)) 429 | (format str "~a[]" name)))) 430 | (aref (destructuring-bind (name &rest rest) (cdr code) 431 | (if rest 432 | (format str "~a~{[~a]~}" (emit-cpp :code name) (mapcar #'(lambda (x) (emit-cpp :code x)) rest)) 433 | (format str "~a[]" (emit-cpp :code name))))) 434 | (return (format str "return ~a" 435 | (emit-cpp :code (second code)))) 436 | (funcall (destructuring-bind (name &rest rest) (cdr code) 437 | (format str "~a(~{~a~^,~})" 438 | (emit-cpp :code name) 439 | (mapcar #'(lambda (x) (emit-cpp :code x)) rest)))) 440 | (extern-c (destructuring-bind (&rest rest) (cdr code) 441 | (format str "extern \"C\" {~%~{~a~^~%~}} // extern \"C\"~%" 442 | (loop for e in rest collect 443 | (emit-cpp :code e))))) 444 | (raw (destructuring-bind (string) (cdr code) 445 | (format str "~a" string))) 446 | (cast (destructuring-bind (type expr) (cdr code) 447 | (format str "(( ~a ) ( ~a ))" type (emit-cpp :code expr)))) 448 | (ns (let* ((args (cdr code)) 449 | (nss (butlast args)) 450 | (member (car (last args)))) 451 | (with-output-to-string (s) 452 | (loop for e in nss do 453 | (format s "~a::" (emit-cpp :code e))) 454 | (format s "~a" (emit-cpp :code member))))) 455 | (slot-value (let* ((args (cdr code)) 456 | (objs (butlast args)) 457 | (member (car (last args)))) 458 | (with-output-to-string (s) 459 | (loop for e in objs do 460 | (format s "~a." (emit-cpp :code e))) 461 | (format s "~a" (emit-cpp :code member))))) 462 | (slot->value (let* ((args (cdr code)) 463 | (objs (butlast args)) 464 | (member (car (last args)))) 465 | (with-output-to-string (s) 466 | (loop for e in objs do 467 | (format s "~a->" (emit-cpp :code e))) 468 | (format s "~a" (emit-cpp :code member))))) 469 | (ref (destructuring-bind (object) (cdr code) 470 | (format str "(&(~a))" (emit-cpp :code object)))) 471 | (deref (destructuring-bind (object) (cdr code) 472 | (format str "(*(~a))" (emit-cpp :code object)))) 473 | (hex (destructuring-bind (number) (cdr code) 474 | (typecase number 475 | (single-float 476 | (format str "~a" (single-float-to-c-hex-string number))) 477 | (number 478 | (format str "0x~x" number))))) 479 | (char (destructuring-bind (a) (cdr code) 480 | (typecase a 481 | (standard-char (format str "'~a'" a)) 482 | (number (format str "'~a'" (code-char a))) 483 | (string (format str "'~a'" (elt a 0)))) 484 | )) 485 | ;#+ispc 486 | (bit (destructuring-bind (number) (cdr code) 487 | (format str "0b~b" number))) 488 | (string (destructuring-bind (string) (cdr code) 489 | (format str "\"~a\"" string))) 490 | (string+len (destructuring-bind (string) (cdr code) 491 | (format str "\"~a\", ~a" string (length string)))) 492 | (array+lenbytes (destructuring-bind (name) (cdr code) 493 | (format str "~a, ( 2 * sizeof( ~a ) )" name name))) 494 | (list (destructuring-bind (&rest rest) (cdr code) 495 | (format str "{~{~a~^,~}}" (mapcar #'(lambda (x) (emit-cpp :code x)) rest)))) 496 | (paren-list (destructuring-bind (&rest rest) (cdr code) 497 | (format str "(~{~a~^,~})" (mapcar #'(lambda (x) (emit-cpp :code x)) rest)))) 498 | (comma-list (destructuring-bind (&rest rest) (cdr code) 499 | (format str "~{~a~^,~}" (mapcar #'(lambda (x) (emit-cpp :code x)) rest)))) 500 | (make-instance (destructuring-bind (object &rest rest) (cdr code) 501 | (format str "~a{~{~a~^,~}}" object (mapcar #'(lambda (x) (emit-cpp :code x)) rest)))) 502 | (lisp (eval (cadr code))) 503 | (statement ;; add semicolon 504 | (cond ((member (second code) (append *binary-operator-symbol* 505 | *computed-assignment-operator-symbol* 506 | *logical-operator-symbol* 507 | '(= return funcall raw go break new delete delete[] ? do-while slot-value))) 508 | ;; add semicolon to expressions 509 | (format str "~a;" (emit-cpp :code (cdr code)))) 510 | ((member (second code) '(if for-range while for foreach foreach-unique foreach-tiled foreach-active dotimes compound-statement statements with-compilation-unit tagbody decl setf lisp case let macroexpand struct class union function)) 511 | ;; if for, .. don't need semicolon 512 | (emit-cpp :code (cdr code))) 513 | (t (format nil "not processable statement: ~a" code)))) 514 | 515 | (t (cond ((and (= 2 (length code)) (member (car code) '(- ~ !))) 516 | ;; handle unary operators, i.e. - ~ !, this code 517 | ;; needs to be placed before binary - operator! 518 | (destructuring-bind (op operand) code 519 | (format nil "(~a (~a))" 520 | op 521 | (emit-cpp :code operand)))) 522 | ((member (car code) *binary-operator-symbol*) 523 | ;; handle binary operators 524 | ;; no semicolon 525 | (with-output-to-string (s) 526 | (format s "(") 527 | (loop for e in (cdr code) 528 | and i below (1- (length (cdr code))) do 529 | (format s "~a ~a " (emit-cpp :code e) (car code))) 530 | (format s "~a)" (emit-cpp :code (car (last (cdr code))))))) 531 | ((member (car code) *class-key*) 532 | ;; handle class, struct or union definitions 533 | (destructuring-bind (class-key identifier base-clause &rest member-specification) code 534 | (with-output-to-string (s) 535 | (format s "~a ~a " class-key identifier) 536 | (when base-clause 537 | (format s " :~{ ~a~^,~}" base-clause)) 538 | (format s "{~%~{~a~%~}};~%" (loop for e in member-specification collect 539 | (emit-cpp :code e)))))) 540 | ((member (car code) (append '(=) *computed-assignment-operator-symbol*)) 541 | ;; handle assignment and computed assignment, i.e. =, +=, /=, ... 542 | (destructuring-bind (op lvalue rvalue) code 543 | (format str "~a ~a ~a" 544 | (emit-cpp :code lvalue) 545 | op 546 | (emit-cpp :code rvalue)))) 547 | ((member (car code) *logical-operator-symbol*) 548 | ;; handle logical operators, i.e. ==, &&, ... 549 | (destructuring-bind (op left right) code 550 | (format str "(~a ~a ~a)" 551 | (emit-cpp :code left) 552 | op 553 | (emit-cpp :code right)))) 554 | (t (format nil "not processable: ~a" code))))) 555 | (cond 556 | ((or (symbolp code) 557 | (stringp code)) ;; print variable 558 | (format nil "~a" code) 559 | ;(substitute #\_ #\- (format nil "~a" code)) 560 | ) 561 | ((numberp code) ;; print constants 562 | (cond ((integerp code) (format str "~a" code)) 563 | ((floatp code) 564 | (typecase code 565 | (single-float (format str "(~a)" (print-sufficient-digits-f32 code))) 566 | (double-float (format str "(~a)" (print-sufficient-digits-f64 code))))) 567 | ((complexp code) 568 | (typecase (realpart code) 569 | (single-float 570 | (format str "((~a) + (~ai))" 571 | (print-sufficient-digits-f32 (realpart code)) 572 | (print-sufficient-digits-f32 (imagpart code)))) 573 | (double-float 574 | (format nil "((~a) + (~ai))" 575 | (print-sufficient-digits-f64 (realpart code)) 576 | (print-sufficient-digits-f64 (imagpart code)))))))) 577 | )) 578 | "")) 579 | 580 | 581 | (defun compile-cpp (fn code &key options) 582 | (let ((source-fn (concatenate 'string fn ".cpp")) 583 | (bin-fn (concatenate 'string fn ".bin"))) 584 | (with-open-file (s source-fn 585 | :direction :output :if-exists :supersede :if-does-not-exist :create) 586 | (emit-cpp :str s :code code)) 587 | (sb-ext:run-program "/usr/bin/clang-format" `("-i" ,source-fn)) 588 | (sleep .1) 589 | (with-output-to-string (s) 590 | (sb-ext:run-program "/usr/bin/g++" (append options `("-fno-exceptions" "-nostdlib" "-fno-unwind-tables" "-fno-rtti" "-march=native" "-o" ,bin-fn "-Os" ,source-fn)) 591 | :output s :error :output)) 592 | ; (sleep .1) 593 | ; (sb-ext:run-program "/usr/bin/objdump" `("-DS" ,bin-fn)) 594 | )) 595 | 596 | -------------------------------------------------------------------------------- /doc/ex1.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel :execute :load-toplevel) 2 | (ql:quickload :cl-cpp-generator)) 3 | 4 | (in-package :cl-cpp-generator) 5 | 6 | (defmacro with-glfw-window ((win &key (w 512) (h 512) (title "glfw")) &body body) 7 | `(let ((,win :type GLFWwindow*)) 8 | (if (! (funcall glfwInit)) 9 | (statements (return -1))) 10 | (setf ,win (funcall glfwCreateWindow ,w ,h (string ,title) NULL NULL)) 11 | (if (! ,win) 12 | (statements (funcall glfwTerminate) 13 | (return -1))) 14 | (funcall glfwMakeContextCurrent ,win) 15 | ,@body 16 | (funcall glfwTerminate))) 17 | 18 | (defmacro with-gl-primitive (prim &body body) 19 | `(statements 20 | (funcall glBegin ,prim) 21 | ,@body 22 | (funcall glEnd))) 23 | 24 | (progn 25 | (with-open-file (s "emitted_code.cpp" :direction :output 26 | :if-exists :supersede 27 | :if-does-not-exist :create) 28 | (emit-cpp :str s :clear-env t 29 | :code 30 | `(with-compilation-unit 31 | (include "GLFW/glfw3.h") 32 | (function (main ((argc :type int) (argv :type char**)) 33 | int) 34 | (decl ((argc :type (void)))) 35 | (macroexpand 36 | (with-glfw-window (main_window :w 512 :h 512) 37 | (funcall glfwSetWindowTitle main_window (aref argv 0)) 38 | #+black-on-white 39 | (statements (funcall glClearColor 1.0 1.0 1.0 1.0) 40 | (funcall glColor4f 0.0 0.0 0.0 1.0) 41 | (funcall glLineWidth 6.0)) 42 | (for (() (! (funcall glfwWindowShouldClose main_window)) ()) 43 | (funcall glClear GL_COLOR_BUFFER_BIT) 44 | (funcall glLoadIdentity) 45 | (let ((count :type "static float" :init 0.0)) 46 | (funcall glRotatef (+= count 2.1) .0 .0 1.)) 47 | (macroexpand (with-gl-primitive GL_LINE_LOOP 48 | ,@(let ((n 10)) 49 | (loop for i below n collect 50 | (let ((arg (coerce (/ (* 2 pi i) n) 51 | 'single-float))) 52 | `(funcall glVertex2f ,(cos arg) ,(sin arg))))))) 53 | (funcall glfwSwapBuffers main_window) 54 | (funcall glfwPollEvents)))) 55 | (return 0))))) 56 | (sb-ext:run-program "/usr/bin/clang-format" 57 | (list "-i" (namestring "emitted_code.cpp")))) 58 | -------------------------------------------------------------------------------- /doc/makefile: -------------------------------------------------------------------------------- 1 | CXXFLAGS=-Wall -Wextra -ggdb 2 | LDFLAGS=-lglfw -lGL 3 | emitted_code: emitted_code.cpp 4 | -------------------------------------------------------------------------------- /doc/screen_dsp_fsm_diagrams.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/plops/cl-cpp-generator/a0bba0a6e0e8f34e3e4459508ada1cd0036d9068/doc/screen_dsp_fsm_diagrams.png -------------------------------------------------------------------------------- /doc/screen_emitted_code.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/plops/cl-cpp-generator/a0bba0a6e0e8f34e3e4459508ada1cd0036d9068/doc/screen_emitted_code.png -------------------------------------------------------------------------------- /linker-cmd-file.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;; spru513j.pdf page 195 3 | (defun emit-cmd (&key code) 4 | (if code 5 | (if (listp code) 6 | (case (car code) 7 | (with-compilation-unit (format nil "~{~a~}" 8 | (loop for e in (cdr code) collect 9 | (emit-cmd :code e)))) 10 | (raw (destructuring-bind (string) (cdr code) 11 | (format nil "~a~%" string))) 12 | (funcall (destructuring-bind (name &rest rest) (cdr code) 13 | ;; supported functions in memory range entries: 14 | ;; start(memory-range [, page=0]) 15 | ;; size(memory-range [, page=0]) 16 | ;; end(memory-range [, page=0]) 17 | (format nil "~a(~{~a~^,~})" 18 | (emit-cmd :code name) 19 | (mapcar #'(lambda (x) (emit-cmd :code x)) rest)))) 20 | (sections (destructuring-bind (&rest rest) (cdr code) 21 | ;; describe how inpt sections are combined 22 | ;; into output sections, 23 | 24 | ;; define output sections in executable, 25 | 26 | ;; control placement of sections relative to 27 | ;; each other and in entire memory 28 | 29 | ;; rename output sections 30 | (with-output-to-string (s) 31 | (format s "SECTIONS~%") 32 | (write-sequence (emit-cmd :code `(compound-statement ,@rest)) s)))) 33 | 34 | (section-specification (destructuring-bind (name &rest properties) (cdr code) 35 | ;; each section specification 36 | ;; defines an output section in 37 | ;; the output file 38 | 39 | ;; name .. can refer to section, 40 | ;; subsection or archive library 41 | ;; members 42 | 43 | ;; properties .. list of 44 | ;; properties that define the 45 | ;; sections contents and their 46 | ;; allocation, separated by 47 | ;; optional commas 48 | 49 | ;; load = PROG, PAGE = 0 load = (0x0200) 50 | ;; the = is optional, it can also be a >, value can optionally be enclosed in () 51 | ;; run = 0x010 52 | ;; usually load and run location are the same, except with slow external memory (in our case flash) 53 | ;; if load and run separate, than all parameters after load refer to load and all after run to run 54 | ;; type = COPY 55 | ;; type = DSECT 56 | ;; type = NOLOAD 57 | ;; fill = 0xffffffff 58 | ;; { input_sections } 59 | ;; align = 16 60 | ;; .text : load = align(32) .. allocate .text so that it falls on a 32-byte boundary 61 | ;; palign .. pads the section to ensure size 62 | ;; .text : palign(2) {} > PMEM .. equivalent to this: 63 | ;; .text : palign = 2 {} > PMEM 64 | ;; section starts on 2-byte boundary and its size is guaranteed to be multiple of 2 bytes 65 | ;; .mytext: palign(power2) {} > PMEM .. increases section size to the next power of two boundary 66 | ;; .mytext being 120 bytes and PMEM starting at 0x10020 will result in: 67 | ;; .mytext start=0x10080 size=0x80 align=128 68 | ;; block(0x100) .. section must fit between two adresses aligned to the blocking factor 69 | ;; .. if too large it starts on an address boundary 70 | ;; ebss : load = block(0x0080) .. entire section is contained in a single 128-byte page 71 | ;; or begins on that boundary, block and align exclude each other 72 | ;; order: aligned from largest to smallest, blocked from largest to smallest, 73 | ;; others from largest to smallest 74 | ;; page = 1 .. if page is not specified then initialized sections go to 0 and uninitialized to 1 75 | ;; .text: 0x0001000 .. binding 22-bit constant to location. sections must not overlap, 76 | ;; incompatible with named memory 77 | ;; .text: > (X) .. bind to some executable memory, 78 | ;; linker uses lower addresses first and avoids fragmentation when possible 79 | ;; .stack : {} > RAM (HIGH) .. location specifier, use this so that 80 | ;; small changes in application don't lead to large changes in memory map 81 | ;; .text: PAGE=0 .. anywhere in page0 82 | ;; .text : { "f1-new.obj"(.text) "f3-a.obj"(.text,sec2) } 83 | ;; .text : { *(.text) } .. this is the default, if you dont write {..} 84 | ;; *(.data) matches .dataspecial 85 | ;; subsections are separated by colons: A:B:C or europe:north:norway 86 | ;; .rts > BOOT2 { --library=rtsXX.lib(.text) } 87 | ;; .text : {} > MEM1 | MEM2 | MEM3 .. list of ranges for the linker to choose from 88 | ;; .text : {} >> MEM1 | MEM2 | MEM3 .. .text output section can be split 89 | ;; .text : {} >> RAM .. split also works with a single target 90 | ;; .text : {} >> (RW) .. finds sections with matching attributes 91 | ;; some sections should not be split (.cinit autoinitialization C/C++, .pinit global constructors C++) 92 | ;; start end or size; run allocation of a union 93 | 94 | ;; to refer at run time to a load-time address the .label directive defines a special 95 | ;; symbol with the sections load address. you don't need .label if you use the table operator 96 | ;; group, union to organize and conserve memory 97 | ;; group .. allocate contiguously in memory 98 | ;; union .. allocate at same run address 99 | ;; GROUP 0x1000 : { .data term_rec } .. assume term_rec contains termination record for table in .data 100 | ;; you can't specify binding, alignment and allocation into named memory within the group 101 | ;; if you have several routines that you want in fast memory at different stages of execution 102 | ;; or share a block of memory for objects that are not active at the same time 103 | ;; union occupies as much memory as its largest component 104 | ;; UNION : run = FAST_MEM { .ebss:part1: { file1.obj(.ebss) } .ebss:part2: { file2.obj(.ebss) } } 105 | ;; UNION : run = FAST_MEM { .ebss:part1: load= SLOW_MEM { file1.obj(.ebss) } .ebss:part2: load=SLOW_MEM { file2.obj(.ebss) } } 106 | 107 | (with-output-to-string (s) 108 | (format s "~a :" name) 109 | (loop for (property-name value) in properties and i from 0 do 110 | (if (= i 0) 111 | (format s " ~a = ~a" property-name value) 112 | (format s ", ~a = ~a" property-name value)))))) 113 | (section-blocks (destructuring-bind (&rest rest) (cdr code) 114 | (with-output-to-string (s) 115 | (loop for (name target &key page load run type load-start load-end run-start) in rest do 116 | (format s "~a~%" (emit-cmd :code (list 'section-block name target :page page :load load :run run :type type 117 | :load-start load-start :load-end load-end :run-start run-start))))))) 118 | (memory (destructuring-bind (&rest rest) (cdr code) 119 | (with-output-to-string (s) 120 | (format s "MEMORY~%") 121 | (write-sequence (emit-cmd :code `(compound-statement ,@rest)) s)))) 122 | 123 | (compound-statement (destructuring-bind (&rest lines) (cdr code) 124 | (with-output-to-string (s) 125 | (format s "{~%") 126 | (loop for e in lines do 127 | (format s "~a~%" (emit-cmd :code e))) 128 | (format s "}~%")))) 129 | (memory-range (destructuring-bind (name attr origin length &optional fill) (cdr code) 130 | ;; page .. up to 32767 can be specified, overlap possible, defaults to 0 131 | ;; name .. max 64 chars A-Za-z$._ 132 | ;; attr .. R W X I 133 | ;; origin .. 32bit 134 | ;; length .. 22bit 135 | ;; fill .. fill character for range, increases output size! 136 | (with-output-to-string (s) 137 | (format s "~a" name) 138 | (when attr (format s "( ~a )" attr)) 139 | (format s " : origin = ~a, length = ~a" 140 | (emit-cmd :code origin) 141 | (emit-cmd :code length)) 142 | (when fill 143 | (format s ", fill = ~a" fill))))) 144 | (memory-ranges (destructuring-bind (&rest rest) (cdr code) 145 | (with-output-to-string (s) 146 | (loop for (name attr origin length &optional fill) in rest do 147 | (format s "~a~%" (emit-cmd :code `(memory-range ,name ,attr ,origin ,length ,fill))))))) 148 | (page-specifier (destructuring-bind (number) (cdr code) 149 | (format nil "PAGE ~A:" number))) 150 | (t (cond 151 | ;; the following operations are supported: * / % + - , unary: - ~ ! 152 | ((and (= 2 (length code)) (member (car code) '(- ~ !))) 153 | ;; handle unary operators, i.e. - ~ ! 154 | (destructuring-bind (op operand) code 155 | (format nil "(~a (~a))" 156 | op 157 | (emit-cmd :code operand)))) 158 | ((member (car code) '(* / % + -)) 159 | ;; handle binary operators 160 | (with-output-to-string (s) 161 | (format s "(") 162 | (loop for e in (cdr code) 163 | and i below (1- (length (cdr code))) do 164 | (format s "~a ~a " (emit-cmd :code e) (car code))) 165 | (format s "~a)" (emit-cmd :code (car (last (cdr code))))))) 166 | ((member (car code) '(<< >> == = < <= > >= & |\|| && ||||)) 167 | ;; handle logical operators, i.e. ==, &&, ... 168 | (destructuring-bind (op left right) code 169 | (format nil "(~a ~a ~a)" 170 | (emit-cmd :code left) 171 | op 172 | (emit-cmd :code right)))) 173 | 174 | (t (format nil "not processable: ~a" code))))) 175 | (cond ((numberp code) 176 | (format nil "0x~x" code)) 177 | ((or (symbolp code) 178 | (stringp code)) ;; print variable 179 | (substitute #\_ #\- (format nil "~a" code))) 180 | )))) 181 | 182 | #+nil 183 | (emit-cmd :code '(sections 184 | (section-blocks 185 | (.cinit "> FLASHC" :page 0) 186 | (AppRamFuncs nil :load FLASHF :run RAML0 :load-start _RamfuncsLoadStart :load-end _RamfuncsLoadEnd :page 0)))) 187 | 188 | #+nil 189 | (emit-cmd :code '(with-compilation-unit 190 | (raw "#define BUFFER 0") 191 | (memory 192 | (page-specifier 0) 193 | (memory-ranges 194 | (ZONE0 RW #x4000 #x1000 #xffffffff) 195 | (RAML0 () #x8000 (+ #x1000 (&& BUFFER (~ 1))))) 196 | (page-specifier 1) 197 | (memory-range BOOT_RSVD () (+ #x180 (funcall end RAML0 1)) #x50)))) 198 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | ;; http://www.sbcl.org/manual/ 16.3 sb-cover. load this file with C-c 2 | ;; C-l in slime if there are assert errors, the tests fail the section 3 | ;; "How to fix a broke test" in README.org explains how the tests can 4 | ;; be corrected. 5 | 6 | ;; if all tests run successfull, you can see a code coverage report in 7 | ;; coverage/*.html. This will tell which code lines were 8 | ;; checked. Please note that highlighted green in this report not 9 | ;; necessarily means that all cases are checked, e.g format calls with 10 | ;; ~^ in the format string will need to be checked with different 11 | ;; arguments. Any calls of member may also need many tests for full 12 | ;; coverage. 13 | 14 | ;; Note: You can use C-u C-M-x to execute individual test forms and 15 | ;; print the output in the current buffer. 16 | 17 | (require :sb-cover) 18 | 19 | (declaim (optimize sb-cover:store-coverage-data 20 | (speed 0) 21 | (safety 3) 22 | (debug 3))) 23 | #+nil (push :ispc *features*) ;; for now i have to open cp.lisp and compile it again with C-c C-k, so that foreach works 24 | #+nil(compile-file "cp.lisp") 25 | #+nil(load "cp.fasl") 26 | 27 | (in-package :cl-cpp-generator) 28 | 29 | (defun clang-format (str &optional 30 | (fn "/dev/shm/o.cpp") 31 | ) 32 | (with-open-file (s fn 33 | :direction :output :if-exists :supersede :if-does-not-exist :create) 34 | (write-sequence str s)) 35 | (sb-ext:run-program "/usr/bin/clang-format" '("-i" "/dev/shm/o.cpp")) 36 | (sleep .1) 37 | (with-open-file (s fn) 38 | (let ((str (make-string (file-length s)))) 39 | (read-sequence str s) 40 | str))) 41 | 42 | 43 | 44 | (defun test (num code string) 45 | (if (string= 46 | (clang-format (emit-cpp :str nil :code code)) 47 | (clang-format string) 48 | ) 49 | num 50 | (progn 51 | (clang-format (emit-cpp :str nil :code code) "/dev/shm/1") 52 | (clang-format string "/dev/shm/2") 53 | (assert (eq nil 54 | (with-output-to-string (s) 55 | (sb-ext:run-program "/usr/bin/diff" '("/dev/shm/1" "/dev/shm/2") 56 | :output s))))))) 57 | 58 | 59 | (progn ;; for loop 60 | (test 0 61 | '(for ((i a :type int) (< i n) (+= i 1)) 62 | (+= b q)) 63 | "for (int i = a; (i < n); i += 1) { 64 | b += q; 65 | } 66 | ") 67 | (test 1 68 | '(for (() (< i n) (+= i 1)) 69 | (+= b q)) 70 | "for (; (i < n); i += 1) { 71 | b += q; 72 | } 73 | ") 74 | (test 2 75 | '(for ((i a :type int) () (+= i 1)) 76 | (+= b q)) 77 | "for (int i = a; ; i += 1) { 78 | b += q; 79 | } 80 | ") 81 | (test 3 82 | '(for ((i a :type int) (< i n) ()) 83 | (+= b q)) 84 | "for (int i = a; (i < n);) { 85 | b += q; 86 | } 87 | ") 88 | (test 4 89 | '(for ((i a) (< i n) ()) 90 | (+= b q)) 91 | "for (auto i = a; (i < n);) { 92 | b += q; 93 | } 94 | ")) 95 | 96 | (progn ;; if 97 | (test 5 98 | '(if (== a b) (+= a b) (-= a b)) 99 | "if ((a == b)) { 100 | a += b; 101 | } 102 | else { 103 | a -= b; 104 | } 105 | ") 106 | (test 6 107 | '(if (== a b) (+= a b)) 108 | "if ((a == b)) { 109 | a += b; 110 | } 111 | ")) 112 | 113 | (progn ;; setf 114 | (test 7 '(setf q (+ 1 2 3) l (+ 1 2 3)) 115 | "q = (1 + 2 + 3); 116 | l = (1 + 2 + 3); 117 | ") 118 | (test 8 '(setf q (+ 1 2 3)) 119 | "q = (1 + 2 + 3);") 120 | ) 121 | 122 | (progn ;; decl 123 | (test 9 '(decl ((i :type int :init 0) 124 | (f :type float :init 3.2s-7) 125 | (d :type double :init 7.2d-31) 126 | (z :type "complex float" :init #.(complex 2s0 1s0)) 127 | (w :type "complex double" :init #.(complex 2d0 1d0)))) 128 | "int i = 0; 129 | float f = (3.2e-7f); 130 | double d = (7.2e-31); 131 | complex float z = ((2.e+0f) + (1.e+0fi)); 132 | complex double w = ((2.e+0) + (1.e+0i)); 133 | ")) 134 | 135 | (progn ;; let 136 | (test 10 '(let ((i :type int :init 0) 137 | (f :type float :init 3.2s-7) 138 | (d :type double :init 7.2d-31) 139 | (z :type "complex float" :init #.(complex 2s0 1s0)) 140 | (w :type "complex double" :init #.(complex 2d0 1d0))) 141 | (setf i (+ f d) j (- 3 j)) 142 | (+= j (+ 32 q))) 143 | "{ 144 | int i = 0; 145 | float f = (3.2e-7f); 146 | double d = (7.2e-31); 147 | complex float z = ((2.e+0f) + (1.e+0fi)); 148 | complex double w = ((2.e+0) + (1.e+0i)); 149 | 150 | i = (f + d);j = (3 - j); 151 | 152 | j += (32 + q); 153 | } 154 | ") 155 | ) 156 | 157 | (progn ;; computed assignment with complicated variable 158 | (test 11 '(+= "a::b" 3) "a::b += 3")) 159 | 160 | (progn ;; class, struct and union; function declaration 161 | (test 12 '(with-compilation-unit 162 | (include ) 163 | (include "bla.h") 164 | (with-namespace N 165 | (class "gug::senso" () 166 | (access-specifier public) 167 | (function (f ((a :type int)) int :specifier const) 168 | (return i)) 169 | (function (h ((a :type int)) int)) 170 | (access-specifier private) 171 | (function (f2 172 | ((a :type int)) int)) 173 | (function (h2 ((a :type int)) int)) 174 | (decl ((i :type int) 175 | (resetBus :type "Reset::BusCb")))) 176 | (class sensor ("public p::pipeline" 177 | "virtual public qqw::q" 178 | "virtual public qq::q") 179 | (function (sensor ((a :type char)))) 180 | (decl ((j :type int)))) 181 | (union "lag::sensor2" ("private p::pipeline2") 182 | (decl ((j :type int) 183 | (f :type float)))) 184 | (struct "lag::sensor2" ("private p::pipeline2") 185 | (access-specifier public) 186 | (decl ((j :type int) 187 | (f :type float)))) 188 | 189 | 190 | )) 191 | "#include 192 | #include \"bla.h\" 193 | namespace N { 194 | class gug::senso { 195 | public: 196 | 197 | int f(int a) const{ 198 | return i; 199 | } 200 | 201 | int h(int a); 202 | private: 203 | 204 | int f2(int a); 205 | int h2(int a); 206 | int i; 207 | Reset::BusCb resetBus; 208 | 209 | }; 210 | 211 | class sensor : public p::pipeline, virtual public qqw::q, virtual public qq::q{ 212 | sensor(char a); 213 | int j; 214 | 215 | }; 216 | 217 | union lag::sensor2 : private p::pipeline2{ 218 | int j; 219 | float f; 220 | 221 | }; 222 | 223 | struct lag::sensor2 : private p::pipeline2{ 224 | public: 225 | 226 | int j; 227 | float f; 228 | 229 | }; 230 | 231 | } // namespace N 232 | 233 | ")) 234 | 235 | 236 | (progn ;; function definition 237 | (test 13 '(function (g ((a :type char) 238 | (b :type int*)) "complex double::blub") 239 | (decl ((q :init b))) 240 | (setf "blub::q" (+ 1 2 3) 241 | l (+ 1 2 3))) 242 | "complex double::blub g(char a,int* b){ 243 | auto q = b; 244 | 245 | blub::q = (1 + 2 + 3); 246 | l = (1 + 2 + 3); 247 | 248 | } 249 | ") 250 | ;; constructor with initializers 251 | (test 14 '(function (bla ((a :type char) 252 | (b :type int*)) () 253 | :ctor ((a 3) 254 | (sendToSensorCb sendToSensorCb_))) 255 | (+= a b) 256 | ) 257 | "bla(char a,int* b): a( 3 ), sendToSensorCb( sendToSensorCb_ ) 258 | { 259 | a += b; 260 | } 261 | ")) 262 | 263 | (progn ;; function call 264 | (test 15 '(function (g ((a :type char) 265 | (b :type int*)) "complex double::blub") 266 | (funcall add a b)) 267 | "complex double ::blub g(char a, int *b) { add(a, b); } 268 | ")) 269 | 270 | 271 | (progn ;; default parameter 272 | (test 16 `(function (blah ((a :type int :default 3))) 273 | (raw "// ")) 274 | "blah(int a = 3){ 275 | // ; 276 | } 277 | ")) 278 | 279 | (progn ;; terniary operator 280 | (test 17 281 | `(statements (? a b c) 282 | (? (< a b) x) 283 | (? (&& (<= 0 h) (< h 24)) 284 | (= hour h) 285 | (comma-list (<< cout (string "bla")) (= hour 0)) 286 | )) 287 | "( a ) ? ( b ): ( c ); 288 | ( (a < b) ) ? ( x ); 289 | ( ((0 <= h) && (h < 24)) ) ? ( hour = h ): ( (cout << \"bla\"),hour = 0 ); 290 | ")) 291 | 292 | 293 | (progn 294 | (test 18 ;; for-range (c++) 295 | `(statements 296 | (for-range (e (funcall make_iterator_range (string ".") (list )))) 297 | (for-range ((e :type "auto&&") (funcall make_iterator_range (string ".") (list ))))) 298 | " for(auto e : make_iterator_range(\".\",{})) { 299 | } 300 | 301 | for(auto&& e : make_iterator_range(\".\",{})) { 302 | } 303 | ")) 304 | 305 | 306 | (progn 307 | (test 19 ;; new, delete[] 308 | `(let ((buf :type "unsigned char*" :init (new (aref "unsigned char" size)))) 309 | (delete[] buf)) 310 | "{ 311 | unsigned char* buf = new unsigned char[size]; 312 | 313 | delete [] buf; 314 | } 315 | ") 316 | (test 20 ;; new, delete 317 | `(let ((buf :type "unsigned char*" :init (new "unsigned char"))) 318 | (delete buf)) 319 | "{ 320 | unsigned char* buf = new unsigned char; 321 | 322 | delete buf; 323 | } 324 | ")) 325 | 326 | (progn 327 | (test 21 ;; alignment on 64 byte boundary 328 | `(let (((aref buf (* width height)) :type "static int" :extra (raw " __attribute__((aligned(64)))")))) 329 | "{ 330 | static int buf[(width * height)] __attribute__((aligned(64))); 331 | 332 | } 333 | ")) 334 | 335 | (progn 336 | (test 22 ;; enum class 337 | `(with-compilation-unit 338 | (enum-class (ProtocolType) IP ICMP RAW) 339 | (enum-class (fruit :type uint8_t) apple melon)) 340 | "enum class ProtocolType { IP, ICMP, RAW}; 341 | 342 | enum class fruit : uint8_t { apple, melon}; 343 | ")) 344 | 345 | (progn 346 | (test 23 ;; lambda (c++) 347 | `(lambda (((i :type int)) :ret "->int") ) 348 | "[](int i)->int { 349 | } 350 | ")) 351 | 352 | (progn 353 | (test 24 ;; do-while while 354 | `(statements 355 | (while (< 1 a) (+= 1 a) (setf a b)) 356 | (do-while (< 1 a) (+= 1 a) (setf a b))) 357 | " while((1 < a)) { 358 | 1 += a; 359 | a = b; 360 | } 361 | 362 | do { 363 | 1 += a; 364 | a = b; 365 | } 366 | while ( (1 < a) ); 367 | ")) 368 | 369 | (progn 370 | (test 25 ;; || 371 | `(if (|\|\|| a b) 372 | (statements (funcall bal))) 373 | "if ( (a || b) ) { 374 | bal(); 375 | 376 | } 377 | ")) 378 | 379 | (progn 380 | (test 26 ;; ispc 381 | `(with-compilation-unit 382 | (dotimes (i (funcall max 2 3)) 383 | (funcall bla)) 384 | (foreach (i (funcall max 1 0) (funcall min m n)) 385 | (funcall ata)) 386 | (foreach ((i (funcall max 1 0) (funcall min m n)) 387 | (j 0 n)) 388 | (funcall ata)) 389 | (foreach-active (i) 390 | (+= (aref a index) (bit #b0110))) 391 | (function (func ((v :type "uniform int")) "extern void")) 392 | (foreach-unique (val x) 393 | (funcall func val)) 394 | (let ((dx :type float :init (/ (- x1 x0) width)) 395 | (dy :type float :init (/ (- y1 y0) height)) 396 | ) 397 | (foreach (i (funcall max 1 0) (funcall min m n)) 398 | (funcall ata)) 399 | #+nil (foreach (i 0 width) 400 | (let ((x :type float :init (+ x0 (* i dx))) 401 | (y :type float :init (+ y0 (* i dy))) 402 | (index :type int :init (+ i (* j width))) 403 | ) 404 | (setf (aref output index) (funcall mandel x y #+nil max_iterations)))))) 405 | "for(unsigned int i = 0; (i < max(2,3)); i += 1) { 406 | bla(); 407 | } 408 | 409 | foreach(i = max(1,0) ... min(m,n)) { 410 | ata(); 411 | } 412 | 413 | foreach(i = max(1,0) ... min(m,n),j = 0 ... n) { 414 | ata(); 415 | } 416 | 417 | foreach_active(i) { 418 | a[index] += 0b110; 419 | } 420 | 421 | extern void func(uniform int v); 422 | foreach_uniq(val in x) { 423 | func(val); 424 | } 425 | 426 | { 427 | float dx = ((x1 - x0) / width); 428 | float dy = ((y1 - y0) / height); 429 | 430 | foreach(i = max(1,0) ... min(m,n)) { 431 | ata(); 432 | } 433 | 434 | } 435 | ")) 436 | 437 | (progn 438 | (test 27 ;; default member https://jeffamstutz.io/2017/03/04/what-features-i-like-the-most-in-c11-part-2/ 439 | `(class MyClassType () 440 | (access-specifier private) 441 | (decl ((privateInt :type int :extra "{ 1 }")))) 442 | 443 | "class MyClassType { 444 | private: 445 | 446 | int privateInt{ 1 }; 447 | 448 | }; 449 | ")) 450 | 451 | (progn 452 | (test 28 ;; struct inside of function 453 | `(function (bla () void) 454 | (struct b () 455 | (decl ((q :type int) 456 | (w :type float))))) 457 | 458 | "void bla(){ 459 | struct b { 460 | int q; 461 | float w; 462 | 463 | }; 464 | 465 | } 466 | ")) 467 | 468 | (progn 469 | (test 29 ;; operator 470 | `(function (operator= ((a :type "const Array&")) Array&)) 471 | "Array& operator=(const Array& a);")) 472 | 473 | (progn 474 | (defmacro with-fopen ((handle fn) &body body) 475 | `(let ((,handle :type FILE* :init (funcall fopen ,fn (string "wb")))) 476 | ,@body 477 | (funcall fclose ,handle))) 478 | (test 30 ;; macro 479 | `(function (frame_store ((frame_data :type "char*") 480 | (frame_length :type int) 481 | (filename :type "const char*")) void) 482 | (macroexpand (with-fopen (o filename) 483 | (funcall fwrite frame_data frame_length 1 o)))) 484 | 485 | "void frame_store(char* frame_data,int frame_length,const char* filename){ 486 | { 487 | FILE* o = fopen(filename,\"wb\"); 488 | 489 | fwrite(frame_data,frame_length,1,o); 490 | fclose(o); 491 | } 492 | 493 | } 494 | ")) 495 | 496 | ;;(sb-introspect:who-calls ) 497 | 498 | (progn 499 | 500 | (macrolet ((with-fopen ((handle fn) &body body) 501 | `(let ((,handle :type FILE* :init (funcall fopen ,fn (string "wb")))) 502 | ,@body 503 | (funcall fclose ,handle)))) 504 | (test 30 ;; macrolet 505 | `(function (frame_store ((frame_data :type "char*") 506 | (frame_length :type int) 507 | (filename :type "const char*")) void) 508 | (macroexpand (with-fopen (o filename) 509 | (funcall fwrite frame_data frame_length 1 o)))) 510 | 511 | "void frame_store(char* frame_data,int frame_length,const char* filename){ 512 | { 513 | FILE* o = fopen(filename,\"wb\"); 514 | 515 | fwrite(frame_data,frame_length,1,o); 516 | fclose(o); 517 | } 518 | 519 | } 520 | "))) 521 | 522 | 523 | (test 31 ;; constructor inheritance 524 | `(function (CustomRectItem ((x :type qreal) 525 | (y :type qreal) 526 | (w :type qreal) 527 | (h :type qreal) 528 | (parent :type QGraphicsItem* :default nullptr)) 529 | explicit 530 | :parent-ctor 531 | ((QGraphicsRectItem x y w h parent))) 532 | (raw "//")) 533 | 534 | "explicit CustomRectItem(qreal x,qreal y,qreal w,qreal h,QGraphicsItem* parent = nullptr):QGraphicsRectItem(x,y,w,h,parent) 535 | { 536 | //; 537 | } 538 | ") 539 | 540 | 541 | (test 32 ;; multi dimensonal array 542 | `(with-compilation-unit 543 | (aref buf) 544 | (aref buf 1) 545 | (aref buf (+ 1 2) (* i j)) 546 | (aref bta (+ 3 2) 1 1)) 547 | 548 | "buf[] 549 | buf[1] 550 | buf[(1 + 2)][(i * j)] 551 | bta[(3 + 2)][1][1]") 552 | 553 | 554 | 555 | #+nil 556 | (emit-cpp :str nil :code '(with-compilation-unit 557 | (include ) 558 | (include "bla.h") 559 | (with-namespace N 560 | (class "gug::senso" () 561 | (access-specifier public) 562 | (function (f ((a :type int)) int :specifier const) 563 | (return i)) 564 | (function (h ((a :type int)) int)) 565 | (access-specifier private) 566 | (function (f2 567 | ((a :type int)) int)) 568 | (function (h2 ((a :type int)) int)) 569 | (decl ((i :type int) 570 | (resetBus :type "Reset::BusCb")))) 571 | (class sensor ("public p::pipeline" 572 | "virtual public qqw::q" 573 | "virtual public qq::q") 574 | (function (sensor ((a :type char)))) 575 | (decl ((j :type int)))) 576 | (union "lag::sensor2" ("private p::pipeline2") 577 | (decl ((j :type int) 578 | (f :type float)))) 579 | (struct "lag::sensor2" ("private p::pipeline2") 580 | (access-specifier public) 581 | (decl ((j :type int) 582 | (f :type float)))) 583 | 584 | 585 | ))) 586 | 587 | 588 | 589 | (sb-cover:report "/home/martin/stage/cl-cpp-generator/cover/") 590 | 591 | #+nil 592 | (sb-cover:reset-coverage) 593 | 594 | 595 | --------------------------------------------------------------------------------