├── .gitignore ├── version.rkt ├── tests ├── fulmar-core-tests.rkt ├── main.rkt ├── test.fmr ├── core-chunk-tests.rkt └── standard-chunk-tests.rkt ├── info.rkt ├── doc └── fulmar-doc.scrbl ├── examples └── meta │ ├── add.cpp.fmr │ ├── add.cpp │ ├── joinlocation.cpp.fmr │ ├── joinlocation.cpp │ ├── lambdacalculus.cpp.fmr │ └── lambdacalculus.cpp ├── doc.rkt ├── private ├── doc │ ├── document.rkt │ ├── doc-scraper.rkt │ └── doc-gen.rkt ├── generate.rkt ├── utility.rkt ├── core-chunk.rkt └── fulmar-core.rkt ├── apply.rkt ├── verify.rkt ├── LICENSE ├── generate.rkt ├── main.rkt ├── README.md ├── type-decls.rkt ├── meta.rkt ├── FulmarAbbreviations.rkt └── standard-chunk.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | # ignore auto/temporary backups 2 | *~ 3 | 4 | # ignore Racket auto directories 5 | **/compiled/ 6 | -------------------------------------------------------------------------------- /version.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require setup/getinfo) 4 | 5 | (define version-number 6 | ((get-info '("fulmar")) 'version)) 7 | 8 | (define generated-string 9 | (format "/* This file was generated by fulmar version ~a. */~n~n" version-number)) 10 | 11 | (provide version-number 12 | generated-string) 13 | -------------------------------------------------------------------------------- /tests/fulmar-core-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require "../private/fulmar-core.rkt") 5 | 6 | ;unit tests for fulmar-core.rkt 7 | 8 | (define/provide-test-suite test-flatten* 9 | (test-case 10 | "Test flatten*" 11 | (check-equal? (flatten*) null) 12 | (check-equal? (flatten* 'a 'b '(c d e) 'f) '(a b c d e f)))) 13 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version "0.9.2") 4 | (define collection "fulmar") 5 | (define deps '("base" 6 | "scribble-lib" 7 | "typed-racket-lib" 8 | "rackunit-lib" 9 | "sandbox-lib" 10 | "at-exp-lib")) 11 | (define build-deps '("at-exp-lib")) 12 | (define scribblings '(("doc/fulmar-doc.scrbl" ()))) 13 | -------------------------------------------------------------------------------- /doc/fulmar-doc.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "../private/doc/doc-gen.rkt") 4 | 5 | @title{Fulmar} 6 | 7 | @table-of-contents[] 8 | 9 | @section{standard-chunk} 10 | The standard chunks are intended to be the useful high-level forms available to 11 | end users of Fulmar. They come for free when you use @racketfont{#lang fulmar}. 12 | 13 | @(doc-gen "standard-chunk.rkt") 14 | 15 | @section{type-decls} 16 | @(doc-gen "type-decls.rkt") 17 | 18 | @section{verify} 19 | @(doc-gen "verify.rkt") 20 | 21 | @section{fulmar-core} 22 | @(doc-gen "private/fulmar-core.rkt") 23 | -------------------------------------------------------------------------------- /examples/meta/add.cpp.fmr: -------------------------------------------------------------------------------- 1 | #lang fulmar 2 | 3 | (require fulmar/meta) 4 | 5 | (definitions 6 | (define/meta zero) 7 | (define/meta succ (n)) 8 | (define/meta (add m n) 9 | [((succ n-minus-one) m) (add n-minus-one 10 | (succ m))] 11 | [((zero) m) m]) 12 | (define/meta (m-equal a b) 13 | [(v v) v])) 14 | 15 | 16 | #< >, Succ >::result typedef result; 21 | 22 | MEqual > > >::result typedef assert; 23 | 24 | return 0; 25 | } 26 | tests-section-end 27 | 28 | -------------------------------------------------------------------------------- /doc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require 3 | racket/contract 4 | scribble/srcdoc 5 | (for-doc racket/base 6 | scribble/manual)) 7 | 8 | (provide define/doc 9 | (all-from-out racket/contract 10 | scribble/srcdoc)) 11 | 12 | (define-syntax define/doc 13 | (syntax-rules () 14 | [(define/doc (id a ...) contract doc body) 15 | (begin 16 | (provide 17 | (proc-doc/names 18 | id 19 | contract 20 | (a ...) 21 | doc)) 22 | (define (id a ...) 23 | body))] 24 | [(define/doc id contract doc body) 25 | (begin 26 | (provide 27 | (thing-doc 28 | id 29 | contract 30 | doc)) 31 | (define id body))])) 32 | -------------------------------------------------------------------------------- /private/doc/document.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide document) 4 | 5 | (define-syntax-rule (document . _) 6 | (void)) 7 | 8 | (document document 9 | "The document macro is intended to be useful to the doc-scraper and not 10 | racket itself. If you don't have the doc-scraper, don't bother with it." 11 | 12 | "Its purpose is to give the doc-scraper's reader something to look for when 13 | scraping for documentation, while getting completely out of the way when it 14 | comes time to run the code." 15 | 16 | "To use it for your own documentation, the first argument should be the name 17 | of whatever it is you're documenting. The rest of the arguments should be 18 | whatever you want to show up in the paragraphs of the documented thing. 19 | One argument per paragraph.") 20 | -------------------------------------------------------------------------------- /examples/meta/add.cpp: -------------------------------------------------------------------------------- 1 | /* This file was generated by fulmar version 0.9.2. */ 2 | 3 | struct Zero {}; 4 | 5 | template 6 | struct Succ {}; 7 | 8 | template 9 | struct Add; 10 | 11 | template 12 | struct MEqual; 13 | 14 | template 15 | struct Add, M> { 16 | typename Add >::result typedef result; 17 | }; 18 | 19 | template 20 | struct Add { M typedef result; }; 21 | 22 | template 23 | struct MEqual { V typedef result; }; 24 | 25 | int main(int argc, const char *argv[]) 26 | { 27 | Add >, Succ >::result typedef result; 28 | 29 | MEqual > > >::result typedef assert; 30 | 31 | return 0; 32 | } 33 | -------------------------------------------------------------------------------- /private/doc/doc-scraper.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/stream 3 | racket/match 4 | racket/dict 5 | ) 6 | 7 | (provide read-sym-stream 8 | fancy-filter 9 | crush) 10 | 11 | (define (sym-stream name port) 12 | (let ([next-sym (read-syntax name port)]) 13 | (if (eof-object? next-sym) 14 | empty-stream 15 | (stream-cons next-sym (sym-stream name port))))) 16 | 17 | (define (read-sym-stream name port) 18 | (read-language port) 19 | (sym-stream name port)) 20 | 21 | (define (fancy-filter e) 22 | (match (syntax->datum e) 23 | [`(: . ,_) #t] 24 | [`(define-type . ,_) #t] 25 | [`(struct: . ,_) #t] 26 | [`(document . ,_) #t] 27 | [_ #f])) 28 | 29 | (define (crush sym-str) 30 | (stream-fold 31 | (λ (d s) 32 | (match (syntax->datum s) 33 | [`(,_ ,k . ,_) (dict-set d k (cons s (dict-ref d k '())))] 34 | [_ d])) 35 | '() ; Replace with any empty dictionary type 36 | sym-str)) 37 | -------------------------------------------------------------------------------- /apply.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/sandbox) 4 | (require fulmar/version) 5 | 6 | (require "verify.rkt" 7 | "private/generate.rkt") 8 | 9 | (module+ main 10 | (define root-dir 11 | (normalize-path 12 | (command-line 13 | #:program "apply" 14 | #:usage-help "apply fulmar to all .fmr files in a directory (recursing through non-hidden subdirectories) and write the output to corresponding .h and .cpp files." 15 | #:args (filename) 16 | filename))) 17 | 18 | (define fmr-files (map ((curry build-path) root-dir) (find-fmr root-dir))) 19 | (define top-fmr-files (filter find-generated fmr-files)) 20 | 21 | (for ([fmr top-fmr-files]) 22 | (let* ((relative-fmr-string (path->string (find-relative-path root-dir fmr))) 23 | (out-file (find-generated fmr)) 24 | (out (open-output-file out-file #:exists 'truncate)) 25 | (output (evaluate-fmr fmr fmr-files))) 26 | (displayln relative-fmr-string) 27 | (display output out) 28 | (close-output-port out)))) 29 | -------------------------------------------------------------------------------- /private/doc/doc-gen.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require scribble/manual 4 | scribble/racket 5 | racket/stream 6 | racket/dict 7 | "doc-scraper.rkt") 8 | 9 | (provide gen-doc doc-gen) 10 | 11 | (define (gen-doc filepath) 12 | (dict-map (crush (stream-filter fancy-filter 13 | (read-sym-stream filepath 14 | (open-input-file filepath)))) 15 | (λ (k es) (cons 16 | (subsection (symbol->string k)) 17 | (map (λ (e) 18 | (match (syntax->datum e) 19 | [`(document ,_ . ,ps) (map para ps)] 20 | [_ (para (to-element e))])) es))))) 21 | 22 | (define (doc-gen filename) 23 | (let-values ([(path) (current-directory)] 24 | [(parent x y) (split-path (current-directory))]) 25 | (if (file-exists? (build-path path filename)) 26 | (gen-doc (build-path path filename)) 27 | (gen-doc (build-path parent filename))))) 28 | -------------------------------------------------------------------------------- /examples/meta/joinlocation.cpp.fmr: -------------------------------------------------------------------------------- 1 | #lang fulmar 2 | 3 | (require fulmar/meta) 4 | 5 | #<::result typedef result1; 24 | MEqual::result typedef assert1; 25 | 26 | JoinLocation::result typedef result2; 27 | MEqual::result typedef assert2; 28 | 29 | JoinLocation::result typedef result3; 30 | MEqual::result typedef assert3; 31 | 32 | JoinLocation::result typedef result4; 33 | MEqual::result typedef assert4; 34 | 35 | return 0; 36 | } 37 | tests-section-end 38 | -------------------------------------------------------------------------------- /verify.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "private/generate.rkt") 4 | 5 | (module+ main 6 | (define root-dir 7 | (normalize-path 8 | (command-line 9 | #:program "verify" 10 | #:usage-help "apply fulmar to all .fmr files in a directory (recursing through non-hidden subdirectories) and compare the output to corresponding .h and .cpp files for testing." 11 | #:args (filename) 12 | filename))) 13 | 14 | (define fmr-files (map ((curry build-path) root-dir) (find-fmr root-dir))) 15 | (define top-fmr-files (filter find-generated fmr-files)) 16 | 17 | (define matched 18 | (for/and ([fmr top-fmr-files]) 19 | (let* ((relative-fmr-string (path->string (find-relative-path root-dir fmr))) 20 | (comparison-file (find-generated fmr)) 21 | (comparison (file->string comparison-file)) 22 | (output (evaluate-fmr fmr fmr-files)) 23 | (matched (equal? output comparison))) 24 | (displayln (format "~a: ~a" (if matched "matched" "FAILED") relative-fmr-string)) 25 | matched))) 26 | (exit (if matched 27 | 0 28 | 1))) 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 University of Utah 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /examples/meta/joinlocation.cpp: -------------------------------------------------------------------------------- 1 | /* This file was generated by fulmar version 0.9.2. */ 2 | 3 | struct SingleValue; 4 | struct SomethingElse; 5 | template 6 | struct JoinLocation; 7 | 8 | template 9 | struct MEqual; 10 | 11 | template<> 12 | struct JoinLocation { SingleValue typedef result; }; 13 | 14 | template 15 | struct JoinLocation { L typedef result; }; 16 | 17 | template 18 | struct JoinLocation { L typedef result; }; 19 | 20 | template 21 | struct JoinLocation { L typedef result; }; 22 | 23 | template 24 | struct MEqual { V typedef result; }; 25 | int main(int argc, const char *argv[]) 26 | { 27 | JoinLocation::result typedef result1; 28 | MEqual::result typedef assert1; 29 | 30 | JoinLocation::result typedef result2; 31 | MEqual::result typedef assert2; 32 | 33 | JoinLocation::result typedef result3; 34 | MEqual::result typedef assert3; 35 | 36 | JoinLocation::result typedef result4; 37 | MEqual::result typedef assert4; 38 | 39 | return 0; 40 | } 41 | -------------------------------------------------------------------------------- /private/generate.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/sandbox) 4 | (require fulmar/version) 5 | 6 | (provide (all-defined-out)) 7 | 8 | (define (hidden? path) 9 | (ormap (λ (path-element) 10 | (let* ((as-string (path->string path-element)) 11 | (first-character (string-ref as-string 0))) 12 | (eqv? first-character #\.))) 13 | (explode-path path))) 14 | 15 | (define (find-fmr root-dir) 16 | (let* ((relative-paths (map ((curry find-relative-path) root-dir) 17 | (sequence->list (in-directory root-dir)))) 18 | (non-hidden-paths (filter (negate hidden?) relative-paths))) 19 | (filter (λ (path) (equal? (filename-extension path) #"fmr")) non-hidden-paths))) 20 | 21 | (define (find-generated fmr-path) 22 | (let ((trimmed (string->path (string-trim (path->string fmr-path) ".fmr")))) 23 | (if (filename-extension trimmed) 24 | trimmed 25 | #f))) 26 | 27 | (define (evaluate-fmr fmr-path import-paths) 28 | (parameterize ([sandbox-output 'string] 29 | [sandbox-memory-limit 1000] 30 | [sandbox-eval-limits '(60 1000)] 31 | [compile-enforce-module-constants #f]) 32 | (string-append 33 | ; This hack is required because we print the version info with a configure-runtime submodule, which won't run in the 34 | generated-string 35 | (get-output (make-module-evaluator fmr-path #:allow-for-require import-paths))))) -------------------------------------------------------------------------------- /generate.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "private/generate.rkt") 4 | 5 | (module+ main 6 | (define root-dir 7 | (normalize-path 8 | (command-line 9 | #:program "generate" 10 | #:usage-help "apply fulmar to all .fmr files in a directory (recursing through non-hidden subdirectories) and replacing the output in the corresponding .h and .cpp files if different." 11 | #:args (filename) 12 | filename))) 13 | 14 | (define fmr-files (map ((curry build-path) root-dir) (find-fmr root-dir))) 15 | (define top-fmr-files (filter find-generated fmr-files)) 16 | 17 | (for ([fmr top-fmr-files]) 18 | (let* ((relative-fmr-string (path->string (find-relative-path root-dir fmr))) 19 | (comparison-file (find-generated fmr)) 20 | (comparison (file->string comparison-file)) 21 | (output (evaluate-fmr fmr fmr-files)) 22 | (matched (equal? output comparison))) 23 | (if matched 24 | (displayln (format "~a: ~a" "matched " relative-fmr-string)) 25 | (begin (if (file-exists? comparison-file) 26 | (rename-file-or-directory comparison-file 27 | (string->path (string-append (path->string comparison-file) 28 | "~r~")) 29 | #t) 30 | (void)) 31 | (display-to-file output comparison-file) 32 | (displayln (format "~a: ~a" "generated" relative-fmr-string))))))) 33 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "private/core-chunk.rkt" 4 | "private/fulmar-core.rkt" 5 | "version.rkt" 6 | "standard-chunk.rkt" 7 | "doc.rkt" 8 | syntax/wrap-modbeg) 9 | 10 | (provide (except-out (all-from-out racket) #%module-begin #%top-interaction ) 11 | (all-from-out "standard-chunk.rkt" "doc.rkt") 12 | (rename-out 13 | [fulmar-module-begin #%module-begin] 14 | [fulmar-top-interaction #%top-interaction])) 15 | 16 | ; Provide a reader supporting at-expressions for srcdoc. 17 | (module reader syntax/module-reader 18 | #:language 'fulmar 19 | (require (only-in scribble/reader use-at-readtable)) 20 | (use-at-readtable)) 21 | 22 | ; Compile and print the passed chunks. 23 | (define (print-values vs) 24 | (for-each displayln 25 | (reverse (write-chunk vs)))) 26 | 27 | ; This macro manipulates expressions entered in the REPL 28 | (define-syntax-rule (fulmar-top-interaction f ...) 29 | (print-values (f ...))) 30 | 31 | ; This macro manipulates the module body. 32 | (define-syntax-rule (fulmar-module-begin a ...) 33 | (fulmar-wrapping-module-begin 34 | ; use a configure-runtime submodule to print the version info once and only once - not once 35 | ; per involved #lang fulmar file (as would be the case if we just added a side effect here) 36 | (module configure-runtime racket/base 37 | (require racket/format 38 | fulmar/version) 39 | (display generated-string)) 40 | a 41 | ...)) 42 | 43 | (define-syntax fulmar-wrapping-module-begin 44 | (make-wrapping-module-begin 45 | #'print-values)) 46 | -------------------------------------------------------------------------------- /private/utility.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | ; A simple maybe monad for racket 6 | 7 | (struct: Nothing ()) 8 | (struct: (a) Just ([v : a])) 9 | 10 | (define-type (Maybe a) (U Nothing (Just a))) 11 | 12 | ; Cons together everything that isn't nothing 13 | 14 | (: cons-with-maybe (All (a) ((Maybe a) 15 | (Listof a) 16 | -> (Listof a)))) 17 | (define (cons-with-maybe ar dr) 18 | (cond 19 | [(Nothing? ar) dr] 20 | [(Just? ar) (let ([v (Just-v ar)]) (cons v dr))])) 21 | 22 | ; Take a list of Maybe something and produce a list of only the Justs 23 | 24 | (: all-justs (All (a) ((Listof (Maybe a)) -> (Listof a)))) 25 | (define (all-justs in-list) 26 | (: helper ((Listof (Maybe a)) (Listof a) -> (Listof a))) 27 | (define (helper ls acc) 28 | (match ls 29 | ['() 30 | #;=> 31 | acc] 32 | [(cons x xs) 33 | #;=> 34 | (helper xs (cons-with-maybe x acc))])) 35 | (reverse (helper in-list '()))) 36 | 37 | ; Take a predicate and a list of two things and separate the list. 38 | 39 | (: segregate (All (a b) (((U a b) -> (Pairof (Maybe a) (Maybe b))) 40 | (Listof (U a b)) 41 | -> (Pairof (Listof a) (Listof b))))) 42 | (define (segregate sifter lst) 43 | (foldr 44 | (λ: ([e : (U a b)] [p : (Pairof (Listof a) (Listof b))]) 45 | (let ([se (sifter e)]) 46 | (let ([l (car se)] 47 | [r (cdr se)] 48 | [ls (car p)] 49 | [rs (cdr p)]) 50 | (ann (cons (cons-with-maybe l ls) 51 | (cons-with-maybe r rs)) (Pairof (Listof a) (Listof b)))))) 52 | (ann '(() . ()) (Pairof (Listof a) (Listof b))) 53 | lst)) 54 | -------------------------------------------------------------------------------- /examples/meta/lambdacalculus.cpp.fmr: -------------------------------------------------------------------------------- 1 | #lang fulmar 2 | 3 | (require fulmar/meta) 4 | 5 | #< 7 | #include 8 | #include 9 | imports-section-end 10 | 11 | (definitions 12 | ; structs 13 | (define/meta zero) 14 | (define/meta succ (n)) 15 | (define/meta m-lambda (name body)) 16 | (define/meta app (fun arg)) 17 | (define/meta ref (name)) 18 | (define/meta lit (t)) 19 | (define/meta emptyenv) 20 | (define/meta binding (name value env)) 21 | (define/meta closure (lam env)) 22 | ; functions 23 | (define/meta (env-lookup name env) 24 | [(name (binding name value env)) value] 25 | [(_ (binding name2 value env)) (env-lookup name env)]) 26 | (define/meta (m-eval exp env) 27 | [((lit t) _) t] 28 | [((ref name) _) (env-lookup name env)] 29 | [((m-lambda name body) _) (closure (m-lambda name body) env)] 30 | [((app fun arg) _) (m-apply (m-eval fun env) 31 | (m-eval arg env))]) 32 | (define/meta (m-apply proc value) 33 | [((closure (m-lambda name body) env) _) 34 | (m-eval body (binding name value env))]) 35 | (define/meta (m-equal a b) 36 | [(v v) v])) 37 | 38 | #< 1, 3 => 0](3): 45 | EnvLookup, 46 | Binding > > :: result typedef result1; 48 | 49 | MEqual::result typedef assert1; 50 | 51 | // Testing ((lambda (x) x) 2): 52 | 53 | MEval >,Lit > > >,Emptyenv> :: result typedef result2; 54 | 55 | MEqual > >::result typedef assert2; 56 | 57 | std::cout << "All tests passed!" << std::endl; 58 | 59 | return EXIT_SUCCESS ; 60 | } 61 | tests-section-end 62 | -------------------------------------------------------------------------------- /examples/meta/lambdacalculus.cpp: -------------------------------------------------------------------------------- 1 | /* This file was generated by fulmar version 0.9.2. */ 2 | 3 | #include 4 | #include 5 | #include 6 | struct Zero {}; 7 | 8 | template 9 | struct Succ {}; 10 | 11 | template 12 | struct MLambda {}; 13 | 14 | template 15 | struct App {}; 16 | 17 | template 18 | struct Ref {}; 19 | 20 | template 21 | struct Lit {}; 22 | 23 | struct Emptyenv {}; 24 | 25 | template 26 | struct Binding {}; 27 | 28 | template 29 | struct Closure {}; 30 | 31 | template 32 | struct EnvLookup; 33 | 34 | template 35 | struct MEval; 36 | 37 | template 38 | struct MApply; 39 | 40 | template 41 | struct MEqual; 42 | 43 | template 44 | struct EnvLookup > { Value typedef result; }; 45 | 46 | template 47 | struct EnvLookup > { 48 | typename EnvLookup::result typedef result; 49 | }; 50 | 51 | template 52 | struct MEval, Gensym8> { T typedef result; }; 53 | 54 | template 55 | struct MEval, Gensym9> { 56 | typename EnvLookup::result typedef result; 57 | }; 58 | 59 | template 60 | struct MEval, Gensym10> { 61 | Closure, Gensym10> typedef result; 62 | }; 63 | 64 | template 65 | struct MEval, Gensym11> { 66 | typename MApply::result, 67 | typename MEval::result>::result typedef result 68 | ; 69 | }; 70 | 71 | template 72 | struct MApply, Env>, Gensym12> { 73 | typename MEval >::result typedef result; 74 | }; 75 | 76 | template 77 | struct MEqual { V typedef result; }; 78 | class X {}; 79 | class Y {}; 80 | 81 | int main (int argc, char* argv[]) { 82 | 83 | // Testing [2 => 1, 3 => 0](3): 84 | EnvLookup, 85 | Binding > > :: result typedef result1; 87 | 88 | MEqual::result typedef assert1; 89 | 90 | // Testing ((lambda (x) x) 2): 91 | 92 | MEval >,Lit > > >,Emptyenv> :: result typedef result2; 93 | 94 | MEqual > >::result typedef assert2; 95 | 96 | std::cout << "All tests passed!" << std::endl; 97 | 98 | return EXIT_SUCCESS ; 99 | } 100 | -------------------------------------------------------------------------------- /tests/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require rackunit/text-ui) 5 | (require "fulmar-core-tests.rkt") 6 | (require "core-chunk-tests.rkt") 7 | (require "standard-chunk-tests.rkt") 8 | 9 | ;sequentially check if any tests fail 10 | ; returns true if all given tests pass 11 | ; false if any of the given tests fail 12 | ; prints out summary as well 13 | (define/contract (sequential-run-tests verbosity . tests) 14 | (->* (symbol?) #:rest (listof test-suite?) boolean?) 15 | (andmap (λ (test) (= 0 (run-tests test verbosity))) 16 | tests)) 17 | 18 | ;check if any tests fail with text-based output 19 | ; returns true if all given tests pass 20 | ; false if any of the given tests fail 21 | ; prints out summary as well 22 | (define/contract (run-tests-text . tests) 23 | (->* () #:rest (listof test-suite?) boolean?) 24 | (andmap (λ (test) (= 0 (run-tests test 'verbose))) 25 | tests)) 26 | 27 | ;check if any tests fail quietly 28 | ; returns true if all given tests pass 29 | ; false if any of the given tests fail 30 | (define/contract (test-fail? . tests) 31 | (->* () #:rest (listof test-suite?) boolean?) 32 | (andmap (λ (test) (= 0 (run-tests test 'quiet))) 33 | tests)) 34 | 35 | ;fulmar-core tests: 36 | (define/contract fulmar-core-tests 37 | (listof test-suite?) 38 | (list test-flatten*)) 39 | 40 | (apply run-tests-text fulmar-core-tests) 41 | 42 | ;core chunk tests: 43 | (define/contract core-chunk-tests 44 | (listof test-suite?) 45 | (list test-combine-strings 46 | test-length-equals-one 47 | test-chunk-transform 48 | test-literal 49 | test-space 50 | test-new-line 51 | test-pp-directive 52 | test-empty 53 | test-concat 54 | test-immediate 55 | test-speculative 56 | test-position-indent 57 | test-indent 58 | test-comment-env-chunk)) 59 | 60 | (apply run-tests-text core-chunk-tests) 61 | 62 | ;standard chunk tests: 63 | (define/contract standard-core-tests 64 | (listof test-suite?) 65 | (list test-basic-chunks 66 | test-attach-list-separator 67 | test-between 68 | test-between/attach 69 | test-arg-list 70 | test-paren-list 71 | test-template-list 72 | test-constructor-assignment-list 73 | test-body 74 | test-smt-list 75 | test-pp-define 76 | test-pp-include 77 | test-pp-includes 78 | test-pp-ifdef 79 | test-pp-ifndef 80 | test-pp-else 81 | test-pp-endif 82 | test-pp-conditional 83 | test-pp-conditional-ifdef 84 | test-pp-conditional-ifndef 85 | test-pp-header-file 86 | test-macro-define 87 | test-namespace-define 88 | test-described-smts 89 | test-constize 90 | test-template-define 91 | test-template-use 92 | test-function-declare 93 | test-static-function-declare 94 | test-void-function-declare 95 | test-function-define 96 | test-void-function-define 97 | test-returning-function-define 98 | test-constructor-assignment 99 | test-constructor 100 | test-struct-declare 101 | test-template-struct-declare 102 | test-section-define 103 | test-struct-define 104 | test-template-struct-define 105 | test-scope-resolution-operator 106 | test-typedef-smt 107 | test-function-call 108 | test-member-function-call)) 109 | 110 | (apply run-tests-text standard-core-tests) 111 | -------------------------------------------------------------------------------- /private/core-chunk.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (require "fulmar-core.rkt" 4 | "doc/document.rkt") 5 | 6 | ;fulmar core chunks - these directly build nekots or use fulmar-core functionality 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;helper functions;;;;;;;;;;;; 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | ;fulmar-core definitions 13 | (provide flatten* 14 | Chunk 15 | NestofChunks) 16 | 17 | (provide (all-defined-out)) 18 | 19 | ;combine strings 20 | (: combine-strings ((U Symbol String) * -> String)) 21 | (define (combine-strings . values) 22 | (apply string-append 23 | (map (λ: ([s : (U Symbol String)]) 24 | (cond 25 | [(symbol? s) (symbol->string s)] 26 | [else s])) 27 | values))) 28 | 29 | ;helper for speculative 30 | ; (located here for testing) 31 | (: length-equals-one (All (a) ((Listof a) -> Boolean))) 32 | (define (length-equals-one lst) 33 | (and (pair? lst) 34 | (= 1 (length lst)))) 35 | 36 | 37 | (document not-ends-in->> 38 | "Helper function for speculative that will return false if the given chunks 39 | end in >>.") 40 | (: not-ends-in->> ((Listof String) -> Boolean)) 41 | (define (not-ends-in->> lst) 42 | (match lst 43 | [`(,(regexp #rx">>$") . ,_) #f] 44 | [_ #t])) 45 | 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | ;;nekot-building chunks;;;;;;; 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | 50 | ;literal chunk 51 | ; simple string 52 | (: literal ((U Symbol String) * -> String)) 53 | (define (literal . strings) 54 | (apply combine-strings strings)) 55 | 56 | ;sequence of spaces chunk 57 | ; adds some number of spaces 58 | (: space Chunk) 59 | (define space (Space)) 60 | 61 | ;new line chunk 62 | ; adds a new line 63 | (define new-line 64 | (Newline)) 65 | 66 | ;preprocessor directive chunk 67 | ; correctly adds # to line 68 | (define pp-directive "#") 69 | 70 | ;empty (no-op) chunk 71 | ; only real uses of this chunk are for testing and filing in stubs/empty parameters 72 | (define empty 73 | "") 74 | 75 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 76 | ;;meta-nekot-building chunks;; 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | 79 | ;concatenation chunk 80 | ; sets up a general concatenation chunks 81 | ; - attempts to put as many on the same line as possible 82 | ; - no spaces added 83 | (: concat (NestofChunks * -> Concat)) 84 | (define (concat . chunks) 85 | (Concat (flatten* chunks))) 86 | 87 | ;immediate chunk 88 | ; bypasses usual writing rules and writes chunk immediately after preceeding chunk 89 | (define: (immediate [chunk : Chunk]) : Immediate 90 | (Immediate chunk)) 91 | 92 | ;speculative chunk 93 | ; attempts different chunks 94 | ; run proc on first chunk 95 | ; if proc returns true, use results of first chunk 96 | ; otherwise, use results of second chunk 97 | (: speculative (Chunk ((Listof String) -> Boolean) Chunk -> Speculative)) 98 | (define (speculative attempt success? backup) 99 | (Speculative attempt success? backup)) 100 | 101 | ;position indent chunk 102 | ; sets indent to current position of line 103 | (: position-indent (Chunk -> Position-indent)) 104 | (define (position-indent chunk) 105 | (Position-indent chunk)) 106 | 107 | ;indent chunk 108 | ; increases current indent 109 | (: indent (Integer Chunk -> Indent)) 110 | (define (indent length chunk) 111 | (Indent chunk length)) 112 | 113 | ;comment env chunk 114 | ; puts chunks in a comment env environment 115 | (: comment-env-chunk (case-> [Chunk -> Comment] 116 | [Chunk Char -> Comment])) 117 | (define (comment-env-chunk chunk [init-char #\space]) 118 | (Comment chunk init-char)) 119 | -------------------------------------------------------------------------------- /private/fulmar-core.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | #;(provide (all-defined-out)) 4 | 5 | (struct: S-chunk () #:transparent) 6 | 7 | (define-type Chunk (U String Symbol Integer S-chunk)) 8 | (define-type NestofChunks (Rec T (U (Listof T) Chunk))) 9 | 10 | (struct: Newline S-chunk () #:transparent) 11 | (struct: Space S-chunk () #:transparent) 12 | (struct: Immediate S-chunk ([body : Chunk]) #:transparent) 13 | (struct: Position-indent S-chunk ([body : Chunk]) #:transparent) 14 | (struct: Concat S-chunk ([chunks : (Listof Chunk)]) #:transparent) 15 | (struct: Comment S-chunk ([body : Chunk] 16 | [init-char : Char]) #:transparent) 17 | (struct: Indent S-chunk ([body : Chunk] 18 | [length : Integer]) #:transparent) 19 | (struct: Speculative S-chunk ([attempt : Chunk] 20 | [success? : ((Listof String) -> Boolean)] 21 | [backup : Chunk]) #:transparent) 22 | 23 | (require/typed typed/racket 24 | [flatten ((Listof NestofChunks) -> (Listof Chunk))]) 25 | 26 | (: flatten* (NestofChunks * -> (Listof Chunk))) 27 | (define (flatten* . lst) 28 | (flatten lst)) 29 | 30 | (provide (all-defined-out)) 31 | 32 | (define mode (make-parameter 'normal)) 33 | (define indention (make-parameter "")) 34 | (define line-length (make-parameter 80)) 35 | (: in-comment? (Parameterof Boolean)) 36 | (define in-comment? (make-parameter #f)) 37 | 38 | (: make-whitespace (Integer -> String)) 39 | (define (make-whitespace n) 40 | (make-string n #\space)) 41 | 42 | ; Removes TRAILING whitespace from the end of a line 43 | (: remove-whitespace (String -> String)) 44 | (define (remove-whitespace line) 45 | ; (string-trim line #:left? #f)) 46 | (define: (last-non-whitespace-index [ii : Integer]) : Integer 47 | (let ([i (- ii 1)]) 48 | (cond 49 | [(> 0 i) 0] 50 | [(not (equal? #\space (string-ref line i))) ii] 51 | [else (last-non-whitespace-index i)]))) 52 | (let ([i (last-non-whitespace-index (string-length line))]) 53 | (substring line 0 i))) 54 | ; Another tested alternative: 55 | ; (let ([index (do: : Integer ([i (- (string-length line) 1) (- i 1)]) 56 | ; ((or (> 0 i) (not (equal? #\space (string-ref line i)))) 57 | ; (+ i 1)))]) 58 | ; (substring line 0 index))) 59 | 60 | (: is-whitespace? (String -> Boolean)) 61 | (define (is-whitespace? line) 62 | (zero? (string-length (remove-whitespace line)))) 63 | 64 | (: finish-line (String -> String)) 65 | (define (finish-line given-line) 66 | (if (equal? given-line (indention)) 67 | "" 68 | (remove-whitespace given-line))) 69 | 70 | (: add-literal (String String -> (Listof String))) 71 | (define (add-literal string line) 72 | (let* ((stringl (string-length string)) 73 | (linel (string-length line))) 74 | (cond [(= 0 stringl) 75 | (list line)] 76 | [(or (equal? 'immediate (mode)) 77 | (<= (+ stringl linel) 78 | (line-length)) 79 | (>= (string-length (indention)) 80 | linel)) 81 | (list (string-append line string))] 82 | [else 83 | (list (string-append (indention) string) 84 | (finish-line line))]))) 85 | 86 | (: add-space (String -> (Listof String))) 87 | (define (add-space line) 88 | (if (or (equal? (mode) 'immediate) 89 | (< (string-length line) (line-length))) 90 | (list (string-append line " ")) 91 | (list "" (finish-line line)))) 92 | 93 | (: add-concatenated ((Listof Chunk) String -> (Listof String))) 94 | (define (add-concatenated chunks line) 95 | (for/fold: ([lines : (Listof String) (list line)]) 96 | ([chunk : Chunk (in-list chunks)]) 97 | (append (write-chunk chunk (car lines)) 98 | (cdr lines)))) 99 | 100 | (: add-speculative ((List Chunk ((Listof String) -> Boolean) Chunk) String -> (Listof String))) 101 | (define (add-speculative body line) 102 | (match-let* ([(list attempt success? backup) body] 103 | [attempted (write-chunk attempt line)]) 104 | (if (success? attempted) 105 | attempted 106 | (write-chunk backup line)))) 107 | 108 | (: write-chunk (case-> 109 | [Chunk -> (Listof String)] 110 | [Chunk String -> (Listof String)])) 111 | (define write-chunk 112 | (case-lambda 113 | [(chunk) 114 | (write-chunk chunk "")] 115 | [(chunk line) 116 | (define new-line (if (equal? line "") 117 | (indention) 118 | line)) 119 | (match chunk 120 | [(and (? string?) ch) 121 | (add-literal ch new-line)] 122 | [(and (? symbol?) ch) 123 | (add-literal (symbol->string ch) new-line)] 124 | [(and (? exact-nonnegative-integer?) ch) 125 | (add-literal (number->string ch) new-line)] 126 | [(Speculative attempt success? backup) 127 | (add-speculative `(,attempt ,success? ,backup) new-line)] 128 | [(Indent body length) 129 | (parameterize ([indention (string-append (indention) (make-whitespace length))]) 130 | (write-chunk body line))] 131 | [(Position-indent body) 132 | (parameterize ([indention (make-whitespace (string-length line))]) 133 | (write-chunk body line))] 134 | [(Comment body init-char) 135 | (let ([was-in-comment (in-comment?)]) 136 | (parameterize ([in-comment? #t]) 137 | (write-chunk 138 | (Concat 139 | (flatten (list "/*" 140 | (string init-char) 141 | (Position-indent body) 142 | (if was-in-comment 143 | " **" 144 | " */")))) line)))] 145 | [(Concat chunks) 146 | (add-concatenated chunks new-line)] 147 | [(Immediate body) 148 | (parameterize ([mode 'immediate]) 149 | (write-chunk body line))] 150 | [(Newline) 151 | (list "" (finish-line line))] 152 | [(Space) 153 | (add-space new-line)] 154 | )])) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Fulmar 2 | ====== 3 | 4 | Fulmar is currently considered **unstable**, and may break backwards compatibility. 5 | 6 | Fulmar is a C++ code generation framework. It was originally created to generate most of the tens of thousands of lines of code that make up the Nebo PDE domain-specific language. 7 | The goal is to make Fulmar generally useful, though at present it is still very specialized to Nebo. 8 | Fulmar is being developed by a team of computer science researchers at the University of Utah. See AUTHORS for more details. 9 | 10 | Intended Audience 11 | ----------------- 12 | 13 | (Who should use Fulmar?) 14 | 15 | Fulmar leverages the power of Racket to generate C++ code. If you're finding yourself writing highly repetitive C++ and neither macros nor template metaprogramming are helping (or you've been using them and they've become cumbersome), Fulmar was designed to solve your problem. 16 | 17 | Getting Fulmar 18 | -------------- 19 | 20 | (or, "I'm sold! How do I get it?") 21 | 22 | Hold your horses! Fulmar is still in its early stages of development. It may not be ready for your mission-critical, 24-7-365 build-server-on-a-lunar-rocket application yet. In fact, it's entirely possible that Fulmar may not be ready for your try-project-euler-in-a-new-language application yet. 23 | 24 | That said, if you want to download and try Fulmar, you can clone its main git repo: 25 | https://github.com/cwearl/fulmar.git 26 | 27 | Dependencies 28 | ------------ 29 | 30 | Fulmar requires Racket version 6.0.1 or greater. 31 | Of course, the code Fulmar generates is pretty useless without a C++ compiler, unless you intend to turn it into abstract art. 32 | The compiler compatibility of the C++ code Fulmar generates depends entirely on what code gets generated. Fulmar should be quite capable of generating code that any C++ compiler can handle, so no specific compiler dependencies are necessary. 33 | 34 | Installation 35 | ------------ 36 | **Fulmar requires Racket 6.0.1 or later. Being just recently released, it may not yet be packaged by your distro yet.** 37 | 38 | (or, "Ooookay, I've got the code. Now what?") 39 | 40 | Using Fulmar consists of writing one or more Fulmar files (\*.fmr) and running them with Racket. Before you can do that, Racket needs to be made aware of Fulmar's existence. 41 | 42 | Currently, Fulmar has no automated way to install itself. Fortunately, it's fairly straightforward to get it in working order: 43 | 44 | 1. Place a copy of the Fulmar source tree where you want it to live on your system. 45 | 46 | If you're the only one using Fulmar on this computer, you can probably just stuff it somewhere in your home directory. (For example, ~/projects/fulmar or ~/src/fulmar) 47 | If you want a system-wide install, this has to be a location that can be read by everyone who should be able to use Fulmar. (For example, on Linux it might be a good idea to create /usr/local/share/fulmar or /opt/fulmar and put the Fulmar source tree there.) 48 | 49 | 2. Create a symbolic link from the Racket collections directory to the Fulmar source tree. 50 | 51 | If you're doing a single-user setup, you can just make a link in ~/.racket/x.y.z/collects where x.y.z is the version number of your Racket installation. 52 | 53 | The following link contains more information about how and where to set up the symbolic link to get Fulmar working: 54 | http://docs.racket-lang.org/guide/language-collection.html 55 | 56 | There's a suite of pseudo-unit/regression tests in the tests/ directory. Currently, you can run tests/main.rkt to test Fulmar. 57 | 58 | Use 59 | --- 60 | 61 | Once you've gone through the installation above, you should be able to run Fulmar scripts from DrRacket or from the terminal like so: 62 | 63 | racket myscript.fmr 64 | 65 | There is a Fulmar script in tests/ called test.fmr that you can try out. 66 | 67 | When run, a Fulmar script produces formatted C++ code on standard out. Assuming your terminal shell supports output redirection (most do), you can redirect the C++ code to a file: 68 | 69 | racket myscript.fmr > myscript.C 70 | 71 | You can then compile the resulting file with your favorite C++ compiler. If your compiler supports reading from standard input, you can skip the intermediate C++ file altogether. For example, if you are using the GCC C++ compiler: 72 | 73 | racket myscript.fmr | g++ -x c++ -c -o myscript.o - 74 | 75 | Of course, this would make it difficult to track down any compile errors, but it could potentially be useful when compiling a large number of Fulmar scripts. 76 | 77 | Trivial Example Script 78 | ---------------------- 79 | 80 | A full tutorial on creating Fulmar scripts is beyond the scope of this humble README. There will be separate documentation detailing Fulmar's semantics and how to leverage it. 81 | 82 | The following is a very simple Fulmar script: 83 | 84 | #lang fulmar 85 | 86 | (returning-function-define (constize (function-declare 'eval 'double)) 87 | null 88 | 'value_) 89 | 90 | When run, this script produces the following output: 91 | 92 | inline double eval(void) const { return value_; } 93 | 94 | The first argument of returning-function-define is a function signature, the second is the body of the function, and the third argument is the return value of the function. 95 | 96 | Documenting Defined Forms 97 | ------------------------- 98 | 99 | Fulmar provides a define/doc macro that allows for documentation inline with function and variable definition. The supported forms are: 100 | 101 | (define/doc 102 | (id args ...) 103 | contract 104 | doc 105 | body) 106 | 107 | for functions and 108 | 109 | (define/doc 110 | id 111 | contract 112 | doc 113 | body) 114 | 115 | for general bindings. 116 | 117 | contract is as defined at http://docs.racket-lang.org/scribble/srcdoc.html#%28form._%28%28lib._scribble%2Fsrcdoc..rkt%29._proc-doc%29%29 118 | 119 | doc is a description expression in racket's at-expression 120 | format. See here for details: http://docs.racket-lang.org/scribble/reader.html 121 | 122 | An example from tests/test.fmr: 123 | 124 | (define/doc l 125 | (-> any/c any/c) 126 | @{Rename for built in @racket[literal]} 127 | literal) 128 | 129 | 130 | Known Issues, Caveats, Notes 131 | ---------------------------- 132 | 133 | Because Fulmar is implemented in Racket, and because Fulmar scripts are essentially an extension of Racket, the following link to the Racket documentation has been included in this README. If you have little to no experience with Racket and/or you're having trouble writing a useful Fulmar script, this is an excellent resource to begin with: 134 | http://docs.racket-lang.org/guide/ 135 | 136 | License and Copyright 137 | --------------------- 138 | 139 | Fulmar is Copyright (c) 2014 University of Utah. It is licensed under the terms of the MIT License. A copy of the full text of this license is included in the LICENSE file. 140 | -------------------------------------------------------------------------------- /type-decls.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | ;;; GET FULMAR CHUNK-MAKING FUNCTIONS ;;; 4 | 5 | (require "private/fulmar-core.rkt" 6 | "private/core-chunk.rkt" 7 | "standard-chunk.rkt" 8 | "private/utility.rkt") 9 | 10 | ; This really belongs in an abbreviations file or somewhere. Anywhere but here. 11 | ; It's here now because I don't have a complete typed abbreviations file, and 12 | ; if I did, I'm not sure requiring it in this file would be a good idea. 13 | (: between-spaces ((Listof Chunk) -> Chunk)) 14 | (define (between-spaces chunks) 15 | (let ([chunks (filter (λ (x) (not (eq? empty x))) chunks)]) 16 | (match chunks 17 | ['() empty] 18 | [(cons x '()) x] 19 | [_ (apply between " " chunks)]))) 20 | 21 | ;;; TYPE DEFINITIONS ;;; 22 | 23 | (define-type NDBoolean (U Boolean 'unspecified)) 24 | (define-type C++-base-type (U C++-pointable-type Symbol)) 25 | (define-type C++-type-size (U 'long 'short 'longlong)) 26 | (define-type C++-type-signedness (U 'signed 'unsigned)) 27 | (define-type C++-type-qualifier (U 'const 'volatile)) 28 | (define-type C++-float-type (U 'float 'double 'longdouble)) 29 | 30 | ;; Internal C++ type representation ;; 31 | 32 | (struct: C++-type 33 | ([base : C++-base-type]) 34 | #:transparent) 35 | 36 | (struct: C++-qualified-type C++-type 37 | ([qualifiers : (Listof C++-type-qualifier)]) 38 | #:transparent) 39 | 40 | (struct: C++-pointable-type C++-qualified-type () #:transparent) 41 | (struct: C++-reference-type C++-qualified-type () #:transparent) 42 | (struct: C++-pointer-type C++-pointable-type () #:transparent) 43 | 44 | (struct: C++-array-type C++-pointable-type 45 | ([length : Chunk]) 46 | #:transparent) 47 | 48 | ; Primitive type stuff 49 | (struct: C++-sizable-type C++-pointable-type 50 | ([size : (Maybe C++-type-size)]) 51 | #:transparent) 52 | 53 | (struct: C++-integer-type C++-sizable-type 54 | ([signedness : (Maybe C++-type-signedness)]) 55 | #:transparent) 56 | 57 | ; Template type stuff 58 | (struct: C++-templated-type C++-pointable-type 59 | ([parameters : (Listof C++-type)]) ; Should allow more kinds of parameters 60 | #:transparent) 61 | 62 | ;;; PUBLIC CONSTRUCTORS ;;; 63 | 64 | (provide typ-float 65 | typ-double 66 | typ-long-double 67 | typ-int 68 | typ-char 69 | typ-pointer 70 | typ-reference 71 | typ-array 72 | typ-template-type) 73 | 74 | (: typ-float (C++-type-qualifier * -> C++-pointable-type)) 75 | (define (typ-float . qualifiers) 76 | (C++-pointable-type 'float qualifiers)) 77 | 78 | (: typ-double (C++-type-qualifier * -> C++-pointable-type)) 79 | (define (typ-double . qualifiers) 80 | (C++-pointable-type 'double qualifiers)) 81 | 82 | (: typ-long-double (C++-type-qualifier * -> C++-sizable-type)) 83 | (define (typ-long-double . qualifiers) 84 | (C++-sizable-type 'double qualifiers (Just 'long))) 85 | 86 | (: typ-int ([#:size (U Null C++-type-size)] 87 | [#:sign (U Null C++-type-signedness)] 88 | C++-type-qualifier * -> C++-integer-type)) 89 | (define (typ-int #:size [size '()] #:sign [signedness '()] . qualifiers) 90 | (let ([size (if (null? size) (Nothing) (Just size))] 91 | [signedness (if (null? signedness) (Nothing) (Just signedness))]) 92 | (C++-integer-type 'int qualifiers size signedness))) 93 | 94 | (: typ-char ([#:sign (U Null C++-type-signedness)] 95 | C++-type-qualifier * -> C++-integer-type)) 96 | (define (typ-char #:sign [signedness '()] . qualifiers) 97 | (let ([signedness (if (null? signedness) (Nothing) (Just signedness))]) 98 | (C++-integer-type 'char qualifiers (Nothing) signedness))) 99 | 100 | (: typ-pointer (C++-pointable-type C++-type-qualifier * -> C++-pointer-type)) 101 | (define (typ-pointer base . qualifiers) 102 | (C++-pointer-type base qualifiers)) 103 | 104 | (: typ-reference (C++-pointable-type C++-type-qualifier * -> C++-reference-type)) 105 | (define (typ-reference base . qualifiers) 106 | (C++-reference-type base qualifiers)) 107 | 108 | (: typ-array (C++-pointable-type 109 | Integer 110 | C++-type-qualifier * -> C++-array-type)) 111 | (define (typ-array base length . qualifiers) 112 | (C++-array-type base qualifiers length)) 113 | 114 | (: typ-template-type (C++-base-type 115 | (U C++-type C++-type-qualifier) * -> C++-templated-type)) 116 | (define (typ-template-type base . qualifiers-and-params) 117 | (let: ([sqa : (Pairof (Listof C++-type) (Listof C++-type-qualifier)) 118 | (segregate (λ: ([q-or-p : (U C++-type C++-type-qualifier)]) 119 | (if (C++-type? q-or-p) 120 | (cons (Just q-or-p) (Nothing)) 121 | (cons (Nothing) (Just q-or-p)))) 122 | qualifiers-and-params)]) 123 | 124 | (let ([params (car sqa)] 125 | [qualifiers (cdr sqa)]) 126 | (C++-templated-type base qualifiers params)))) 127 | 128 | ;;; TYPE RENDERING ;;; 129 | 130 | (provide dcl-variable 131 | dcl-type) 132 | 133 | (: render-base-type (C++-base-type -> Chunk)) 134 | (define (render-base-type type) 135 | (if (C++-pointable-type? type) 136 | (render-simple-type type) 137 | type)) 138 | 139 | (: render-simple-type (C++-qualified-type -> Chunk)) 140 | (define (render-simple-type type) 141 | (match type 142 | [(C++-integer-type base qualifiers size signedness) 143 | #;=> 144 | (between-spaces (append (all-justs `(,size ,signedness)) `(,(render-base-type base) ,@qualifiers)))] 145 | [(C++-sizable-type base qualifiers size) 146 | #;=> 147 | (between-spaces (cons-with-maybe size `(,(render-base-type base) ,@qualifiers)))] 148 | [(C++-qualified-type base qualifiers) 149 | #;=> 150 | (between-spaces `(,(render-base-type base) ,@qualifiers))])) 151 | 152 | (: dcl-variable ((U C++-type C++-base-type) Chunk -> Chunk)) 153 | (define (dcl-variable type name) 154 | (match type 155 | [(C++-reference-type (and base (C++-array-type _ _ _)) qualifiers) 156 | #;=> 157 | (dcl-variable base 158 | (concat "(&" (between-spaces `(,@qualifiers ,name)) ")"))] 159 | [(C++-pointer-type (and base (C++-array-type _ _ _)) qualifiers) 160 | #;=> 161 | (dcl-variable base 162 | (concat "(*" (between-spaces `(,@qualifiers ,name)) ")"))] 163 | [(C++-reference-type base qualifiers) 164 | #;=> 165 | (dcl-variable base 166 | (concat "&" (between-spaces `(,@qualifiers ,name))))] 167 | [(C++-pointer-type base qualifiers) 168 | #;=> 169 | (dcl-variable base 170 | (concat "*" (between-spaces `(,@qualifiers ,name))))] 171 | [(C++-array-type base _ length) 172 | #;=> 173 | (dcl-variable base 174 | (concat name "[" length "]"))] 175 | [(C++-templated-type base qualifiers parameters) 176 | #;=> 177 | (between-spaces 178 | `(,(concat (dcl-type base) 179 | "< " 180 | (apply between/attach "," " " (map dcl-type parameters)) 181 | " >") ,@qualifiers ,name))] 182 | [(and t (C++-qualified-type _ _)) 183 | #;=> 184 | (between-spaces `(,(render-simple-type t) ,name))] 185 | [(C++-type base) 186 | #;=> 187 | (between-spaces `(,(render-base-type base) ,name))] 188 | [else 189 | #;=> 190 | (if (symbol? type) 191 | (between-spaces `(,type ,name)) 192 | (error "Unexpected type: " type))])) 193 | 194 | (: dcl-type ((U C++-type C++-base-type) -> Chunk)) 195 | (define (dcl-type type) 196 | (dcl-variable type empty)) -------------------------------------------------------------------------------- /tests/test.fmr: -------------------------------------------------------------------------------- 1 | #lang fulmar 2 | ; Copyright (c) 2013 The University of Utah 3 | ; 4 | ; Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ; of this software and associated documentation files (the "Software"), to 6 | ; deal in the Software without restriction, including without limitation the 7 | ; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 8 | ; sell copies of the Software, and to permit persons to whom the Software is 9 | ; furnished to do so, subject to the following conditions: 10 | ; 11 | ; The above copyright notice and this permission notice shall be included in 12 | ; all copies or substantial portions of the Software. 13 | ; 14 | ; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | ; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 20 | ; IN THE SOFTWARE. 21 | 22 | (define/doc l 23 | (-> any/c any/c) 24 | @{Rename for built in @racket[literal]} 25 | literal) 26 | 27 | (define c concat) 28 | (define b between) 29 | (define b/a between/attach) 30 | (define n namespace-define) 31 | (define d described-smts) 32 | (define p paren-list) 33 | (define m macro-define) 34 | (define s 1) 35 | (define (cs . chunks) 36 | (c chunks s)) 37 | (define (scs . chunks) 38 | (c s chunks s)) 39 | (define (cc . chunks) 40 | (c chunks ";")) 41 | (define (ccs first second) 42 | (c first ";" s second)) 43 | (define (bs . chunks) 44 | (apply b s chunks)) 45 | (define (bb . chunks) 46 | (apply b blank-line chunks)) 47 | (define (bn . chunks) 48 | (apply b new-line chunks)) 49 | (define (sbs . chunks) 50 | (cc (bs chunks))) 51 | (define (bl-smts . chunks) 52 | (internal-smt-list blank-line chunks)) 53 | (define (nl-smts . chunks) 54 | (smt-list new-line chunks)) 55 | (define typedef typedef-smt) 56 | (define (s-typedef first second) 57 | (cc (typedef-smt first second))) 58 | (define fc function-call) 59 | (define mfc member-function-call) 60 | (define fcn-def function-define) 61 | (define v-fcn-def void-function-define) 62 | (define v-fcn-dcl void-function-declare) 63 | (define r-fcn-def returning-function-define) 64 | (define fcn-dcl function-declare) 65 | (define gen-fcn-dcl general-function-declare) 66 | (define s-fcn-dcl static-function-declare) 67 | (define tpl-def template-define) 68 | (define srt-dcl struct-declare) 69 | (define (s-srt-dcl . chunks) 70 | (cc (apply srt-dcl chunks))) 71 | (define srt-def struct-define) 72 | (define (s-srt-def . chunks) 73 | (cc (apply srt-def chunks))) 74 | (define tpl-srt-dcl template-struct-declare) 75 | (define (s-tpl-srt-dcl . chunks) 76 | (cc (apply tpl-srt-dcl chunks))) 77 | (define tpl-srt-def template-struct-define) 78 | (define (s-tpl-srt-def . chunks) 79 | (cc (apply tpl-srt-def chunks))) 80 | (define tpl-use template-use) 81 | (define (tpl-pmtr pmtr) 82 | (bs 'typename pmtr)) 83 | (define (sub-tpl-use pmtr) 84 | (bs 'template pmtr)) 85 | (define (tpl-fcn-use . pmtrs) 86 | (sub-tpl-use (apply tpl-use pmtrs))) 87 | (define pub-sec public-section) 88 | (define priv-sec private-section) 89 | (define cons-asgn constructor-assignment) 90 | (define scope scope-resolution-operator) 91 | (define (enum . enums) 92 | (sbs 'enum (body-list "," enums))) 93 | (define (kernel-use name . args) 94 | (tpl-use name (tpl-use null (tpl-use null args)))) 95 | (define (device-use . chunks) 96 | (bs '__device__ chunks)) 97 | (define (gbl-fcn-dcl name . params) 98 | (bs '__global__ (general-function-declare name 'void params))) 99 | (define (pp-cond-or name then else) 100 | (pp-conditional-ifdef name 101 | (c then) 102 | (if (not else) 103 | #false 104 | (c else)))) 105 | (define (threads-or then else) 106 | (pp-cond-or 'FIELD_EXPRESSION_THREADS then else)) 107 | (define (threads-only . chunks) 108 | (threads-or chunks #false)) 109 | (define (gpu-or then else) 110 | (pp-cond-or '__CUDACC__ then else)) 111 | (define (gpu-only . chunks) 112 | (gpu-or chunks #false)) 113 | (define (gpu-test-or then else) 114 | (pp-cond-or 'NEBO_GPU_TEST then else)) 115 | (define (gpu-test-only . chunks) 116 | (gpu-test-or chunks #false)) 117 | (define (report-backend-or then else) 118 | (pp-cond-or 'NEBO_REPORT_BACKEND then else)) 119 | (define (report-backend-only . chunks) 120 | (report-backend-or chunks #false)) 121 | (define (report-backend-cout type backend-name) 122 | (report-backend-only (bs (scope 'std 'cout) 123 | '<< 124 | (surround "\"" (bs type 'Nebo backend-name)) 125 | '<< 126 | (scope 'std 'endl)))) 127 | (define (report-backend-start backend-name) 128 | (report-backend-cout 'Starting backend-name)) 129 | (define (report-backend-finish backend-name) 130 | (report-backend-cout 'Finished backend-name)) 131 | (define (full-gpu-test-or then else) 132 | (gpu-only (gpu-test-or then else))) 133 | (define (full-gpu-test-only . chunks) 134 | (full-gpu-test-or chunks #false)) 135 | (define (par . chunks) 136 | (p (bs chunks))) 137 | (define (ter-cond if then else) 138 | (par if '? then ":" else)) 139 | (define (op-asgn op lhs . rhs) 140 | (bs lhs op rhs)) 141 | (define (n= lhs . rhs) 142 | (op-asgn '= lhs rhs)) 143 | (define (nt= type lhs . rhs) 144 | (n= (bs type lhs) rhs)) 145 | (define (nt=c type lhs . rhs) 146 | (nt= (bs 'const type) lhs rhs)) 147 | (define (n+= lhs . rhs) 148 | (op-asgn '+= lhs rhs)) 149 | (define (n== lhs . rhs) 150 | (op-asgn '== lhs rhs)) 151 | (define (n!= lhs . rhs) 152 | (op-asgn '!= lhs rhs)) 153 | (define (n< lhs . rhs) 154 | (op-asgn '< lhs rhs)) 155 | (define (n> lhs . rhs) 156 | (op-asgn '> lhs rhs)) 157 | (define (n<= lhs . rhs) 158 | (op-asgn '<= lhs rhs)) 159 | (define (n>= lhs . rhs) 160 | (op-asgn '>= lhs rhs)) 161 | (define (n+ lhs . rhs) 162 | (op-asgn '+ lhs rhs)) 163 | (define (n- lhs . rhs) 164 | (op-asgn '- lhs rhs)) 165 | (define (n* lhs . rhs) 166 | (op-asgn '* lhs rhs)) 167 | (define (n/ lhs . rhs) 168 | (op-asgn '/ lhs rhs)) 169 | (define (n% lhs . rhs) 170 | (op-asgn '% lhs rhs)) 171 | (define (n++ chunk) 172 | (l chunk '++)) 173 | (define (n-and lhs . rhs) 174 | (b (scs '&&) lhs rhs)) 175 | (define (n-or lhs . rhs) 176 | (b (scs "||") lhs rhs)) 177 | (define (n-not chunk) 178 | (c '! (par chunk))) 179 | (define (tc . chunks) 180 | (bs chunks 'const)) 181 | (define (stc . chunks) 182 | (cc (tc chunks))) 183 | (define (ref . chunks) 184 | (bs chunks '&)) 185 | (define (cref . chunks) 186 | (ref (tc chunks))) 187 | (define (ptr . chunks) 188 | (bs chunks '*)) 189 | (define (cptr . chunks) 190 | (ptr (tc chunks))) 191 | (define (ad type arg) 192 | (bs type arg)) 193 | (define (sad type arg) 194 | (cc (ad type arg))) 195 | (define (adc type arg) 196 | (bs (tc type) arg)) 197 | (define (sadc type arg) 198 | (cc (adc type arg))) 199 | (define (adr type arg) 200 | (bs (ref type) arg)) 201 | (define (sadr type arg) 202 | (cc (adr type arg))) 203 | (define (adcr type arg) 204 | (bs (cref type) arg)) 205 | (define (sadcr type arg) 206 | (cc (adcr type arg))) 207 | (define (adp type arg) 208 | (bs (ptr type) arg)) 209 | (define (sadp type arg) 210 | (cc (adp type arg))) 211 | (define (adcp type arg) 212 | (bs (cptr type) arg)) 213 | (define (sadcp type arg) 214 | (cc (adcp type arg))) 215 | (define (take-ptr . chunks) 216 | (c '& chunks)) 217 | (define (nif check . then) 218 | (bs (fc 'if check) 219 | (body then))) 220 | (define (nelse else) 221 | (bs 'else (body else))) 222 | (define (nifelse check then else) 223 | (b new-line 224 | (nif check then) 225 | (nelse else))) 226 | (define (nelseif check . then) 227 | (bs 'else (nif check then))) 228 | (define (nifelseif check1 then1 check2 then2) 229 | (b new-line 230 | (nif check1 then1) 231 | (nelseif check2 then2))) 232 | (define (nwhile while . body) 233 | (bs (fc 'while while) 234 | (body body))) 235 | (define (nfor init check next . chunks) 236 | (bs (fc 'for (bs (cc init) 237 | (cc check) 238 | next)) 239 | (body chunks))) 240 | 241 | 242 | (nfor (nt= 'int 'i "0") 243 | (n< 'i "100") 244 | (n++ 'i) 245 | 'body1 246 | (n= (c '* 'i) 247 | "100")) 248 | -------------------------------------------------------------------------------- /tests/core-chunk-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require "../private/fulmar-core.rkt") 5 | (require "../private/core-chunk.rkt") 6 | 7 | ;unit tests for core-chunk.rkt 8 | 9 | ;helper functions 10 | 11 | (define/provide-test-suite test-combine-strings 12 | (test-case 13 | "Test combine-strings" 14 | (check-equal? (combine-strings "asdf") "asdf") 15 | (check-equal? (combine-strings 'asdf) "asdf") 16 | (check-equal? (combine-strings "asdf" "jkl") "asdfjkl") 17 | (check-equal? (combine-strings "asdf" 'jkl) "asdfjkl") 18 | (check-equal? (combine-strings 'asdf "jkl") "asdfjkl") 19 | (check-equal? (combine-strings 'asdf 'jkl) "asdfjkl"))) 20 | 21 | (define/provide-test-suite test-length-equals-one 22 | (test-case 23 | "Test length-equals-one" 24 | (check-true (length-equals-one (list ""))) 25 | (check-true (length-equals-one (list " "))) 26 | (check-true (length-equals-one (list "abcd"))) 27 | (check-false (length-equals-one (list "" ""))) 28 | (check-false (length-equals-one (list "" " "))) 29 | (check-false (length-equals-one (list " " ""))) 30 | (check-false (length-equals-one (list " " " "))) 31 | (check-false (length-equals-one (list "abcd" ""))) 32 | (check-false (length-equals-one (list "" "abcd"))) 33 | (check-false (length-equals-one (list "abcd" "abcd"))))) 34 | 35 | (define/provide-test-suite test-chunk-transform 36 | (test-case 37 | "Test chunk-transform - tests only implicit chunks (not structured chunks)" 38 | (check-equal? (write-chunk "asdf") 39 | '("asdf")) 40 | (check-equal? (write-chunk 'asdf) 41 | '("asdf")) 42 | (check-equal? (write-chunk 1) 43 | '("1")) 44 | (check-equal? (write-chunk 4) 45 | '("4")))) 46 | 47 | ;nekot-building chunks 48 | 49 | (define/provide-test-suite test-literal 50 | (test-case 51 | "Test literal" 52 | (check-equal? (write-chunk (literal "asdf")) 53 | '("asdf")) 54 | (check-equal? (write-chunk (literal 'asdf)) 55 | '("asdf")) 56 | (check-equal? (write-chunk (literal "asdf" "jkl")) 57 | '("asdfjkl")) 58 | (check-equal? (write-chunk (literal "asdf" 'jkl)) 59 | '("asdfjkl")) 60 | (check-equal? (write-chunk (literal 'asdf "jkl")) 61 | '("asdfjkl")) 62 | (check-equal? (write-chunk (literal 'asdf 'jkl)) 63 | '("asdfjkl")))) 64 | 65 | (define/provide-test-suite test-space 66 | (test-case 67 | "Test space" 68 | (check-equal? (write-chunk space) 69 | '(" ")))) 70 | 71 | (define/provide-test-suite test-new-line 72 | (test-case 73 | "Test new-line" 74 | (check-equal? (write-chunk new-line) 75 | '("" "")) 76 | (check-equal? (write-chunk new-line) 77 | '("" "")))) 78 | 79 | (define/provide-test-suite test-pp-directive 80 | (test-case 81 | "Test pp-directive" 82 | (check-equal? (write-chunk pp-directive) 83 | '("#")))) 84 | 85 | ;meta-nekot-building chunks 86 | 87 | (define/provide-test-suite test-empty 88 | (test-case 89 | "Test empty" 90 | (check-equal? (write-chunk empty) 91 | '("")) 92 | (check-equal? (write-chunk (concat empty 93 | "asdf")) 94 | '("asdf")))) 95 | 96 | (define/provide-test-suite test-concat 97 | (test-case 98 | "Test concat" 99 | (check-equal? (write-chunk (concat 'asdf 'jkl)) 100 | '("asdfjkl")) 101 | (check-equal? (write-chunk (concat (list 'asdf 'jkl))) 102 | '("asdfjkl")) 103 | (check-equal? (write-chunk (concat 'asdf 4 'jkl)) 104 | '("asdf4jkl")))) 105 | 106 | (define/provide-test-suite test-immediate 107 | (test-case 108 | "Test immediate" 109 | (check-equal? (write-chunk (immediate 'asdf)) 110 | '("asdf")) 111 | (check-equal? (write-chunk (immediate 4)) 112 | '("4")) 113 | (check-equal? (write-chunk (immediate (concat 4 'asdf))) 114 | '("4asdf")))) 115 | 116 | (define/provide-test-suite test-speculative 117 | (test-case 118 | "Test speculative" 119 | (define test-success? (λ (any) #false)) 120 | (define check-length (λ (lst) (= 1 (length lst)))) 121 | (check-equal? (write-chunk (speculative 'asdf test-success? 'jkl)) 122 | '("jkl")) 123 | (check-equal? (write-chunk (speculative new-line check-length 4)) 124 | '("4")))) 125 | 126 | (define/provide-test-suite test-position-indent 127 | (test-case 128 | "Test position-indent" 129 | (define test 'asdf) 130 | (define test-2 'jkl) 131 | (check-equal? (write-chunk (position-indent 'asdf)) 132 | '("asdf")) 133 | (check-equal? (write-chunk (concat 'asdf (position-indent (concat new-line 'jkl)))) 134 | '(" jkl" 135 | "asdf")))) 136 | 137 | 138 | ;context-aware chunks 139 | 140 | (define/provide-test-suite test-indent 141 | (test-case 142 | "Test indent" 143 | (check-equal? (write-chunk (indent 0 (concat 'asdf new-line 'jkl))) 144 | '("jkl" 145 | "asdf")) 146 | (check-equal? (write-chunk (indent 2 (concat 'asdf new-line 'jkl))) 147 | '(" jkl" 148 | " asdf")) 149 | (check-equal? (write-chunk (indent 3 (concat 'asdf new-line 'jkl))) 150 | '(" jkl" 151 | " asdf")) 152 | (check-equal? (write-chunk (indent 5 (concat 'asdf new-line 'jkl))) 153 | '(" jkl" 154 | " asdf")) 155 | (check-equal? (write-chunk (indent 2 (concat 'asdf new-line 'jkl))) 156 | '(" jkl" 157 | " asdf")) 158 | (check-equal? (write-chunk (indent 3 (concat 'asdf new-line 'jkl))) 159 | '(" jkl" 160 | " asdf")) 161 | (check-equal? (write-chunk (indent 5 (concat 'asdf new-line 'jkl))) 162 | '(" jkl" 163 | " asdf")) 164 | (check-equal? (write-chunk (indent 2 (indent 1 (concat 'asdf new-line 'jkl)))) 165 | '(" jkl" 166 | " asdf")) 167 | (check-equal? (write-chunk (indent 3 (indent 2 (concat 'asdf new-line 'jkl)))) 168 | '(" jkl" 169 | " asdf"))) 170 | (test-case 171 | "Test indent - interaction with position-indent tests" 172 | (check-equal? (write-chunk (concat 123 (position-indent (concat 'asdf new-line 'jkl)))) 173 | '(" jkl" 174 | "123asdf")) 175 | (check-equal? (write-chunk (indent 3 (concat 'asdf (position-indent (concat new-line 'jkl))))) 176 | '(" jkl" 177 | " asdf")) 178 | (check-equal? (write-chunk (indent 3 (concat 'asdf (position-indent (concat new-line 'jkl new-line "123"))))) 179 | '(" 123" 180 | " jkl" 181 | " asdf")) 182 | (check-equal? (write-chunk (indent 3 (concat 'asdf (position-indent (concat new-line 'jkl new-line (indent 1 "123")))))) 183 | '(" 123" 184 | " jkl" 185 | " asdf")) 186 | (check-equal? (write-chunk (indent 3 (concat 'asdf (position-indent (concat new-line 187 | (indent 1 'jkl) 188 | new-line 189 | "123"))))) 190 | '(" 123" 191 | " jkl" 192 | " asdf")))) 193 | 194 | (define/provide-test-suite test-comment-env-chunk 195 | (test-case 196 | "Test comment-env-chunk" 197 | (check-equal? (write-chunk (comment-env-chunk 'asdf #\*)) 198 | '("/**asdf */")) 199 | (check-equal? (write-chunk (comment-env-chunk 'asdf #\ )) 200 | '("/* asdf */")) 201 | (check-equal? (write-chunk (comment-env-chunk 'asdf)) 202 | '("/* asdf */")) 203 | (check-equal? (write-chunk (comment-env-chunk (indent 2 (comment-env-chunk 'asdf)))) 204 | '("/* /* asdf ** */")) 205 | (check-equal? (write-chunk (comment-env-chunk (concat new-line (indent 2 (comment-env-chunk 'asdf))))) 206 | '(" /* asdf ** */" 207 | "/*")) 208 | (check-equal? (write-chunk (comment-env-chunk (concat 'asdf new-line 'jkl))) 209 | '(" jkl */" 210 | "/* asdf")))) 211 | -------------------------------------------------------------------------------- /meta.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require fulmar/standard-chunk 4 | fulmar/FulmarAbbreviations 5 | fulmar/private/fulmar-core 6 | (for-syntax racket)) 7 | 8 | (provide define/meta definitions definitions-chunk) 9 | 10 | 11 | ; Structs that hold the functions called to produce chunks for various parts 12 | ; of meta-functions and meta-structs. Using instances as procedures gets the ref. 13 | (struct meta-struct (def-thunk ref-fn) #:transparent 14 | #:property prop:procedure (struct-field-index ref-fn)) 15 | (struct meta-function (decl-thunk def-thunk ref-fn) #:transparent 16 | #:property prop:procedure (struct-field-index ref-fn)) 17 | 18 | 19 | ; Remove hyphens and titlecase to make a C++-like type name. 20 | (define-for-syntax (make-cpp-id id) 21 | (string-replace (string-titlecase id) "-" "")) 22 | 23 | (define-for-syntax (syntax->cpp-id stx) 24 | (make-cpp-id (symbol->string (syntax->datum stx)))) 25 | 26 | 27 | ; Meta-struct implementation 28 | 29 | (define (make-struct-def-thunk name-cpp-id field-cpp-ids) 30 | (lambda () 31 | (if (null? field-cpp-ids) 32 | (stmt-def-struct 33 | name-cpp-id 34 | '()) 35 | (stmt-def-template-struct 36 | name-cpp-id 37 | (map typename field-cpp-ids) 38 | '())))) 39 | 40 | (define (make-struct-ref-fn name-cpp-id field-count) 41 | (define (reffun . args) 42 | (when (not (= (length args) field-count)) 43 | (define arguments-list 44 | (string-join (map ~v args) "\n ")) 45 | (error (format 46 | #<cpp-id name)] 63 | [field-cpp-ids (map syntax->cpp-id (syntax->list fields))] 64 | [field-count (length field-cpp-ids)]) 65 | #`(define #,name (meta-struct 66 | (make-struct-def-thunk #,name-cpp-id (quote #,field-cpp-ids)) 67 | (make-struct-ref-fn #,name-cpp-id #,field-count))))) 68 | 69 | 70 | ; Meta-function implementation. 71 | 72 | ; This sort of repeats make-struct-def-thunk. Need to abstract something out maybe? 73 | ; I guess this one isn't too bad. 74 | (define (make-fn-decl-thunk name-cpp-id arg-cpp-ids) 75 | (lambda () 76 | (stmt-dcl-template-struct 77 | name-cpp-id 78 | (map typename arg-cpp-ids) 79 | '()))) 80 | 81 | ; But this one is almost totally repetetive. Abstract. 82 | (define (make-fn-ref-fn name-cpp-id field-count) 83 | (define (reffun . args) 84 | (when (not (= (length args) field-count)) 85 | (define arguments-list 86 | (string-join (map ~v args) "\n ")) 87 | (error (format 88 | #<list #'(args ...)))] 121 | [vars-set (remove-duplicates 122 | (apply append (map transformed-vars transformed-args)) 123 | free-identifier=?)] 124 | [ref-expr #`(mstruct #,@(map transformed-ref transformed-args))]) 125 | (transformed vars-set ref-expr))] 126 | [id 127 | (if (identifier? #'id) 128 | (transformed (list #'id) #'id) 129 | (transformed '() #'id))])) 130 | 131 | (define-for-syntax (match-case name-cpp-id args matchargs return) 132 | (define transformed-args (map transform-match matchargs)) 133 | (define vars-set (remove-duplicates 134 | (apply append (map transformed-vars transformed-args)) 135 | free-identifier=?)) 136 | (define tpl-params (map syntax->cpp-id vars-set)) 137 | (define (with-params stx) 138 | #`(let ( 139 | #,@(map (lambda (var cpp-id) #`[#,var #,cpp-id]) vars-set tpl-params) 140 | ) 141 | #,stx)) 142 | (define ref-chunks (map (compose with-params transformed-ref) transformed-args)) 143 | (define (with-args stx) 144 | #`(let ( 145 | #,@(map (lambda (arg expr) #`[#,arg #,expr]) args ref-chunks) 146 | ) 147 | #,stx) 148 | ) 149 | #`( 150 | stmt-def-template-struct 151 | #,name-cpp-id 152 | (map typename (list #,@tpl-params)) ;template args 153 | (list #,@ref-chunks) ; partial specialization 154 | (stmt-typedef #,(with-args (with-params return)) 'result) 155 | ) 156 | ) 157 | 158 | (define-for-syntax (make-fn-def-thunk name-cpp-id args clauses) 159 | #`(lambda () 160 | (top-list 161 | #,@(map (lambda (stx) 162 | (syntax-case stx () 163 | [[(matchargs ...) return] 164 | (match-case name-cpp-id args (syntax->list #'(matchargs ...)) #'return)])) 165 | clauses)))) 166 | 167 | (define-for-syntax (meta-fn-stx stx) 168 | (syntax-case stx () 169 | [(_ (name args ...) 170 | [(matchargs ...) return] ...) 171 | (let* ([name-cpp-id (syntax->cpp-id #'name)] 172 | [arg-cpp-ids (map syntax->cpp-id (syntax->list #'(args ...)))] 173 | [arg-count (length arg-cpp-ids)]) 174 | #`(define name (meta-function 175 | (make-fn-decl-thunk #,name-cpp-id (quote #,arg-cpp-ids)) 176 | #,(make-fn-def-thunk name-cpp-id (syntax->list #'(args ...)) 177 | (syntax->list #'([(matchargs ...) return] ...))) 178 | (make-fn-ref-fn #,name-cpp-id #,arg-count) 179 | )) 180 | )])) 181 | 182 | (define-syntax (define/meta stx) 183 | (syntax-case stx () 184 | [(_ name) 185 | (meta-struct-stx #'name #'())] 186 | [(_ (name args ...) 187 | [(matchargs ...) return] ...) 188 | (meta-fn-stx stx)] 189 | [(_ name (field fields ...)) 190 | (meta-struct-stx #'name #'(field fields ...))])) 191 | 192 | 193 | ; Definitions chunk implementation. 194 | 195 | (define (definitions-chunk args) 196 | (apply top-list 197 | (append (map 198 | (lambda (item) 199 | (cond 200 | [(meta-struct? item) ((meta-struct-def-thunk item))] 201 | [(meta-function? item) ((meta-function-decl-thunk item))])) 202 | args) 203 | (map 204 | (lambda (item) 205 | ((meta-function-def-thunk item))) 206 | (filter meta-function? args))))) 207 | 208 | (define-syntax (definitions stx) 209 | (syntax-case stx () 210 | [(_ subforms ...) 211 | (let* ([expanded-subforms (map (lambda (subform) 212 | (local-expand subform (syntax-local-context) (list #'define))) 213 | (syntax->list #'(subforms ...)))] 214 | [defined-ids (map (lambda (expanded-subform) 215 | (syntax-case expanded-subform () 216 | [(define id expr) #'id])) 217 | expanded-subforms)]) 218 | #`(begin 219 | subforms ... 220 | (definitions-chunk (list #,@defined-ids))))])) 221 | 222 | 223 | #| 224 | 225 | It would be better if these were unit tests. 226 | 227 | (meta/define test (a b)) 228 | (write-chunk ((meta-struct-def-thunk test))) 229 | (write-chunk ((meta-struct-ref-fn test) "a" "b")) 230 | ; Test 231 | 232 | (write-chunk ((meta-struct-ref-fn test) "a" "b" "c")) 233 | ; arity mismatch 234 | 235 | ; prop:procedure use test 236 | (write-chunk (test "a" 'b)) 237 | ; Test 238 | (write-chunk (test "a" "b" "c")) 239 | ; arity mismatch 240 | 241 | ; This shouldn't work - define with (meta/define test2) instead. 242 | (meta/define test2 ()) 243 | ; bad syntax 244 | 245 | (meta/define test3) 246 | (write-chunk ((meta-struct-def-thunk test3))) 247 | ; struct Test3 {}; 248 | (write-chunk ((meta-struct-ref-fn test3))) 249 | ; Test3 250 | 251 | (meta/define (myf arg) 252 | [('double) (test 'a 'b)]) 253 | (write-chunk ((meta-function-decl-thunk myf))) 254 | ; template 255 | ; struct Myf; 256 | (write-chunk (myf 'a)) 257 | ; Myf::result 258 | (write-chunk ((meta-function-def-thunk myf))) 259 | 260 | (meta/define (myf2 arg) 261 | [('double) (myf 'a)]) 262 | (write-chunk ((meta-function-def-thunk myf2))) 263 | 264 | |# 265 | -------------------------------------------------------------------------------- /FulmarAbbreviations.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | ; Copyright (c) 2014 The University of Utah 4 | ; 5 | ; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ; of this software and associated documentation files (the "Software"), to 7 | ; deal in the Software without restriction, including without limitation the 8 | ; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 9 | ; sell copies of the Software, and to permit persons to whom the Software is 10 | ; furnished to do so, subject to the following conditions: 11 | ; 12 | ; The above copyright notice and this permission notice shall be included in 13 | ; all copies or substantial portions of the Software. 14 | ; 15 | ; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ; IN THE SOFTWARE. 22 | 23 | (provide (all-defined-out)) 24 | 25 | (require "private/fulmar-core.rkt") 26 | (require "standard-chunk.rkt") 27 | 28 | (: space-after (NestofChunks * -> Chunk)) 29 | (define (space-after . chunks) 30 | (concat chunks space)) 31 | (: spaces-around (NestofChunks * -> Chunk)) 32 | (define (spaces-around . chunks) 33 | (concat space chunks space)) 34 | (: add-spaces (NestofChunks * -> Chunk)) 35 | (define (add-spaces . chunks) 36 | (apply between space chunks)) 37 | (: stmt (NestofChunks * -> Chunk)) 38 | (define (stmt . chunks) 39 | (concat (add-spaces chunks) ";")) 40 | (: add-blank-lines (NestofChunks * -> Chunk)) 41 | (define (add-blank-lines . chunks) 42 | (apply between blank-line chunks)) 43 | (: typedef (Chunk Chunk -> Chunk)) 44 | (define (typedef first second) 45 | (typedef-smt first second)) 46 | (: stmt-typedef (Chunk Chunk -> Chunk)) 47 | (define (stmt-typedef first second) 48 | (stmt (typedef-smt first second))) 49 | (: val-call (Chunk NestofChunks * -> Chunk)) 50 | (define (val-call fcn . args) 51 | (function-call fcn args)) 52 | (: stmt-call (Chunk NestofChunks * -> Chunk)) 53 | (define (stmt-call fcn . args) 54 | (stmt (function-call fcn args))) 55 | (: val-member-call (Chunk Chunk NestofChunks * -> Chunk)) 56 | (define (val-member-call obj fcn . args) 57 | (member-function-call obj fcn args)) 58 | (: stmt-member-call (Chunk Chunk NestofChunks * -> Chunk)) 59 | (define (stmt-member-call obj fcn . args) 60 | (stmt (member-function-call obj fcn args))) 61 | (define def-function function-define) 62 | (define def-void-function void-function-define) 63 | (define def-returning-function returning-function-define) 64 | (define dcl-function function-declare) 65 | (define dcl-no-inline-function general-function-declare) 66 | (define dcl-static-function static-function-declare) 67 | (define def-template template-define) 68 | (define dcl-struct struct-declare) 69 | (define def-struct struct-define) 70 | (define dcl-template-struct template-struct-declare) 71 | (: stmt-dcl-template-struct (Chunk NestofChunks NestofChunks * -> Chunk)) 72 | (define (stmt-dcl-template-struct name params . args) 73 | (stmt (apply dcl-template-struct name params args))) 74 | (define def-template-struct template-struct-define) 75 | (: stmt-def-template-struct (Chunk NestofChunks NestofChunks NestofChunks * -> Chunk)) 76 | (define (stmt-def-template-struct name params args . body) 77 | (stmt (apply def-template-struct name params args body))) 78 | (: stmt-def-struct (Chunk NestofChunks * -> Chunk)) 79 | (define (stmt-def-struct name . body) 80 | (stmt (def-struct (dcl-struct name) body))) 81 | (define type-template template-use) 82 | (: typename (Chunk -> Chunk)) 83 | (define (typename pmtr) 84 | (add-spaces 'typename pmtr)) 85 | (: type-template-function (NestofChunks NestofChunks * -> Chunk)) 86 | (define (type-template-function name . pmtrs) 87 | (add-spaces 'template (apply type-template name pmtrs))) 88 | (define section-public public-section) 89 | (define section-private private-section) 90 | (define val-construct constructor-assignment) 91 | (define scope scope-resolution-operator) 92 | (: enum (NestofChunks * -> Chunk)) 93 | (define (enum . enums) 94 | (stmt 'enum (body-list "," enums))) 95 | (: pp-cond-or (Chunk Chunk (U Chunk False) -> Chunk)) 96 | (define (pp-cond-or name then else) 97 | (pp-conditional-ifdef name 98 | (concat then) 99 | (if (not else) 100 | #false 101 | (concat else)))) 102 | (: pp-threads-or (Chunk (U Chunk False) -> Chunk)) 103 | (define (pp-threads-or then else) 104 | (pp-cond-or 'FIELD_EXPRESSION_THREADS then else)) 105 | (: pp-threads-only (Chunk -> Chunk)) 106 | (define (pp-threads-only chunk) 107 | (pp-threads-or chunk #false)) 108 | (: pp-gpu-or (Chunk (U Chunk False) -> Chunk)) 109 | (define (pp-gpu-or then else) 110 | (pp-cond-or '__CUDACC__ then else)) 111 | (: pp-gpu-only (Chunk -> Chunk)) 112 | (define (pp-gpu-only chunk) 113 | (pp-gpu-or chunk #false)) 114 | (: pp-gpu-test-or (Chunk (U Chunk False) -> Chunk)) 115 | (define (pp-gpu-test-or then else) 116 | (pp-cond-or 'NEBO_GPU_TEST then else)) 117 | (: pp-gpu-test-only (Chunk -> Chunk)) 118 | (define (pp-gpu-test-only chunk) 119 | (pp-gpu-test-or chunk #false)) 120 | (: report-backend-or (Chunk (U Chunk False) -> Chunk)) 121 | (define (report-backend-or then else) 122 | (pp-cond-or 'NEBO_REPORT_BACKEND then else)) 123 | (: report-backend-only (Chunk -> Chunk)) 124 | (define (report-backend-only chunk) 125 | (report-backend-or chunk #false)) 126 | (: kernel-call (Chunk NestofChunks * -> Chunk)) 127 | (define (kernel-call name . args) 128 | (concat name (if-empty args empty (apply arg-list sur-anbr "," args)))) 129 | (: device-only (NestofChunks * -> Chunk)) 130 | (define (device-only . chunks) 131 | (add-spaces '__device__ chunks)) 132 | (: host-device (NestofChunks * -> Chunk)) 133 | (define (host-device . chunks) 134 | (add-spaces (pp-gpu-only (add-spaces '__host__ '__device__)) 135 | chunks)) 136 | (: global-only (NestofChunks * -> Chunk)) 137 | (define (global-only . chunks) 138 | (add-spaces '__global__ chunks)) 139 | (: report-backend-cout (Chunk Chunk -> Chunk)) 140 | (define (report-backend-cout type backend-name) 141 | (report-backend-only (add-spaces (scope 'std 'cout) 142 | '<< 143 | (surround "\"" (add-spaces type 'Nebo backend-name)) 144 | '<< 145 | (scope 'std 'endl)))) 146 | (: report-backend-start (Chunk -> Chunk)) 147 | (define (report-backend-start backend-name) 148 | (report-backend-cout 'Starting backend-name)) 149 | (: report-backend-finish (Chunk -> Chunk)) 150 | (define (report-backend-finish backend-name) 151 | (report-backend-cout 'Finished backend-name)) 152 | (: pp-debug-only (NestofChunks * -> Chunk)) 153 | (define (pp-debug-only . chunks) 154 | (pp-conditional-ifndef 'NDEBUG 155 | (apply concat chunks) 156 | #false)) 157 | (: paren (NestofChunks * -> Chunk)) 158 | (define (paren . chunks) 159 | (sur-paren (position-indent (apply add-spaces chunks)))) 160 | (: ter-cond (Chunk Chunk Chunk -> Chunk)) 161 | (define (ter-cond if then else) 162 | (paren if '? then ': else)) 163 | (: val-assign (Chunk NestofChunks * -> Chunk)) 164 | (define (val-assign lhs . rhs) 165 | (add-spaces lhs '= rhs)) 166 | (: stmt-assign (Chunk NestofChunks * -> Chunk)) 167 | (define (stmt-assign lhs . rhs) 168 | (stmt (apply val-assign lhs rhs))) 169 | (: val-typed-assign (Chunk Chunk NestofChunks * -> Chunk)) 170 | (define (val-typed-assign type lhs . rhs) 171 | (apply val-assign (add-spaces type lhs) rhs)) 172 | (: stmt-typed-assign (Chunk Chunk NestofChunks * -> Chunk)) 173 | (define (stmt-typed-assign type lhs . rhs) 174 | (stmt (apply val-typed-assign type lhs rhs))) 175 | (: val-typed-const-assign (Chunk Chunk NestofChunks * -> Chunk)) 176 | (define (val-typed-const-assign type lhs . rhs) 177 | (apply val-typed-assign (add-spaces 'const type) lhs rhs)) 178 | (: val-equal (Chunk NestofChunks * -> Chunk)) 179 | (define (val-equal lhs . rhs) 180 | (add-spaces lhs '== rhs)) 181 | (: val-not-equal (Chunk NestofChunks * -> Chunk)) 182 | (define (val-not-equal lhs . rhs) 183 | (add-spaces lhs '!= rhs)) 184 | (: val-less-than (Chunk NestofChunks * -> Chunk)) 185 | (define (val-less-than lhs . rhs) 186 | (add-spaces lhs '< rhs)) 187 | (: val-greater-than (Chunk NestofChunks * -> Chunk)) 188 | (define (val-greater-than lhs . rhs) 189 | (add-spaces lhs '> rhs)) 190 | (: val-lesser-equal (Chunk NestofChunks * -> Chunk)) 191 | (define (val-lesser-equal lhs . rhs) 192 | (add-spaces lhs '<= rhs)) 193 | (: val-greater-equal (Chunk NestofChunks * -> Chunk)) 194 | (define (val-greater-equal lhs . rhs) 195 | (add-spaces lhs '>= rhs)) 196 | (: val-add (Chunk NestofChunks * -> Chunk)) 197 | (define (val-add lhs . rhs) 198 | (add-spaces lhs '+ rhs)) 199 | (: val-subtract (Chunk NestofChunks * -> Chunk)) 200 | (define (val-subtract lhs . rhs) 201 | (add-spaces lhs '- rhs)) 202 | (: val-multiply (Chunk NestofChunks * -> Chunk)) 203 | (define (val-multiply lhs . rhs) 204 | (add-spaces lhs '* rhs)) 205 | (: val-divide (Chunk NestofChunks * -> Chunk)) 206 | (define (val-divide lhs . rhs) 207 | (add-spaces lhs '/ rhs)) 208 | (: val-modulo (Chunk NestofChunks * -> Chunk)) 209 | (define (val-modulo lhs . rhs) 210 | (add-spaces lhs '% rhs)) 211 | (: val-increment (Chunk -> Chunk)) 212 | (define (val-increment chunk) 213 | (concat chunk '++)) 214 | (: val-and (Chunk NestofChunks * -> Chunk)) 215 | (define (val-and lhs . rhs) 216 | (between (spaces-around '&&) lhs rhs)) 217 | (: val-or (Chunk NestofChunks * -> Chunk)) 218 | (define (val-or lhs . rhs) 219 | (between (spaces-around "||") lhs rhs)) 220 | (: val-not (Chunk -> Chunk)) 221 | (define (val-not chunk) 222 | (concat '! (paren chunk))) 223 | (: val-negate (Chunk -> Chunk)) 224 | (define (val-negate chunk) 225 | (concat '- (paren chunk))) 226 | (: const (NestofChunks * -> Chunk)) 227 | (define (const . chunks) 228 | (add-spaces chunks 'const)) 229 | (: ref (NestofChunks * -> Chunk)) 230 | (define (ref . chunks) 231 | (add-spaces chunks '&)) 232 | (: ptr (NestofChunks * -> Chunk)) 233 | (define (ptr . chunks) 234 | (add-spaces chunks '*)) 235 | (: function-pmtr (Chunk Chunk -> Chunk)) 236 | (define (function-pmtr type arg) 237 | (add-spaces type arg)) 238 | (: dcl-variable (Chunk Chunk -> Chunk)) 239 | (define (dcl-variable type arg) 240 | (add-spaces type arg)) 241 | (: stmt-dcl-variable (Chunk Chunk -> Chunk)) 242 | (define (stmt-dcl-variable type arg) 243 | (stmt (function-pmtr type arg))) 244 | (: take-ptr (NestofChunks * -> Chunk)) 245 | (define (take-ptr . chunks) 246 | (concat '& chunks)) 247 | (: stmt-if (Chunk NestofChunks * -> Chunk)) 248 | (define (stmt-if check . then) 249 | (add-spaces (val-call 'if check) 250 | (body then))) 251 | (: stmt-if-else (Chunk Chunk Chunk -> Chunk)) 252 | (define (stmt-if-else check then else) 253 | (between new-line 254 | (stmt-if check then) 255 | (add-spaces 'else (body else)))) 256 | (: stmt-for (Chunk Chunk Chunk NestofChunks * -> Chunk)) 257 | (define (stmt-for init check next . smts) 258 | (add-spaces (val-call 'for (add-spaces (stmt init) 259 | (stmt check) 260 | next)) 261 | (body smts))) 262 | -------------------------------------------------------------------------------- /standard-chunk.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (require "private/core-chunk.rkt" 4 | "private/doc/document.rkt") 5 | 6 | ; from core-chunk 7 | (provide 8 | flatten* 9 | literal 10 | space 11 | new-line 12 | empty 13 | concat 14 | immediate 15 | speculative 16 | position-indent 17 | indent 18 | comment-env-chunk) 19 | 20 | (provide 21 | (all-defined-out)) 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;; 24 | ;basic chunks;;;;;;;;; 25 | ;;;;;;;;;;;;;;;;;;;;;; 26 | 27 | (document empty*? 28 | "Mostly a helper for other standard chunks. Takes anything as its input. If the 29 | input is an empty list or a list of nested lists that are all empty, returns #t. 30 | For ANY OTHER INPUT, returns #f.") 31 | (: empty*? (Any -> Boolean)) 32 | (define (empty*? lst) 33 | (match lst 34 | ['() #t] 35 | [(list xs ...) (for/and: : Boolean ([x xs]) (empty*? x))] 36 | [_ #f])) 37 | 38 | (document if-empty 39 | "Macro of the form: (if-empty given then else)" 40 | "Returns then, if given is null (or a list that flattens to null). 41 | Returns else, otherwise.") 42 | (define-syntax if-empty 43 | (syntax-rules () 44 | [(if-empty given then else) 45 | (if (empty*? given) 46 | then 47 | else)])) 48 | 49 | (document surround 50 | "Surrounds the second given chunk with copies of the first. 51 | Useful if you need to make sure the President is always guarded by the Secret 52 | Service:" 53 | "(surround \"SS\" \"president\") => \"SSpresidentSS\"") 54 | (: surround (Chunk Chunk -> Chunk)) 55 | (define (surround surround chunk) 56 | (concat surround chunk surround)) 57 | 58 | (document blank-lines 59 | "Adds n blank lines." 60 | "Actually, you'll notice that this function accepts any number of integers. 61 | If you provide more than one, the numbers will be added together to produce 62 | the number of blank lines that will be emitted. This might be useful if, for 63 | example, you know you want 2 blank lines, then n more.") 64 | (: blank-lines (Integer * -> Chunk)) 65 | (define (blank-lines . lengths) 66 | (concat (ann (make-list (apply + (cons 1 lengths)) 67 | new-line) (Listof Chunk)))) 68 | 69 | (document blank-line 70 | "Adds one blank line") 71 | (define blank-line (blank-lines 1)) 72 | 73 | (document sur-paren 74 | "Surround a chunk in parenthesis. No, really! See:" 75 | "(sur-paren \"chunk\") => \"(chunk)\"" 76 | "It even works with multiple chunks:" 77 | "(sur-paren \"A\" \"chunk\") => \"(Achunk)\"") 78 | (: sur-paren (Chunk * -> Chunk)) 79 | (define (sur-paren . chunks) 80 | (concat (immediate "(") 81 | chunks 82 | (immediate ")"))) 83 | 84 | (document sur-crbr 85 | "Surround a chunk in curly brackets. Same as sur-paren, but with these: {}") 86 | (: sur-crbr (Chunk * -> Chunk)) 87 | (define (sur-crbr . chunks) 88 | (concat (immediate "{") 89 | chunks 90 | (immediate "}"))) 91 | 92 | (document sur-anbr 93 | "Surround a chunk in angle brackets. Same as sur-paren, but with these: <>" 94 | "If you need to surround a template list in pointy brackets, use 95 | sur-anbr-template instead.") 96 | (: sur-anbr (Chunk * -> Chunk)) 97 | (define (sur-anbr . chunks) 98 | (concat (immediate "<") 99 | chunks 100 | (immediate ">"))) 101 | 102 | (document sur-anbr-template 103 | "Surround a chunk in angle brackets, carefully avoiding C++ parser problems." 104 | "This function is designed to avoid producing a \">>\" at the end of the list. 105 | Since the predominant use of an anble bracketed list in C++ is for templates, 106 | and foo> is a compiler error, this function works hard to produce 107 | foo > instead. If this is not what you need, consider using sur-anbr 108 | instead.") 109 | (: sur-anbr-template (Chunk * -> Chunk)) 110 | (define (sur-anbr-template . chunks) 111 | (speculative (concat (immediate "<") 112 | chunks 113 | (immediate ">")) 114 | not-ends-in->> 115 | (concat (immediate "<") 116 | chunks 117 | space 118 | (immediate ">")))) 119 | 120 | (document sur-sqbr 121 | "Surround a chunk in square brackets. Same as sur-paren, but with these: []") 122 | (: sur-sqbr (Chunk * -> Chunk)) 123 | (define (sur-sqbr . chunks) 124 | (concat (immediate "[") 125 | chunks 126 | (immediate "]"))) 127 | 128 | ;;;;;;;;;;;;;;;;;;;;;; 129 | ;list chunks;;;;;;;;;; 130 | ;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | (document attach-list-separator 133 | "Takes a list separator chunk, and a list of chunks. Takes each chunk in the 134 | list except the last and appends a copy of the separator chunk to it. The 135 | result is a list of chunks with list separators. Before you consider using this 136 | function directly, be sure you wouldn't rather use between/attach." 137 | "(attach-list-separator \", \" `(a b c d e)) => \"a, b, c, d, e\"" 138 | "You can also give this function its list as a rest argument. It will take any 139 | arguments after the first to be chunks that need separators:" 140 | "(attach-list-separator \", \" `a 'b 'c 'd 'e) => \"a, b, c, d, e\"" 141 | "Note: This function flattens. So (attach-list-separator 'x '(a b) 'c 'd) will 142 | give \"axbxcxd\", NOT \"abxcxd\".") 143 | (: attach-list-separator (Chunk NestofChunks * -> (Listof Chunk))) 144 | (define (attach-list-separator to-attach . chunk-lists) 145 | (define chunks (flatten* chunk-lists)) 146 | (define lmap (inst map Chunk Chunk)) 147 | (if-empty chunks 148 | null 149 | (flatten* (lmap (λ: ([chunk : Chunk]) (concat chunk (immediate to-attach))) 150 | (take chunks (- (length chunks) 1))) (last chunks)))) 151 | 152 | (document between 153 | "Takes an add-between chunk, and a list of chunks. Concatenates given chunks 154 | with add-between between each of the given chunks. Operates similarly to 155 | attach-list-separator, but does not assume you want to keep the add-between 156 | chunk paired with the preceding list chunk.") 157 | (: between (Chunk NestofChunks * -> Chunk)) 158 | (define (between add-between-chunk . chunks) 159 | (define ladd-between (inst add-between Chunk Chunk)) 160 | (concat (ladd-between (flatten* chunks) add-between-chunk))) 161 | 162 | (document between/attach 163 | "Combines between and attach functionality to give a convenient way of making 164 | multi-line lists or function bodies in an intelligent way. Takes a to-attach 165 | chunk, an add-between chunk, and then a list of chunks to build into the list. 166 | It then attaches the to-attach chunk to each chunk in the list using 167 | attach-list-separator. Finally, it uses the between function to insert the 168 | add-between chunk after each to-attach." 169 | "This function will work hard to do the Right Thing™ with lists or function 170 | bodies. It tries, for example, to keep commas on the same line as the preceding 171 | list element." 172 | "Assuming line-length was parameterized to a value of 10:" 173 | "(between/attach \",\" space (range 8))" 174 | "=>" 175 | "\"0, 1, 2, 3,\"" 176 | "\"4, 5, 6, 7\"") 177 | (: between/attach (Chunk Chunk NestofChunks * -> Chunk)) 178 | (define (between/attach to-attach add-between . chunks) 179 | (apply between add-between (apply attach-list-separator to-attach chunks))) 180 | 181 | (document arg-list 182 | "Argument list chunk" 183 | "Attempts to put chunks on a single line with a space between each chunk. 184 | If that fails, puts chunks on their own lines. Commonly useful for lists and 185 | arguments to functions. Handier than rolling something for this purpose by 186 | hand.") 187 | (: arg-list ((Chunk -> Chunk) Chunk NestofChunks * -> Chunk)) 188 | (define (arg-list sur attach . chunks) 189 | (: build (Chunk -> Chunk)) 190 | (define (build spacing) 191 | (apply between/attach attach spacing chunks)) 192 | (sur (if-empty chunks 193 | empty 194 | (speculative (build space) 195 | length-equals-one 196 | (position-indent (build new-line)))))) 197 | 198 | (document paren-list 199 | "Parenthesis argument list chunk" 200 | "Takes any list of chunks, separates them with commas, and surrounds the whole 201 | list with parenthesis.") 202 | (: paren-list (NestofChunks * -> Chunk)) 203 | (define (paren-list . chunks) 204 | (apply arg-list sur-paren "," chunks)) 205 | 206 | (document template-list 207 | "Template argument list chunk" 208 | "Takes any list of chunks, separates them with commas, and surrounds the whole 209 | list with angle brackets.") 210 | (: template-list (NestofChunks * -> Chunk)) 211 | (define (template-list . chunks) 212 | (apply arg-list sur-anbr-template "," chunks)) 213 | 214 | (document body-list 215 | "Takes a separator chunk and a list of chunks, separates the chunks with the 216 | separator, and surrounds the whole thing with curly braces.") 217 | (: body-list (Chunk NestofChunks * -> Chunk)) 218 | (define (body-list attach . chunks) 219 | (apply arg-list sur-crbr attach chunks)) 220 | 221 | (document top-list 222 | "Takes any number of chunks as arguments and inserts a blank line between each.") 223 | (: top-list (NestofChunks * -> Chunk)) 224 | (define (top-list . chunks) 225 | (apply between blank-line chunks)) 226 | 227 | (document internal-smt-list 228 | "List of statement chunks without final semi-colon." 229 | "Takes a spacing chunk and any number of chunks, adds spacing between each chunk 230 | and attaches a semi-colon to the end of each chunk (except the last)." 231 | "(internal-smt-list space 'a 'b 'c) => \"a; b; c\"") 232 | (: internal-smt-list (Chunk NestofChunks * -> Chunk)) 233 | (define (internal-smt-list spacing . chunks) 234 | (apply between/attach ";" spacing chunks)) 235 | 236 | (document smt-list 237 | "Takes a spacing chunk and any number of chunks, adds spacing added between each 238 | chunk and attaches a semi-colon to the end of each chunk." 239 | "(smt-list space 'a 'b 'c) => \"a; b; c;\"") 240 | (: smt-list (Chunk NestofChunks * -> Chunk)) 241 | (define (smt-list spacing . chunks) 242 | (if-empty chunks 243 | empty 244 | (concat (apply internal-smt-list spacing chunks) 245 | (immediate ";")))) 246 | 247 | (document constructor-assignment-list 248 | "Constructor assignment list chunk" 249 | "Creates an initializer list for a class constructor." 250 | "Each assignment is separated by a comma - first line is indented 2 spaces and 251 | begun with a colon." 252 | "(constructor-assignment-list \"a(other.a)\" \"b(other.b)\" \"c(other.c)\" => \" : a(other.a), b(other.b), c(other.c)\"" 253 | "(constructor-assignment-list (constructor-assignment 'a 'other.a)) => \" : a(other.a)\"") 254 | (: constructor-assignment-list (NestofChunks * -> Chunk)) 255 | (define (constructor-assignment-list . chunks) 256 | (: build (Chunk -> Chunk)) 257 | (define (build spacing) 258 | (indent 2 (concat ":" 259 | (immediate space) 260 | (position-indent (apply between/attach "," spacing chunks))))) 261 | (if-empty chunks 262 | empty 263 | (speculative (build space) 264 | length-equals-one 265 | (build new-line)))) 266 | 267 | (document general-body 268 | "General body chunk" 269 | "Takes a boolean (use-semi-colons) and any number of chunks." 270 | "Surrounds chunks with curly brackets" 271 | "- adds a semi-colon after each chunk, if use-semi-colons is true" 272 | "- attempts to put chunks on a single line with a space between each chunk" 273 | "- if that fails, puts chunks on their own lines with indented" 274 | "This version places the open curly bracket immediately on current line and the 275 | close curly bracket on its own line. This roughly corresponds to Java or 276 | Google style, with attached brackets. The indent level is 3 spaces. This is not 277 | currently user-configurable.") 278 | (: general-body (Boolean NestofChunks * -> Chunk)) 279 | (define (general-body use-semi-colons . chunks) 280 | (: build (Chunk Chunk -> Chunk)) 281 | (define (build start/end-spacing spacing) 282 | (surround start/end-spacing 283 | (if use-semi-colons 284 | (apply smt-list spacing chunks) 285 | (apply between spacing chunks)))) 286 | (sur-crbr (if-empty chunks 287 | empty 288 | (if (= 1 (length chunks)) 289 | (speculative 290 | (build space space) 291 | length-equals-one 292 | (indent 3 (build new-line blank-line))) 293 | (indent 3 (build new-line blank-line)))))) 294 | 295 | (document body 296 | "Body with semicolons" 297 | "Basically a shortcut for (general-body #true ...)" 298 | "Surrounds chunks with curly brackets" 299 | "- adds a semi-colon after each chunk" 300 | "- attempts to put chunks on a single line with a space between each chunk" 301 | "- if that fails, puts chunks on their own lines with indented" 302 | "Style is the same as with general-body above.") 303 | (: body (NestofChunks * -> Chunk)) 304 | (define (body . chunks) 305 | (apply general-body #true chunks)) 306 | 307 | (document class-body 308 | "Body without semicolons" 309 | "Basically a shortcut for (general-body #false ...)" 310 | "Surrounds chunks with curly brackets" 311 | "- does NOT add semi-colons after each chunk" 312 | "- attempts to put chunks on a single line with a space between each chunk" 313 | "- if that fails, puts chunks on their own lines with indented" 314 | "Style is the same as with general-body above.") 315 | (: class-body (NestofChunks * -> Chunk)) 316 | (define (class-body . chunks) 317 | (apply general-body #false chunks)) 318 | 319 | ;;;;;;;;;;;;;;;;;;;;;; 320 | ;preprocessor chunks;; 321 | ;;;;;;;;;;;;;;;;;;;;;; 322 | 323 | (document pp-define 324 | "Preprocessor define chunk" 325 | "Accepts one argument, a name. Produces:" 326 | "#define ") 327 | (: pp-define (Chunk -> Chunk)) 328 | (define (pp-define name) 329 | (concat pp-directive 'define space name)) 330 | 331 | (document pp-include 332 | "Preprocessor include chunk" 333 | "Accepts one argument, a header filename. Produces:" 334 | "#include <>" 335 | "Where the outer pointy brackets are literal.") 336 | (: pp-include (Chunk -> Chunk)) 337 | (define (pp-include included) 338 | (concat pp-directive 'include space (template-list included))) 339 | 340 | (document pp-alt-include 341 | "Alternate preprocessor include chunk" 342 | "Accepts one argument, a header filename. Produces:" 343 | "#include \"\"") 344 | (: pp-alt-include (Chunk -> Chunk)) 345 | (define (pp-alt-include included) 346 | (concat pp-directive 'include space "\"" included "\"")) 347 | 348 | (document pp-includes 349 | "Multiple includes" 350 | "Accepts any number of arguments and produces an include directive for each.") 351 | (: pp-includes (Chunk * -> Chunk)) 352 | (define (pp-includes . chunks) 353 | (apply between new-line (map pp-include (flatten* chunks)))) 354 | 355 | (document pp-ifdef 356 | "Preprocessor if-defined chunk" 357 | "Accepts one argument, a preprocessor ifdef condition, and makes an ifdef line.") 358 | (: pp-ifdef (Chunk -> Chunk)) 359 | (define (pp-ifdef condition) 360 | (concat pp-directive 'ifdef space condition)) 361 | 362 | (document pp-ifndef 363 | "Preprocessor if-not-defined chunk" 364 | "Makes an ifndef preprocessor directive.") 365 | (: pp-ifndef (Chunk -> Chunk)) 366 | (define (pp-ifndef condition) 367 | (concat pp-directive 'ifndef space condition)) 368 | 369 | (document pp-else 370 | "Preprocessor else chunk" 371 | "Makes an else preprocessor directive. Constant value, should not be called.") 372 | (define pp-else (concat pp-directive 'else)) 373 | 374 | (document pp-endif 375 | "Preprocessor endif chunk" 376 | "Makes an endif preprocessor directive. The argument will end up in a comment 377 | on the same line as the endif, and can be used to specify what condition is 378 | being endifed.") 379 | (: pp-endif (Chunk -> Chunk)) 380 | (define (pp-endif condition) 381 | (concat pp-directive 'endif new-line (comment-env-chunk condition))) 382 | 383 | (document pp-conditional 384 | "Preprocessor conditional chunk" 385 | "General preprocessor conditional block in a single handy package. Accepts 3 386 | required arguments and one optional argument: directive, condition, then, else." 387 | "directive - the preprocessor command that comes right after the #." 388 | "condition - argument to the directive, following on the same line." 389 | "then - Chunk of code to be placed before the endif." 390 | "else - if present, chunk of code to go after an else, between then and endif." 391 | "Example: (pp-conditional 'ifdef ARM64 \"do_arm64();\" \"reticulate_splines();\")") 392 | (: pp-conditional (case-> 393 | [Chunk Chunk Chunk -> Chunk] 394 | [Chunk Chunk Chunk (U Chunk False) -> Chunk])) 395 | (define (pp-conditional directive condition then [else #false]) 396 | (concat pp-directive 397 | directive 398 | space 399 | condition 400 | new-line 401 | (indent 3 then) 402 | new-line 403 | (if else 404 | (concat pp-else 405 | new-line 406 | (indent 3 else) 407 | new-line) 408 | empty) 409 | (pp-endif condition))) 410 | 411 | (document pp-conditional-ifdef 412 | "Preprocessor conditional ifdef chunk" 413 | "Basically a shortcut for (pp-conditional 'ifdef ...)" 414 | "Makes a preprocessor ifdef line with then and optional else bodies. Its 2 415 | required arguments are the name of the define to check, and the 'then' body. 416 | The optional argument is an 'else' body.") 417 | (: pp-conditional-ifdef (case-> 418 | [Chunk Chunk -> Chunk] 419 | [Chunk Chunk (U False Chunk) -> Chunk])) 420 | (define (pp-conditional-ifdef condition then [else #false]) 421 | (pp-conditional 'ifdef condition then else)) 422 | 423 | (document pp-conditional-ifndef 424 | "Preprocessor conditional ifndef chunk" 425 | "Basically a shortcut for (pp-conditional 'ifndef ...)" 426 | "Makes a preprocessor ifndef line with then and optional else bodies. Its 2 427 | required arguments are the name of the define to check, and the 'then' body. 428 | The optional argument is an 'else' body.") 429 | (: pp-conditional-ifndef (case-> 430 | [Chunk Chunk -> Chunk] 431 | [Chunk Chunk (U False Chunk) -> Chunk])) 432 | (define (pp-conditional-ifndef condition then [else #false]) 433 | (pp-conditional 'ifndef condition then else)) 434 | 435 | (document pp-header-file 436 | "Preprocessor include guard / header file wrapper chunk" 437 | "This is a pretty standard #include guard. Takes at least 1 argument: a name to 438 | define (usually something like 'MY_HEADER_H). Further arguments will become the 439 | body of the header file." 440 | "Example:" 441 | "(pp-header-file 'FOO_STRUCT_H \"struct foo { int member; };\")" 442 | "Produces:" 443 | "#ifndef FOO_STRUCT_H" 444 | "#define FOO_STRUCT_H" 445 | " struct foo { int member; };" 446 | "#endif" 447 | "/* FOO_STRUCT_H */") 448 | (: pp-header-file (Chunk NestofChunks * -> Chunk)) 449 | (define (pp-header-file file-name . chunks) 450 | (pp-conditional-ifndef file-name 451 | (concat (pp-define file-name) 452 | blank-line 453 | (apply top-list chunks) 454 | new-line))) 455 | 456 | (document macro-define 457 | "Macro defintion chunk" 458 | "General macro definition. Accepts at least one argument. The first will be the 459 | name of the macro. Following arguments will become the definition of the macro. 460 | Be careful, as it's quite easy to create invalid code if your definition 461 | contains newlines.") 462 | (: macro-define (Chunk NestofChunks Chunk -> Chunk)) 463 | (define (macro-define name params chunk) 464 | (immediate (concat (pp-define name) space chunk))) 465 | 466 | ;;;;;;;;;;;;;;;;;;;;;; 467 | ;general chunks;;;;;;; 468 | ;;;;;;;;;;;;;;;;;;;;;; 469 | 470 | (document namespace-define 471 | "Declare a namespace for a block of code." 472 | "Accepts a name and any number of further arguments. The name goes after the 473 | namespace keyword, and the remaining arguments get put into a body which goes 474 | in the namespace block. After the code block, a comment containing the name is 475 | added to clarify what is being ended. Example:" 476 | "(namespace-define 'foo \"bar()\") =>" 477 | "namespace foo { bar(); } /* foo */") 478 | (: namespace-define (Chunk NestofChunks * -> Chunk)) 479 | (define (namespace-define name . chunks) 480 | (define chunk (concat 'namespace 481 | (immediate space) 482 | (immediate name) 483 | (immediate space) 484 | (apply body chunks))) 485 | 486 | (concat chunk space (comment-env-chunk name))) 487 | 488 | (document described-smts 489 | "Described statements chunk" 490 | "Accepts a comment and any number of other chunks. Puts the comment into a 491 | comment environment (surrounds it with /* */) and then places the remaining 492 | arguments normally, after a newline. Example:" 493 | "(described-smts \"Automatically synchronize cardinal grammaters\" \"encabulate();\") =>" 494 | "/* Automatically synchronize cardinal grammaters */" 495 | "encabulate();") 496 | (: described-smts (Chunk NestofChunks * -> Chunk)) 497 | (define (described-smts comment . chunks) 498 | (concat (comment-env-chunk comment) 499 | new-line 500 | (apply between/attach ";" new-line chunks))) 501 | 502 | (document constize 503 | "Make constant" 504 | "To be used with types or identifiers. Takes a type, identifier, or any chunk, 505 | and appends const to the end of it." 506 | "(constize \"int a\") =>" 507 | "int a const") 508 | (: constize (Chunk -> Chunk)) 509 | (define (constize chunk) 510 | (concat chunk 511 | (immediate space) 512 | (immediate 'const))) 513 | 514 | ;;;;;;;;;;;;;;;;;;;;;; 515 | ;template chunks;;;;;; 516 | ;;;;;;;;;;;;;;;;;;;;;; 517 | 518 | (document template-define 519 | "Make a template with given template parameters" 520 | "Takes two arguments: a list of parameters, and a name. Produces a template 521 | declaration (sans the final semicolon)." 522 | "Example:" 523 | "(template-define '(p1 p2 p3) 'MyTemplate) =>" 524 | "template" 525 | "MyTemplate") 526 | (: template-define (NestofChunks Chunk -> Chunk)) 527 | (define (template-define params chunk) 528 | (concat 'template 529 | (template-list params) 530 | new-line 531 | (indent 1 chunk))) 532 | 533 | (document template-use 534 | "Make use of a template" 535 | "Takes a name and any number of template arguments. Produces a reference to the 536 | given template with the given arguments. If only a name is given, no pointy 537 | brackets are produced." 538 | "Example:" 539 | "(template-use 'foo 'bar 'baaz) =>" 540 | "foo") 541 | (: template-use (NestofChunks NestofChunks * -> Chunk)) 542 | (define (template-use name . args) 543 | (concat name (if-empty args empty (apply template-list args)))) 544 | 545 | ;;;;;;;;;;;;;;;;;;;;;; 546 | ;function chunks;;;;;; 547 | ;;;;;;;;;;;;;;;;;;;;;; 548 | 549 | (document general-function-declare 550 | "General function declaration" 551 | "Takes a name, a return type, and any number of additional arguments." 552 | "Example:" 553 | "(general-function-declare 'foo 'bar \"int baaz\" \"float quux\") =>" 554 | "bar foo(int baaz, float quux)") 555 | (: general-function-declare (Chunk Chunk NestofChunks * -> Chunk)) 556 | (define (general-function-declare name return-type . params) 557 | (concat return-type space name (apply paren-list (if-empty params 558 | '(void) 559 | params)))) 560 | 561 | (document function-declare 562 | "Declares an inline function" 563 | "This is exactly the same as general-function-declare except it makes the 564 | declared function inline." 565 | "Example:" 566 | "(function-declare 'foo 'bar \"int baaz\" \"float quux\") =>" 567 | "inline bar foo(int baaz, float quux)") 568 | (: function-declare (Chunk Chunk NestofChunks * -> Chunk)) 569 | (define (function-declare name return-type . params) 570 | (concat 'inline space (apply general-function-declare name return-type params))) 571 | 572 | (document static-function-declare 573 | "Exactly the same as function-declare, but additionally declares the function 574 | static." 575 | "Example:" 576 | "(static-function-declare 'foo 'bar \"int baaz\" \"float quux\") =>" 577 | "static inline bar foo(int baaz, float quux)") 578 | (: static-function-declare (Chunk Chunk NestofChunks * -> Chunk)) 579 | (define (static-function-declare name return-type . params) 580 | (concat 'static space (apply function-declare name return-type params))) 581 | 582 | (document void-function-declare 583 | "Declares an inline void function" 584 | "Example:" 585 | "(void-function-declare 'foo \"int baaz\") =>" 586 | "inline void foo(int baaz)") 587 | (: void-function-declare (Chunk NestofChunks -> Chunk)) 588 | (define (void-function-declare name params) 589 | (function-declare name 'void params)) 590 | 591 | (document function-define 592 | "Takes a function signature, and any number of other chunks. Produces a function 593 | definition consisting of the given signature, followed by a body with the 594 | given chunks.") 595 | (: function-define (Chunk NestofChunks * -> Chunk)) 596 | (define (function-define signature . chunks) 597 | (concat signature 598 | (immediate space) 599 | (apply body chunks))) 600 | 601 | (document void-function-define 602 | "Defines a void inline function. This is essentially a shortcut for using 603 | function-define with a void-function-declare.") 604 | (: void-function-define (Chunk NestofChunks NestofChunks * -> Chunk)) 605 | (define (void-function-define name params . body) 606 | (apply function-define (void-function-declare name params) 607 | body)) 608 | 609 | (document returning-function-define 610 | "Takes a signature, a body, and a return expression. Produces a function 611 | definition with the given signature and body. Appends a return statement with 612 | the given return expression to the body." 613 | "Example:" 614 | "(returning-function-define (function-declare 'id 'int \"int x\") '() 'x) =>" 615 | "inline int id(int x) { return x; }") 616 | (: returning-function-define (Chunk NestofChunks Chunk -> Chunk)) 617 | (define (returning-function-define signature body return-expr) 618 | (apply function-define signature (flatten* body (concat 'return 619 | (immediate space) 620 | (position-indent return-expr))))) 621 | 622 | (document constructor-assignment 623 | "Creates an initializer (part of an initializer list) for a constructor." 624 | "The first argument is the variable to assign or the name of the constructor to 625 | call, and successive arguments go in the parenthesis.") 626 | (: constructor-assignment (Chunk NestofChunks * -> Chunk)) 627 | (define (constructor-assignment var . val) 628 | (concat var (apply paren-list val))) 629 | 630 | (document constructor 631 | "Takes a name, a list of parameters, a list of constructor assignments, and any 632 | number of other arguments and produces a constructor for a class." 633 | "Example:" 634 | "(constructor 'foo '(\"int bar\" \"float baaz\") 635 | (list (constructor-assignment 'qux 'bar) 636 | (constructor-assignment 'quux 'bar 'baaz)) \"x = qux + quux\")" 637 | "=>" 638 | "foo(int bar, float baaz)" 639 | " : qux(bar), quux(baaz)" 640 | "{ x = qux + quux; }") 641 | (: constructor (Chunk NestofChunks NestofChunks NestofChunks * -> Chunk)) 642 | (define (constructor name params assigns . chunks) 643 | (concat name 644 | (paren-list params) 645 | (if-empty assigns 646 | (immediate space) 647 | (surround new-line (constructor-assignment-list assigns))) 648 | (apply body chunks))) 649 | 650 | ;;;;;;;;;;;;;;;;;;;;;; 651 | ;class/struct chunks;; 652 | ;;;;;;;;;;;;;;;;;;;;;; 653 | 654 | (document struct-declare 655 | "Declare a struct with the given name. This is ONLY a declaration, and is not 656 | intended to define the content of a struct." 657 | "Example:" 658 | "(struct-declare 'foo)" 659 | "=>" 660 | "struct foo") 661 | (: struct-declare (Chunk -> Chunk)) 662 | (define (struct-declare name) 663 | (concat 'struct space name)) 664 | 665 | (document template-struct-declare 666 | "Declares a templated struct. Useful for making generic structs or partially 667 | instantiated struct templates." 668 | "Example:" 669 | "(template-struct-declare 'a '(b c d) 'e 'f)" 670 | "=>" 671 | "template" 672 | " struct a") 673 | (: template-struct-declare (Chunk NestofChunks NestofChunks * -> Chunk)) 674 | (define (template-struct-declare name params . args) 675 | (template-define params (apply template-use (struct-declare name) 676 | args))) 677 | 678 | (document section-define 679 | "Produces a section definition, such as those used in class definitions to mark 680 | groups of variables and methods as private, public, or protected." 681 | "Example:" 682 | "(section-define 'private (smt-list new-line \"int foo\" \"float bar\"))" 683 | "=>" 684 | "private:" 685 | " int foo;" 686 | " float bar;") 687 | (: section-define (Chunk NestofChunks * -> Chunk)) 688 | (define (section-define type . chunks) 689 | (if-empty chunks 690 | empty 691 | (concat type ":" new-line (indent 1 (apply between blank-line chunks))))) 692 | 693 | (document public-section 694 | "A public section definition. The arguments are placed under a public: line." 695 | "(public-section c ...) can be thought of as a shortcut for (section-define 696 | 'public c ...)") 697 | (: public-section (NestofChunks * -> Chunk)) 698 | (define (public-section . chunks) 699 | (apply section-define 'public chunks)) 700 | 701 | (document private-section 702 | "A private section definition. The arguments are placed under a private: line." 703 | "(private-section c ...) can be thought of as a shortcut for (section-define 704 | 'private c ...)") 705 | (: private-section (NestofChunks * -> Chunk)) 706 | (define (private-section . chunks) 707 | (apply section-define 'private chunks)) 708 | 709 | (document protected-section 710 | "A protected section definition. The arguments are placed under a protected: line." 711 | "(protected-section c ...) can be thought of as a shortcut for (section-define 712 | 'protected c ...)") 713 | (: protected-section (NestofChunks * -> Chunk)) 714 | (define (protected-section . chunks) 715 | (apply section-define 'protected chunks)) 716 | 717 | (document struct-define 718 | "Takes a signature (which can come from struct-declare or 719 | template-struct-declare) and any number of other chunks, and produces a struct 720 | definition. The signature will become the type signature of the struct, while 721 | the remaining arguments will become the body of the struct." 722 | "Example:" 723 | "(struct-define (struct-declare 'foo) \"int a;\" \"float b;\")" 724 | "struct foo {" 725 | " int a;" 726 | " float b;" 727 | "}") 728 | (: struct-define (Chunk NestofChunks * -> Chunk)) 729 | (define (struct-define signature . body) 730 | (concat signature 731 | (immediate space) 732 | (apply class-body body))) 733 | 734 | ;template struct definition 735 | (: template-struct-define (Chunk NestofChunks NestofChunks NestofChunks * -> Chunk)) 736 | (define (template-struct-define name params args . body) 737 | (apply struct-define (template-struct-declare name params args) 738 | body)) 739 | 740 | (document scope-resolution-operator 741 | "Takes a scope and an identifier and produces a chunk that will reference that 742 | identifier in the context of that given scope." 743 | "Example:" 744 | "(scope-resolution-operator 'std 'endl)" 745 | "=>" 746 | "std::endl") 747 | (: scope-resolution-operator (Chunk Chunk -> Chunk)) 748 | (define (scope-resolution-operator scope variable) 749 | (concat scope 750 | (immediate ":") 751 | (immediate ":") 752 | variable)) 753 | 754 | ;;;;;;;;;;;;;;;;;;;;;; 755 | ;statement chunks;;;;; 756 | ;;;;;;;;;;;;;;;;;;;;;; 757 | 758 | (document typedef-smt 759 | "Typedef chunk. Accepts two chunks, lhs and rhs, and produces a typedef, 760 | assigning rhs to be an equivalent type to lhs." 761 | "Example:" 762 | "(typedef-smt 'FieldType 'Result)" 763 | "=>" 764 | "FieldType typedef Result") 765 | (: typedef-smt (Chunk Chunk -> Chunk)) 766 | (define (typedef-smt lhs rhs) 767 | (concat lhs space 'typedef space rhs)) 768 | 769 | (document function-call 770 | "Function call. Accepts the name of a function and any number of arguments to be 771 | passed to it and produces a function call." 772 | "Example:" 773 | "(function-call 'Ackermann 3 4)" 774 | "=>" 775 | "Ackermann(3, 4)") 776 | (: function-call (Chunk NestofChunks * -> Chunk)) 777 | (define (function-call fcn . args) 778 | (concat fcn (apply paren-list args))) 779 | 780 | (document member-function-call 781 | "Object member function call. Accepts some object, the name of a member function 782 | in its class, and any number of arguments. Produces a member function call." 783 | "Example:" 784 | "(member-function-call 'my-square 'scale 20 3)" 785 | "=>" 786 | "my-square.scale(20, 3)" 787 | "Example 2:" 788 | "(member-function-call (function-call 'getObject 6) 'id)" 789 | "=>" 790 | "getObject(6).id()") 791 | (: member-function-call (Chunk Chunk NestofChunks * -> Chunk)) 792 | (define (member-function-call obj fcn . args) 793 | (concat obj 794 | (immediate ".") 795 | (position-indent (apply function-call fcn args)))) 796 | 797 | (document array-access 798 | "Array access chunk. Accepts an array and any number of other arguments. 799 | Produces an access to the array with the given arguments." 800 | "Example:" 801 | "(array-access 'fib 5)" 802 | "=>" 803 | "fib[5]") 804 | (: array-access (Chunk Chunk * -> Chunk)) 805 | (define (array-access array . arg) 806 | (concat array (apply sur-sqbr arg))) 807 | -------------------------------------------------------------------------------- /tests/standard-chunk-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require "../private/fulmar-core.rkt") 5 | (require "../private/core-chunk.rkt") 6 | (require "../standard-chunk.rkt") 7 | 8 | ;unit tests for standard-chunk.rkt 9 | 10 | (define (write-chunk-with-length chunk length) 11 | (parameterize ([line-length length]) 12 | (write-chunk chunk))) 13 | 14 | ;basic chunks 15 | (define/provide-test-suite test-basic-chunks 16 | (test-case 17 | "Test blank-lines" 18 | (define test-context 6) 19 | (check-equal? (write-chunk-with-length (concat "1" (blank-lines 1)) 20 | test-context) 21 | '("" "" "1")) 22 | (check-equal? (write-chunk-with-length (concat "1" (blank-lines 3)) 23 | test-context) 24 | '("" "" "" "" "1"))) 25 | (test-case 26 | "Test blank-line" 27 | (define test-context 6) 28 | (check-equal? (write-chunk-with-length (concat "1" blank-line) 29 | test-context) 30 | '("" "" "1")) 31 | (check-equal? (write-chunk-with-length (concat "123" blank-line) 32 | test-context) 33 | '("" "" "123")))) 34 | 35 | ;list chunks 36 | 37 | (define/provide-test-suite test-attach-list-separator 38 | (test-case 39 | "Test attach-list-separator" 40 | (define test-context 80) 41 | (check-equal? (attach-list-separator ",") 42 | null) 43 | (check-equal? (write-chunk-with-length (concat (attach-list-separator "," 'asdf 'jkl)) 44 | test-context) 45 | '("asdf,jkl")) 46 | (check-equal? (write-chunk-with-length (concat (attach-list-separator "," 'asdf)) 47 | test-context) 48 | '("asdf")) 49 | (check-equal? (write-chunk-with-length (concat (attach-list-separator "," 'asdf 'jkl "12345")) 50 | test-context) 51 | '("asdf,jkl,12345")) 52 | (check-equal? (write-chunk-with-length (concat (attach-list-separator "," 'asdf "123" "12345" "1")) 53 | 4) 54 | '("1" "12345," "123," "asdf,")))) 55 | 56 | (define/provide-test-suite test-between 57 | (test-case 58 | "Test between" 59 | (define test-context 80) 60 | (check-equal? (write-chunk-with-length (between 1) 61 | test-context) 62 | '("")) 63 | (check-equal? (write-chunk-with-length (between space 'asdf 'jkl) 64 | test-context) 65 | '("asdf jkl")) 66 | (check-equal? (write-chunk-with-length (between 1 'asdf) 67 | test-context) 68 | '("asdf")) 69 | (check-equal? (write-chunk-with-length (between space 'asdf 'jkl "12345") 70 | test-context) 71 | '("asdf jkl 12345")) 72 | (check-equal? (write-chunk-with-length (between new-line 'asdf "123" "12345" "1") 73 | test-context) 74 | '("1" "12345" "123" "asdf")))) 75 | 76 | (define/provide-test-suite test-between/attach 77 | (test-case 78 | "Test between/attach" 79 | (define test-context 80) 80 | (check-equal? (write-chunk-with-length (between/attach "," 1) 81 | test-context) 82 | '("")) 83 | (check-equal? (write-chunk-with-length (between/attach "," space 'asdf 'jkl) 84 | test-context) 85 | '("asdf, jkl")) 86 | (check-equal? (write-chunk-with-length (between/attach "," space 'asdf) 87 | test-context) 88 | '("asdf")) 89 | (check-equal? (write-chunk-with-length (between/attach "," space 'asdf 'jkl "12345") 90 | test-context) 91 | '("asdf, jkl, 12345")) 92 | (check-equal? (write-chunk-with-length (between/attach "," space 'asdf "123" "12345" "1") 93 | test-context) 94 | '("asdf, 123, 12345, 1")) 95 | (check-equal? (write-chunk-with-length (between/attach "," new-line 'asdf "123" "12345" "1") 96 | test-context) 97 | '("1" "12345," "123," "asdf,")) 98 | (check-equal? (write-chunk-with-length (between/attach "," space 'asdf "123" "12345" "1") 99 | 4) 100 | '("1" "12345," "123," "asdf,")))) 101 | 102 | (define/provide-test-suite test-arg-list 103 | (test-case 104 | "Test arg-list" 105 | (define test-context 6) 106 | (define test-context-2 80) 107 | (check-equal? (write-chunk-with-length (arg-list sur-paren "," 'asdf) 108 | test-context) 109 | '("(asdf)")) 110 | (check-equal? (write-chunk-with-length (arg-list sur-paren "," (concat 'asdf 'jkl)) 111 | test-context) 112 | '(" jkl)" 113 | "(asdf")) 114 | (check-equal? (write-chunk-with-length (arg-list sur-paren "," 'asdf empty 'jkl) 115 | test-context) 116 | '(" jkl)" " ," "(asdf,")) 117 | (check-equal? (write-chunk-with-length (arg-list sur-paren "," 'asdf empty 'jkl) 118 | test-context-2) 119 | '("(asdf, , jkl)")))) 120 | 121 | (define/provide-test-suite test-paren-list 122 | (test-case 123 | "Test paren-list" 124 | (define test-context 6) 125 | (define test-context-2 80) 126 | (check-equal? (write-chunk-with-length (paren-list 'asdf empty 'jkl) 127 | test-context) 128 | '(" jkl)" " ," "(asdf,")) 129 | (check-equal? (write-chunk-with-length (paren-list 'asdf empty 'jkl) 130 | test-context-2) 131 | '("(asdf, , jkl)")))) 132 | 133 | (define/provide-test-suite test-template-list 134 | (test-case 135 | "Test template-list" 136 | (define test-context 6) 137 | (define test-context-2 80) 138 | (check-equal? (write-chunk-with-length (template-list 'asdf empty 'jkl) 139 | test-context) 140 | '(" jkl>" " ," "")))) 144 | 145 | (define/provide-test-suite test-smt-list 146 | (test-case 147 | "Test smt-list" 148 | (define test-context 80) 149 | (check-equal? (write-chunk-with-length (smt-list blank-line 'asdf space 'jkl) 150 | test-context) 151 | '("jkl;" "" " ;" "" "asdf;")) 152 | (check-equal? (write-chunk-with-length (smt-list new-line 153 | space 154 | 'asdf 155 | empty) 156 | test-context) 157 | '(";" "asdf;" " ;")))) 158 | 159 | 160 | (define/provide-test-suite test-constructor-assignment-list 161 | (test-case 162 | "Test constructor-assignment-list" 163 | (define test-context 80) 164 | (define test-context-2 6) 165 | (check-equal? (write-chunk-with-length (constructor-assignment-list) 166 | test-context) 167 | '("")) 168 | (check-equal? (write-chunk-with-length (constructor-assignment-list 'asdf) 169 | test-context) 170 | '(" : asdf")) 171 | (check-equal? (write-chunk-with-length (constructor-assignment-list 'asdf 'jkl) 172 | test-context) 173 | '(" : asdf, jkl")) 174 | (check-equal? (write-chunk-with-length (constructor-assignment-list 'asdf 'jkl) 175 | test-context-2) 176 | '(" jkl" 177 | " : asdf,")))) 178 | 179 | (define/provide-test-suite test-body 180 | (test-case 181 | "Test body" 182 | (define test-context 80) 183 | (define test-context-2 6) 184 | (check-equal? (write-chunk-with-length (body "123456") 185 | test-context-2) 186 | '("}" 187 | " 123456;" 188 | "{")) 189 | (check-equal? (write-chunk-with-length (body 'asdf space 'jkl) 190 | test-context-2) 191 | '("}" 192 | " jkl;" 193 | "" 194 | " ;" 195 | "" 196 | " asdf;" 197 | "{")))) 198 | 199 | ;preprocessor chunks 200 | 201 | (define/provide-test-suite test-pp-define 202 | (test-case 203 | "Test pp-define" 204 | (define test-context 80) 205 | (check-equal? (write-chunk-with-length (pp-define 'name) test-context) '("#define name")) 206 | (check-equal? (write-chunk-with-length (pp-define (concat 'name "2")) test-context) '("#define name2")) 207 | (check-equal? (write-chunk-with-length (concat space (pp-define 'name)) test-context) '(" #define name")) 208 | (check-equal? (write-chunk-with-length (concat "/* " (pp-define 'name)) test-context) '("/* #define name")))) 209 | 210 | (define/provide-test-suite test-pp-include 211 | (test-case 212 | "Test pp-include" 213 | (define test-context 80) 214 | (check-equal? (write-chunk-with-length (pp-include 'name) test-context) '("#include ")) 215 | (check-equal? (write-chunk-with-length (pp-include (concat 'name "2")) test-context) '("#include ")) 216 | (check-equal? (write-chunk-with-length (concat space (pp-include 'name)) test-context) '(" #include ")) 217 | (check-equal? (write-chunk-with-length (concat "/* " (pp-include 'name)) test-context) '("/* #include ")))) 218 | 219 | (define/provide-test-suite test-pp-includes 220 | (test-case 221 | "Test pp-includes" 222 | (define test-context 80) 223 | (check-equal? (write-chunk-with-length (pp-includes 'name) test-context) '("#include ")) 224 | (check-equal? (write-chunk-with-length (pp-includes 'name 'name2) 225 | test-context) 226 | '("#include " 227 | "#include ")))) 228 | 229 | (define/provide-test-suite test-pp-ifdef 230 | (test-case 231 | "Test pp-ifdef" 232 | (define test-context 80) 233 | (check-equal? (write-chunk-with-length (pp-ifdef 'condition) test-context) '("#ifdef condition")) 234 | (check-equal? (write-chunk-with-length (pp-ifdef (concat 'condition "2")) test-context) '("#ifdef condition2")) 235 | (check-equal? (write-chunk-with-length (concat space (pp-ifdef 'condition)) test-context) '(" #ifdef condition")) 236 | (check-equal? (write-chunk-with-length (concat "/* " (pp-ifdef 'condition)) test-context) '("/* #ifdef condition")))) 237 | 238 | (define/provide-test-suite test-pp-ifndef 239 | (test-case 240 | "Test pp-ifndef" 241 | (define test-context 80) 242 | (check-equal? (write-chunk-with-length (pp-ifndef 'condition) test-context) '("#ifndef condition")) 243 | (check-equal? (write-chunk-with-length (pp-ifndef (concat 'condition "2")) test-context) '("#ifndef condition2")) 244 | (check-equal? (write-chunk-with-length (concat space (pp-ifndef 'condition)) test-context) '(" #ifndef condition")) 245 | (check-equal? (write-chunk-with-length (concat "/* " (pp-ifndef 'condition)) test-context) '("/* #ifndef condition")))) 246 | 247 | (define/provide-test-suite test-pp-else 248 | (test-case 249 | "Test pp-else" 250 | (define test-context 80) 251 | (check-equal? (write-chunk-with-length pp-else test-context) '("#else")) 252 | (check-equal? (write-chunk-with-length (concat space pp-else) test-context) '(" #else")) 253 | (check-equal? (write-chunk-with-length (concat "/* " pp-else) test-context) '("/* #else")))) 254 | 255 | (define/provide-test-suite test-pp-endif 256 | (test-case 257 | "Test pp-endif" 258 | (define test-context 80) 259 | (check-equal? (write-chunk-with-length (pp-endif 'condition) test-context) '("/* condition */" "#endif")) 260 | (check-equal? (write-chunk-with-length (pp-endif (concat 'condition "2")) test-context) '("/* condition2 */" "#endif")) 261 | (check-equal? (write-chunk-with-length (concat space (pp-endif 'condition)) test-context) '("/* condition */" " #endif")) 262 | (check-equal? (write-chunk-with-length (concat "/* " (pp-endif 'condition)) test-context) '("/* condition */" "/* #endif")))) 263 | 264 | (define/provide-test-suite test-pp-conditional 265 | (test-case 266 | "Test pp-conditional" 267 | (define test-context 80) 268 | (check-equal? (write-chunk-with-length (pp-conditional 'ifdef 'condition 'then) 269 | test-context) 270 | '("/* condition */" 271 | "#endif" 272 | " then" 273 | "#ifdef condition")) 274 | (check-equal? (write-chunk-with-length (pp-conditional 'ifndef 'condition 'then 'else2) 275 | test-context) 276 | '("/* condition */" 277 | "#endif" 278 | " else2" 279 | "#else" 280 | " then" 281 | "#ifndef condition")))) 282 | 283 | (define/provide-test-suite test-pp-conditional-ifdef 284 | (test-case 285 | "Test pp-conditional-ifdef" 286 | (define test-context 80) 287 | (check-equal? (write-chunk-with-length (pp-conditional-ifdef 'condition 'then) 288 | test-context) 289 | '("/* condition */" 290 | "#endif" 291 | " then" 292 | "#ifdef condition")) 293 | (check-equal? (write-chunk-with-length (pp-conditional-ifdef 'condition 'then 'else2) 294 | test-context) 295 | '("/* condition */" 296 | "#endif" 297 | " else2" 298 | "#else" 299 | " then" 300 | "#ifdef condition")))) 301 | 302 | (define/provide-test-suite test-pp-conditional-ifndef 303 | (test-case 304 | "Test pp-conditional-ifndef" 305 | (define test-context 80) 306 | (check-equal? (write-chunk-with-length (pp-conditional-ifndef 'condition 'then) 307 | test-context) 308 | '("/* condition */" 309 | "#endif" 310 | " then" 311 | "#ifndef condition")) 312 | (check-equal? (write-chunk-with-length (pp-conditional-ifndef 'condition 'then 'else2) 313 | test-context) 314 | '("/* condition */" 315 | "#endif" 316 | " else2" 317 | "#else" 318 | " then" 319 | "#ifndef condition")))) 320 | 321 | (define/provide-test-suite test-pp-header-file 322 | (test-case 323 | "Test pp-header-file" 324 | (define test-context 80) 325 | (check-equal? (write-chunk-with-length (pp-header-file 'header_file empty 'asdf 'jkl) 326 | test-context) 327 | '("/* header_file */" 328 | "#endif" 329 | "" 330 | " jkl" 331 | "" 332 | " asdf" 333 | "" 334 | "" 335 | "" 336 | " #define header_file" 337 | "#ifndef header_file")) 338 | (check-equal? (write-chunk-with-length (pp-header-file 'header_file 339 | (concat (pp-include 'iostream) 340 | new-line 341 | (pp-include 'algorithm)) 342 | 'asdf 343 | 'jkl) 344 | test-context) 345 | '("/* header_file */" 346 | "#endif" 347 | "" 348 | " jkl" 349 | "" 350 | " asdf" 351 | "" 352 | " #include " 353 | " #include " 354 | "" 355 | " #define header_file" 356 | "#ifndef header_file")))) 357 | 358 | (define/provide-test-suite test-macro-define 359 | (test-case 360 | "Test macro-defintion" 361 | (define test-context 80) 362 | (define test-context-2 20) 363 | (check-equal? (write-chunk-with-length (macro-define 'name null 'asdf) 364 | test-context) 365 | '("#define name asdf")))) 366 | 367 | ;general chunks 368 | 369 | (define/provide-test-suite test-namespace-define 370 | (test-case 371 | "Test namespace-define" 372 | (define test-context 80) 373 | (check-equal? (write-chunk-with-length (namespace-define 'name 'asdf) 374 | test-context) 375 | '("namespace name { asdf; } /* name */")) 376 | (check-equal? (write-chunk-with-length (namespace-define 'name 'asdf) 377 | 12) 378 | '("} /* name */" 379 | " asdf;" 380 | "namespace name {")) 381 | (check-equal? (write-chunk-with-length (namespace-define 'name 'asdf 'jkl) 382 | 12) 383 | '("} /* name */" 384 | " jkl;" 385 | "" 386 | " asdf;" 387 | "namespace name {")))) 388 | 389 | (define/provide-test-suite test-described-smts 390 | (test-case 391 | "Test described-smts" 392 | (define test-context 80) 393 | (check-equal? (write-chunk-with-length (described-smts 'name 'asdf) 394 | test-context) 395 | '("asdf" 396 | "/* name */")) 397 | (check-equal? (write-chunk-with-length (described-smts 'name 'asdf 'jkl) 398 | test-context) 399 | '("jkl" 400 | "asdf;" 401 | "/* name */")) 402 | (check-equal? (write-chunk-with-length (described-smts 'name 'asdf 'jkl "1234") 403 | test-context) 404 | '("1234" 405 | "jkl;" 406 | "asdf;" 407 | "/* name */")))) 408 | 409 | (define/provide-test-suite test-constize 410 | (test-case 411 | "Test constize" 412 | (define test-context 80) 413 | (check-equal? (write-chunk-with-length (constize 'asdf) 414 | test-context) 415 | '("asdf const")) 416 | (check-equal? (write-chunk-with-length (constize 'asdf) 417 | 4) 418 | '("asdf const")))) 419 | 420 | ;template chunks 421 | 422 | (define/provide-test-suite test-template-define 423 | (test-case 424 | "Test template-define" 425 | (define test-context 80) 426 | (check-equal? (write-chunk-with-length (template-define null 'asdf) 427 | test-context) 428 | '(" asdf" 429 | "template<>")) 430 | (check-equal? (write-chunk-with-length (template-define (list 'first) 431 | 'asdf) 432 | test-context) 433 | '(" asdf" 434 | "template")) 435 | (check-equal? (write-chunk-with-length (template-define (list 'first 'second) 436 | 'asdf) 437 | test-context) 438 | '(" asdf" 439 | "template")) 440 | (check-equal? (write-chunk-with-length (template-define (list (concat (comment-env-chunk 'test) 441 | new-line 442 | 'first) 443 | 'second) 444 | 'asdf) 445 | test-context) 446 | '(" asdf" 447 | " second>" 448 | " first," 449 | "template")) 461 | (check-equal? (write-chunk-with-length (template-use 'name (list 'first 'second)) 462 | test-context) 463 | '("name")) 464 | (check-equal? (write-chunk-with-length (template-use 'name (list 'first 'second)) 465 | 6) 466 | '(" second>" 467 | "name")) 686 | (check-equal? (write-chunk-with-length (template-struct-declare 'name 687 | (list 'first) 688 | (list 'first)) 689 | test-context) 690 | '(" struct name" 691 | "template")) 692 | (check-equal? (write-chunk-with-length (template-struct-declare 'name 693 | (list 'first 'second) 694 | (list 'first 'second)) 695 | test-context) 696 | '(" struct name" 697 | "template")) 698 | (check-equal? (write-chunk-with-length (template-struct-declare 'name 699 | (list 'first) 700 | (list 'first 'second)) 701 | test-context) 702 | '(" struct name" 703 | "template")))) 704 | 705 | (define/provide-test-suite test-section-define 706 | (test-case 707 | "Test section-define" 708 | (define test-context 80) 709 | (check-equal? (write-chunk-with-length (section-define 'name 'first 'second) 710 | test-context) 711 | '(" second" 712 | "" 713 | " first" 714 | "name:")))) 715 | 716 | (define/provide-test-suite test-struct-define 717 | (test-case 718 | "Test struct-define" 719 | (define test-context 80) 720 | (check-equal? (write-chunk-with-length (struct-define 'signature 'first 'second) 721 | test-context) 722 | '("}" 723 | " second" 724 | "" 725 | " first" 726 | "signature {")) 727 | (check-equal? (write-chunk-with-length (struct-define 'signature 'first 'second) 728 | 8) 729 | '("}" 730 | " second" 731 | "" 732 | " first" 733 | "signature {")))) 734 | 735 | (define/provide-test-suite test-template-struct-define 736 | (test-case 737 | "Test template-struct-define" 738 | (define test-context 80) 739 | (check-equal? (write-chunk-with-length (template-struct-define 'name 740 | (list 'first 'second) 741 | null 742 | 'first 743 | 'second) 744 | test-context) 745 | '("}" 746 | " second" 747 | "" 748 | " first" 749 | " struct name {" 750 | "template")) 751 | (check-equal? (write-chunk-with-length (template-struct-define 'name 752 | (list 'first 'second) 753 | null 754 | 'first 755 | 'second) 756 | 12) 757 | '("}" 758 | " second" 759 | "" 760 | " first" 761 | " struct name {" 762 | " second>" 763 | "template