├── README.md ├── lang ├── reader.rkt ├── runtime-config.rkt └── language-info.rkt ├── info.rkt ├── scribblings └── fairylog.scrbl ├── reader.rkt ├── LICENSE ├── main.rkt └── expander.rkt /README.md: -------------------------------------------------------------------------------- 1 | # fairylog 2 | A Verilog dialect enchanced by the Racket meta-fairies. 3 | 4 | 5 | Heavily WIP and not suitable for general usage. No docs. Use at your own risk, subject to huge change at any moment! 6 | -------------------------------------------------------------------------------- /lang/reader.rkt: -------------------------------------------------------------------------------- 1 | ;Fairylog 2 | ;Copyright Ross McKinlay, 2019 3 | 4 | #lang s-exp syntax/module-reader 5 | fairylog 6 | #:wrapper1 wrapper1 7 | #:language-info #(fairylog/lang/language-info get-language-info #f) 8 | 9 | (require "../reader.rkt") -------------------------------------------------------------------------------- /lang/runtime-config.rkt: -------------------------------------------------------------------------------- 1 | ;Fairylog ` 2 | ;Copyright Ross McKinlay, 2017 3 | 4 | #lang racket/base 5 | 6 | (provide configure) 7 | 8 | (require (only-in fairylog/reader make-fairylog-readtable)) 9 | 10 | (define (configure data) 11 | (current-readtable (make-fairylog-readtable))) -------------------------------------------------------------------------------- /lang/language-info.rkt: -------------------------------------------------------------------------------- 1 | ;Fairylog 2 | ;Copyright Ross McKinlay, 2019 3 | 4 | #lang racket/base 5 | 6 | (provide get-language-info) 7 | 8 | (define (get-language-info data) 9 | (lambda (key default) 10 | (case key 11 | [(configure-runtime) 12 | '(#[fairylog/lang/runtime-config configure #f])] 13 | [else default]))) -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "fairylog") 4 | 5 | (define version "0.0.1") 6 | 7 | (define deps 8 | '("base")) 9 | 10 | (define build-deps 11 | '("scribble-lib" 12 | "racket-doc")) 13 | 14 | (define pkg-desc "Verilog dialect") 15 | 16 | (define pkg-authors '("pezi_pink@pinksquirrellabs.com")) 17 | 18 | (define scribblings '(("scribblings/fairylog.scrbl" ()))) 19 | 20 | 21 | -------------------------------------------------------------------------------- /scribblings/fairylog.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket)) 4 | 5 | @title{Fairylog} 6 | 7 | @italic{Written by @hyperlink["http://www.pinksquirrellabs.com"]{Ross McKinlay}} 8 | 9 | Fairylog, a Verilog dialect powered by the Racket meta fairies. 10 | 11 | A source-to-source Verilog compiler, with a number of nice compile time features. Full Racket integration, providing macros and compile time programming for FPGA projects. 12 | 13 | @table-of-contents[] 14 | 15 | @section[#:tag "overview"]{Fairylog Overview} 16 | 17 | TODO 18 | 19 | This project in its early experimental stage and is in constant flux. 20 | -------------------------------------------------------------------------------- /reader.rkt: -------------------------------------------------------------------------------- 1 | ;fairylog 2 | ;Copyright Ross McKinlay, 2019 3 | 4 | #lang racket 5 | (require syntax/readerr) 6 | 7 | (provide wrapper1 8 | make-fairylog-readtable) 9 | 10 | ;; make-no-bar-readtable : [(U #false Readtable)] -> Readtable 11 | (define (make-no-vert-bar-readtable [rt (current-readtable)]) 12 | (make-readtable rt 13 | #\| ; The vertical bar will behave 14 | #\a ; the same way a normal character (such as a) 15 | #f)) ; behaves in the default readtable. 16 | 17 | (define (make-fairylog-readtable) 18 | (make-no-vert-bar-readtable)) 19 | 20 | (define (wrapper1 thk) 21 | (parameterize ([current-readtable (make-fairylog-readtable)]) 22 | (thk))) 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Ross McKinlay 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 all 13 | 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 THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | ;Fairylog 2 | ;Copyright Ross McKinlay, 2010 3 | #lang racket/base 4 | (require (except-in 5 | (rename-in racket 6 | [cond r:cond] 7 | [match r:match] 8 | [when r:when] 9 | [if r:if] 10 | [case r:case] 11 | [begin r:begin] 12 | [eq? r:eq?] 13 | [* r:*] 14 | [+ r:+] 15 | [- r:-] 16 | ) 17 | #%module-begin 18 | )) 19 | (require (for-syntax racket 20 | ;"expander.rkt" 21 | )) 22 | (require (rename-in "expander.rkt" 23 | [~cond cond] 24 | [~match match] 25 | [~begin begin] 26 | [~case case] 27 | [~if if] 28 | [~when when] 29 | )) 30 | 31 | (provide ; 32 | #%module-begin 33 | (except-out (all-from-out racket) 34 | ;cond 35 | ) 36 | (for-syntax (all-from-out racket) 37 | ; (all-from-out "expander.rkt") 38 | ) 39 | 40 | (all-from-out "expander.rkt")) 41 | 42 | -------------------------------------------------------------------------------- /expander.rkt: -------------------------------------------------------------------------------- 1 | ;Fairylog 2 | ;Copyright Ross McKinlay, 2019 3 | 4 | #lang racket/base 5 | 6 | (require (for-syntax syntax/parse 7 | racket/string 8 | racket/base 9 | racket/list 10 | racket/syntax 11 | racket/string 12 | racket/function 13 | syntax/srcloc 14 | syntax/location 15 | racket/list)) 16 | 17 | 18 | (require syntax/parse/define syntax/location) 19 | 20 | (begin-for-syntax 21 | ; true when expanding inside an always block with a sensitivity list 22 | (define is-always-sens #f) 23 | 24 | (define (toggle-always-sens) 25 | (set! is-always-sens (not is-always-sens))) 26 | 27 | (define declared-enums (make-hash)) 28 | 29 | (define current-module "") 30 | (define (set-current-module name) 31 | ; (printf "setting current module ~a\n" name) 32 | (set! current-module name)) 33 | 34 | (define (enum-exists? ctx enum-name) 35 | (let ([gn (datum->syntax ctx (string->symbol (string-append "global-enum-" enum-name)))]) 36 | (if (syntax-local-value gn (λ () #f)) 37 | #t 38 | (hash-has-key? declared-enums enum-name)))) 39 | 40 | (define (enum-key-exists? ctx enum-name key) 41 | ; (printf "enum key exists\n") 42 | (let ([enum-name 43 | (if (symbol? enum-name) 44 | (symbol->string enum-name) 45 | enum-name)] 46 | [key 47 | (if (symbol? key) 48 | (symbol->string key) 49 | key)]) 50 | (let ([gn (datum->syntax ctx (string->symbol (string-append "global-enum-" enum-name)))]) 51 | (if (syntax-local-value gn (λ () #f)) 52 | (member key (map car (syntax-local-value gn))) 53 | (member key (map car (hash-ref declared-enums enum-name))))) 54 | )) 55 | 56 | (define (get-enum-keys ctx enum-name) 57 | (map car (hash-ref declared-enums (symbol->string enum-name)))) 58 | 59 | (define (get-enum-value ctx enum-name key) 60 | (let* ([enum-name 61 | (if (symbol? enum-name) 62 | (symbol->string enum-name) 63 | enum-name)] 64 | [key 65 | (if (symbol? key) 66 | (symbol->string key) 67 | key)] 68 | [gn (datum->syntax ctx (string->symbol (string-append "global-enum-" enum-name)))]) 69 | (if (syntax-local-value gn (λ () #f)) 70 | (let 71 | ([pair (memf (λ (p) (equal? (car p) key)) (syntax-local-value gn))]) 72 | (cdr (car pair))) 73 | (let* 74 | ([pairs (hash-ref declared-enums enum-name)] 75 | [pair (memf (λ (p) (equal? (car p) key)) pairs)]) 76 | (cdr (car pair)))))) 77 | 78 | (define (add-enum enum-name vals) 79 | (printf "enum ~a\n" (symbol->string enum-name) ) 80 | (for ([kvp vals]) 81 | (printf "~a : ~x\n" (car kvp) (cdr kvp))) 82 | (hash-set! declared-enums (symbol->string enum-name) vals)) 83 | 84 | (define-syntax-class enum 85 | #:description "a declared enum" 86 | #:opaque 87 | (pattern x:id #:when (enum-exists? (attribute x) (symbol->string (syntax-e (attribute x)))))) 88 | 89 | (define-syntax-class enum-kvp 90 | #:description "a name and numeric value pair" 91 | #:opaque 92 | (pattern [x:id y] 93 | #:with y-evaled (eval (syntax-e (attribute y))) 94 | #:with pair (cons 95 | (format "~a" (syntax-e (attribute x))) 96 | (syntax-e (attribute y-evaled))))) 97 | 98 | (define-syntax-class enum-literal 99 | #:description "enum literal in the form enum.value" 100 | (pattern x:id 101 | #:do 102 | [(define split 103 | (string-split 104 | (symbol->string (syntax-e (attribute x))) 105 | "."))] 106 | #:when (eq? (length split) 2 ) 107 | #:cut 108 | #:fail-unless (enum-exists? (attribute x) (car split)) 109 | (format "the enum ~a does not exist" (car split)) 110 | #:fail-unless (enum-key-exists? (attribute x) (car split) (car (cdr split))) 111 | (format "the value ~a does not exist for enum ~a" 112 | (car (cdr split)) 113 | (car split)) 114 | #:with value (datum->syntax this-syntax (get-enum-value (attribute x) (car split) (car (cdr split)))) 115 | #:with compiled 116 | (datum->syntax this-syntax 117 | (format "~a (~a)" (symbol->string (syntax-e (attribute x))) 118 | (get-enum-value (attribute x) (car split) (car (cdr split))))) 119 | #:with bits (datum->syntax this-syntax (string-length (format "~b" (get-enum-value (attribute x)(car split) (car (cdr split)))))) 120 | )) 121 | 122 | ;important note: these mutable structs do not work "globally", they are for 123 | ;local expansion purposes only. the modules and ports are also exposed via 124 | ;static bindings for other files to see. 125 | (struct port-meta (name direction type) #:transparent) 126 | (struct func-meta (name size-int) #:transparent #:mutable) 127 | (struct module-meta (name ports functions) #:transparent #:mutable) 128 | (define module-metadata (make-hash)) 129 | (define (add-module name ports) 130 | (if (hash-has-key? module-metadata name) 131 | (error "module ~a already exists" name) 132 | (hash-set! module-metadata name (module-meta name ports '())))) 133 | (define (module-exists? name-stx) 134 | ;here we check for a static binding to this works across files. 135 | (if (syntax-local-value name-stx (λ () #f)) 136 | #t 137 | (hash-ref module-metadata (symbol->string (syntax-e name-stx))))) 138 | (define (module-port-names name-stx) 139 | (if (syntax-local-value name-stx (λ () #f)) 140 | (map (compose symbol->string port-meta-name) 141 | (module-meta-ports (syntax-local-value name-stx))) 142 | (map (compose symbol->string port-meta-name) 143 | (module-meta-ports 144 | (hash-ref module-metadata 145 | (symbol->string (syntax-e name-stx))))))) 146 | (define (module-has-port? name-stx port-name) 147 | ;uses static binding data 148 | (if (syntax-local-value name-stx (λ () #f)) 149 | (memf (λ (port) (equal? (symbol->string (port-meta-name port)) port-name)) 150 | (module-meta-ports (syntax-local-value name-stx))) 151 | (memf (λ (port) (equal? (symbol->string (port-meta-name port)) port-name)) 152 | (module-meta-ports (hash-ref module-metadata 153 | (symbol->string (syntax-e name-stx))))))) 154 | (define (module-has-function? module-name function-name) 155 | ;uses local data 156 | (memf (λ (func) (equal? (func-meta-name func) function-name)) 157 | (module-meta-functions (hash-ref module-metadata module-name)))) 158 | (define (add-module-function module-name function-name size) 159 | (let* ([mod (hash-ref module-metadata module-name)] 160 | [fs (module-meta-functions mod)]) 161 | (set-module-meta-functions! mod (cons (func-meta function-name size) fs)))) 162 | 163 | 164 | (define-syntax-class module-param 165 | #:description "a module initializer" 166 | (pattern [port-name:id port-value:bound-usage] 167 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'port-name))) 168 | #:with value(datum->syntax this-syntax #'port-value.compiled)) 169 | 170 | (pattern [port-name:id port-value:expr] 171 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'port-name))) 172 | #:with value(datum->syntax this-syntax #'(expression port-value)))) 173 | 174 | (define scoped-bindings-stack (box (list (make-hash)))) 175 | (define (push-scoped-stack) 176 | (let* ([lst (unbox scoped-bindings-stack)] 177 | [new-lst (cons (make-hash) lst)]) 178 | (set-box! scoped-bindings-stack new-lst))) 179 | 180 | (define (pop-scoped-stack) 181 | 182 | (let* ([lst (unbox scoped-bindings-stack)] 183 | [new-lst (cdr lst)]) 184 | (set-box! scoped-bindings-stack new-lst))) 185 | 186 | (define (peek-scoped-stack) 187 | (let ([lst (unbox scoped-bindings-stack)]) 188 | (car lst))) 189 | 190 | (struct binding-meta ( stx-size stx-arity-list)) 191 | (define (add-scoped-binding stx-name binding-meta stx) 192 | (let ([name (syntax-e stx-name)] 193 | [scoped (peek-scoped-stack)]) 194 | (when (and (in-scope? name) (not (equal? name "global"))) 195 | (writeln 196 | (format "warning: ~a is already in scope at ~a" 197 | name (source-location->string stx)))) 198 | (hash-set! scoped name binding-meta))) 199 | 200 | (define (remove-scoped-binding stx-name) 201 | (let ([name (syntax-e stx-name)] 202 | [scoped (peek-scoped-stack)]) 203 | (hash-remove! scoped name))) 204 | 205 | (define (in-scope? name) 206 | (define (aux lst) 207 | (cond 208 | [(empty? lst) #f] 209 | [(hash-has-key? (car lst) name) #t] 210 | [else (aux (cdr lst))])) 211 | (aux (unbox scoped-bindings-stack))) 212 | 213 | (define (get-binding-size name) 214 | (let ([name2 (if (syntax? name) (symbol->string (syntax-e name)) name)]) 215 | (define (aux lst) 216 | (cond 217 | [(empty? lst) 218 | (begin 219 | 'none)] 220 | [(hash-has-key? (car lst) name2) 221 | (begin 222 | (binding-meta-stx-size (hash-ref (car lst) name2)))] 223 | [else (aux (cdr lst))])) 224 | (aux (unbox scoped-bindings-stack)))) 225 | 226 | (define (get-binding-arities name) 227 | (let ([name2 (if (syntax? name) (symbol->string (syntax-e name)) name)]) 228 | (define (aux lst) 229 | (cond 230 | [(empty? lst) 231 | (begin 232 | 'none)] 233 | [(hash-has-key? (car lst) name2) 234 | (begin 235 | (binding-meta-stx-arity-list (hash-ref (car lst) name2)))] 236 | [else (aux (cdr lst))])) 237 | (aux (unbox scoped-bindings-stack)))) 238 | 239 | (define-syntax-class scoped-binding 240 | #:description "identifier in scope" 241 | #:commit 242 | (pattern x:id 243 | #:with name (symbol->string (syntax-e #'x)) 244 | #:with name-stx (datum->syntax this-syntax (symbol->string (syntax-e #'x))) 245 | #:fail-unless (in-scope? (symbol->string (syntax-e #'x))) "identifier is not in scope." 246 | #:with size-int (get-binding-size (symbol->string (syntax-e #'x))) 247 | #:with arities (get-binding-arities (symbol->string (syntax-e #'x))) 248 | #:with is-array? 249 | (let* ([a (get-binding-arities (symbol->string (syntax-e #'x)))] 250 | [b (if (syntax? a)(list?(syntax-e a)) #f)] ) 251 | (and (syntax? a) (list? (syntax-e a))) 252 | ))) 253 | 254 | (define-syntax-class binding 255 | #:description "identifier name" 256 | (pattern x:id 257 | #:with name (symbol->string (syntax-e #'x)))) 258 | 259 | (define-syntax-class scoped-function 260 | (pattern x:id 261 | #:with name (symbol->string (syntax-e #'x)) 262 | #:with name-stx (datum->syntax this-syntax (symbol->string (syntax-e #'x))) 263 | #:when (module-has-function? current-module (symbol->string (syntax-e #'x))) 264 | ) 265 | ) 266 | 267 | (define-syntax-class inner-usage 268 | (pattern x:scoped-binding 269 | #:with name #'x.name 270 | #:with size-int #'x.size-int 271 | #:with compiled 272 | #'x.name-stx) 273 | (pattern x:expr 274 | #:with size-int #'(expression x) 275 | #:with compiled #'(expression x))) 276 | 277 | (define-syntax-class bound-usage 278 | #:description "identifier in scope with or without size, or array access" 279 | #:commit 280 | 281 | ;arrays: 282 | ;when accessing an array, verilog says you must use all the dimensions. 283 | ;following that, you can further index into the bits using the normal 284 | ;range syntax. 285 | 286 | ;to start with no range checking of arrays. but we must still know 287 | ;the length of the array to know if they have supplied a range at the 288 | ;end or not (up to two expressions) 289 | (pattern [s:scoped-binding 290 | x:inner-usage ...+] 291 | #:with x-count (length (syntax->list #'(x ...))) 292 | #:with name #'s.name 293 | 294 | #:with oob #'#f ;todo; out of bounds checks 295 | #:with compiled 296 | ;todo: report these errors properly, not using exceptions!! 297 | ;todo: range checking on arities. 298 | (if (syntax-e #'s.is-array?) 299 | (cond 300 | [(< (syntax-e #'x-count) (length (syntax-e #'s.arities))) 301 | (error "you must specify all the array's dimensions" #'s)] 302 | [(= (syntax-e #'x-count) (length (syntax-e #'s.arities))) 303 | #'`(name ("[" ,x.compiled "]") ...)] 304 | [else 305 | (let-values 306 | ([(left right) 307 | (split-at 308 | (syntax->list #'(x ...)) 309 | (length (syntax-e #'s.arities)))]) 310 | (syntax-parse (list left right) 311 | [((z:inner-usage ...) (ya:inner-usage yb:inner-usage)) 312 | #'`(name ("[" z.compiled "]") ... 313 | "[" ya.compiled " : " yb.compiled "]" 314 | )] 315 | [((z:inner-usage ...) (ya:inner-usage)) 316 | #'`(name ("[" z.compiled "]") ... 317 | "[" ya.compiled "]" 318 | )] 319 | [((z:inner-usage ...) ()) 320 | #'`(name ("[" z.compiled "]") ...)]))]) 321 | (cond 322 | [(> (syntax-e #'x-count) 2) (error "not an array\n" #'s)] 323 | [(= (syntax-e #'x-count) 2) 324 | (syntax-parse #'(x ...) 325 | [(x:inner-usage y:inner-usage) 326 | #'`(name "[" ,x.compiled " : " ,y.compiled "]")])] 327 | [else 328 | #'`(name ("[" ,x.compiled "]") ...)])) 329 | 330 | #:with name-stx #'compiled 331 | 332 | #:with size-int 333 | ;since it is not possible to compile an array expression without 334 | ;all the indexes, we need only return the atual data size 335 | ;OR whatever the range equates to. for non-arrays, the size will 336 | ;be either one for a signle bit select or the size of the range. 337 | 338 | (if (syntax-e #'s.is-array?) 339 | (let-values 340 | ([(left right) 341 | (split-at (syntax->list #'(x ...)) 342 | (length (syntax-e #'s.arities)))]) 343 | (syntax-parse (list left right) 344 | [((z:inner-usage ...) (msb:inner-usage lsb:inner-usage)) 345 | #'(+ (- msb.size-int lsb.size-int) 1)] 346 | [((z:inner-usage ...) (ya:inner-usage)) 347 | ;single bit 348 | #'1] 349 | [((z:inner-usage ...) ()) 350 | ;indexed - return size of array data 351 | #'s.size-int])) 352 | (syntax-parse #'(x ...) 353 | [(msb:inner-usage lsb:inner-usage) 354 | ; (printf "here size is ~a ~a \n" #'msb.size-int #'lsb.size-int 355 | ;) 356 | #'(+ (- msb.size-int lsb.size-int) 1)] 357 | [(x:inner-usage) 358 | #'1]) 359 | 360 | )) 361 | 362 | (pattern s:scoped-binding 363 | #:with name #'s.name 364 | #:with size (datum->syntax this-syntax "") 365 | #:with size-int #'s.size-int 366 | #:with oob #'#f 367 | #:with compiled (datum->syntax this-syntax (symbol->string (syntax-e (attribute s)))) 368 | #:with name-stx #'compiled) ;used in error reporting 369 | 370 | )) 371 | 372 | (define-syntax (push-binding stx) 373 | (syntax-parse stx 374 | [(_ id size) 375 | (add-scoped-binding #'id (binding-meta #'size #'#f) stx) 376 | #'(void)] 377 | [(_ id size arity-list) 378 | (add-scoped-binding #'id (binding-meta #'size #'arity-list) stx) 379 | #'(void)])) 380 | 381 | (define-syntax (pop-scoped-stack stx) 382 | (syntax-parse stx 383 | [(_) 384 | (pop-scoped-stack) 385 | #'(void)])) 386 | 387 | (define-syntax (toggle-always-sens stx) 388 | (syntax-parse stx 389 | [(_) 390 | (toggle-always-sens) 391 | #'(void)])) 392 | 393 | (begin-for-syntax 394 | (define (syntax->error-syntax stx) 395 | (datum->syntax stx 396 | (format "~a:~a:~a" 397 | (syntax-source stx) 398 | (syntax-line stx) 399 | (syntax-column stx)))) 400 | 401 | (define (is-hex-literal? str) 402 | (regexp-match #px"^[$][0-9A-Fa-f_ZzXx]+$" str)) 403 | 404 | (define (is-binary-literal? str) 405 | (regexp-match #px"^[%][01_ZzXx]+$" str)) 406 | 407 | (define (is-hex-string? str) 408 | (regexp-match #px"^[0-9A-Fa-f_ZzXx]+$" str)) 409 | 410 | (define (is-binary-string? str) 411 | (regexp-match #px"^[$][01_ZzXx]+$" str)) 412 | 413 | (define (is-number-literal-candidate? str) 414 | ;todo: need better literal checking 415 | ; eg check literal with base is not greater than size 416 | ; check literals characters properly - binary only 01xz_ etc 417 | (let ([parsed 418 | (regexp-match #px"^([0-9]+)_(2|8|10|16)_(-)?([0-9A-Fa-f_ZzXx]+$)" str)]) 419 | (if (eq? parsed #f) 420 | #f 421 | (cdr parsed)))) ; outputs size base negative? value 422 | 423 | (define (string-replace-many str from to) 424 | (for/fold ([str str]) 425 | ([f from]) 426 | (string-replace str f to))) 427 | 428 | (define-syntax-class number-literal 429 | #:datum-literals (_) 430 | (pattern x:integer 431 | #:with base 10 432 | #:with bits 433 | (datum->syntax this-syntax 434 | (string-length (format "~b" (syntax-e (attribute x))))) ;easy way out! 435 | #:with compiled 436 | (datum->syntax this-syntax 437 | (format "~a" (syntax-e (attribute x))))) 438 | ;hex literals 439 | (pattern x:id 440 | #:do [(define str (symbol->string (syntax-e (attribute x))))] 441 | #:when (is-hex-literal? str) 442 | #:do [(define cleaned (string-replace 443 | (string-replace str "_" "") "$" ""))] 444 | #:with base 16 445 | ; for hex, leading zeroes are counted towards the length 446 | #:with bits (datum->syntax this-syntax (* 4 (string-length cleaned))) 447 | #:with compiled 448 | (datum->syntax this-syntax 449 | (format "~a'h~a" 450 | (syntax-e (attribute bits)) 451 | (substring str 1)))) 452 | ;binary literals 453 | (pattern x:id 454 | #:do [(define str (symbol->string (syntax-e (attribute x))))] 455 | #:when (is-binary-literal? str) 456 | #:do [(define cleaned (string-replace 457 | (string-replace str "_" "") "%" ""))] 458 | #:with base 2 459 | ; for binary, leading zeroes are counted towards the length 460 | #:with bits (datum->syntax this-syntax (string-length cleaned)) 461 | #:with compiled 462 | (datum->syntax this-syntax 463 | (format "~a'b~a" 464 | (syntax-e (attribute bits)) 465 | (substring str 1) ))) 466 | 467 | ;full literal syntax 468 | (pattern x:id 469 | #:do [(define str 470 | (is-number-literal-candidate? 471 | (symbol->string (syntax-e (attribute x)))))] 472 | #:when (list? str) 473 | #:do [(define radix (string->number (list-ref str 1))) 474 | (define radix-str 475 | (case (string->number (list-ref str 1)) 476 | [(2) "'b"] 477 | [(8) "'o"] 478 | [(10) "'d"] 479 | [(16) "'h"])) 480 | (define size (string->number (list-ref str 0))) 481 | (define literal (list-ref str 3))] 482 | #:with base radix-str 483 | #:with bits size 484 | #:do [(let* ([n (string-replace-many literal '["X" "x" "Z" "z"]"0")] 485 | [l 486 | ;for all but decimal we count the leading zeroes as well 487 | ;todo: this needs work, probably want tot just parse and count binary instead? 488 | (case radix 489 | [(2) (string-length n)] 490 | [(8) (* (string-length n) 3)] 491 | [(16) (string-length (format "~b" (string->number n 16)) 492 | )] 493 | [(10) (string-length (format "~b" (string->number n 10)) 494 | )])]) 495 | (when (> l size) 496 | (printf "warning: number literal ~a does not fit into the specified size at ~a\\n" 497 | (symbol->string (syntax-e (attribute x))) #'x)))] 498 | #:with compiled 499 | (datum->syntax this-syntax 500 | (format "~a~a~a~a" 501 | (case (list-ref str 2) 502 | [(#f) ""] 503 | [else "-"]) 504 | size radix-str literal)))) 505 | 506 | 507 | (define-syntax-class edge-type 508 | (pattern #:posedge) 509 | (pattern #:negedge)) 510 | 511 | (define-syntax-class sensitivity 512 | #:no-delimit-cut 513 | (pattern [edge:edge-type ~! signal:bound-usage] 514 | #:with edge-type (datum->syntax this-syntax (keyword->string (syntax-e #'edge))) 515 | #:with compiled #'signal.compiled) 516 | (pattern [signal:bound-usage] 517 | #:with edge-type (datum->syntax this-syntax "") 518 | #:with compiled #'signal.compiled) 519 | ) 520 | 521 | (define-syntax-class direction-option 522 | (pattern #:input) 523 | (pattern #:output) 524 | (pattern #:inout)) 525 | 526 | (define-syntax-class type-option 527 | (pattern #:wire) 528 | (pattern #:wand) 529 | (pattern #:wor) 530 | (pattern #:tri) 531 | (pattern #:reg) 532 | (pattern #:integer) 533 | (pattern #:time) 534 | (pattern #:real)) 535 | 536 | (define-syntax-class function-param 537 | #:description "a function parameter" 538 | (pattern [name-sym:id 539 | (~optional [x (~optional y)])] 540 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'name-sym))) 541 | #:with direction (datum->syntax this-syntax "input") 542 | #:with type (datum->syntax this-syntax "wire") 543 | #:with arity-list #'#f 544 | #:with default #'"" 545 | #:with size-int 546 | (cond 547 | [(and (attribute x) (attribute y)) 548 | #'(+ (- x y) 1)] 549 | [(attribute x) 550 | #'x] 551 | [else #'1]) 552 | #:with size 553 | (cond 554 | [(and (attribute x) (attribute y)) 555 | #'`("[" ,x ":" ,y "]")] 556 | [(attribute x) 557 | #'`("[" ,(- x 1) ":0" "]")] 558 | [else #'""]))) 559 | 560 | (define-syntax-class param 561 | #:description "a module parameter" 562 | (pattern [name-sym:id 563 | direction-opt:direction-option 564 | type-opt:type-option 565 | (~optional [x (~optional y)]) 566 | (~optional default-value)] 567 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'name-sym))) 568 | #:with direction (datum->syntax this-syntax (keyword->string (syntax-e #'direction-opt))) 569 | #:with type (datum->syntax this-syntax (keyword->string (syntax-e #'type-opt))) 570 | #:with default 571 | (if (attribute default-value) 572 | #'`(" = " ,(expression default-value)) 573 | #'"") 574 | #:with size-int 575 | (cond 576 | [(and (attribute x) (attribute y)) 577 | #'(+ (- x y) 1)] 578 | [(attribute x) 579 | #'x] 580 | [else #'1]) 581 | #:with size 582 | (cond 583 | [(and (attribute x) (attribute y)) 584 | #'`("[" ,x ":" ,y "]")] 585 | [(attribute x) 586 | #'`("[" ,(- x 1) ":0" "]")] 587 | [else #'""]))) 588 | 589 | (define-syntax-class local-param 590 | #:datum-literals (array) 591 | 592 | (pattern [name-sym:id 593 | type-opt:type-option 594 | [x (~optional y)] 595 | (~optional (array x2:expr ...+))] 596 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'name-sym))) 597 | #:with type (datum->syntax this-syntax (keyword->string (syntax-e #'type-opt))) 598 | #:with default ;arrays dont have defaults, instead the 599 | ;additional array syntax appears here. 600 | (cond 601 | [(and (attribute x2)) 602 | #'`( 603 | ( 604 | "[0:" ,(- x2 1) "]" 605 | ) ... 606 | )] 607 | [else #'""]) 608 | 609 | #:with arity-list 610 | (if (attribute x2) 611 | (syntax->list #'(x2 ...)) 612 | #'#f) 613 | 614 | ; actual data size, not array dimensions. 615 | #:with size-int 616 | (cond 617 | [(and (attribute x) (attribute y)) 618 | #'(+ (- x y) 1)] 619 | [(attribute x) 620 | #'x] 621 | [else #'1]) 622 | #:with size 623 | (cond 624 | [(and (attribute x) (attribute y)) 625 | #'`("[" ,x ":" ,y "]")] 626 | [(attribute x) 627 | #'`("[" ,(- x 1) ": 0" "]")] 628 | [else #'""])) 629 | 630 | (pattern [name-sym:id 631 | type-opt:type-option 632 | (~optional [x (~optional y)]) 633 | (~optional 634 | default-value:expr)] 635 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'name-sym))) 636 | #:with type (datum->syntax this-syntax (keyword->string (syntax-e #'type-opt))) 637 | #:with default 638 | (if (attribute default-value) 639 | #'`(" = " ,(expression default-value)) 640 | #'"") 641 | #:with arity-list #'#f 642 | #:with size-int 643 | (cond 644 | [(and (attribute x) (attribute y)) 645 | #'(+ (- x y) 1)] 646 | [(attribute x) 647 | #'x] 648 | [else #'1]) 649 | #:with size 650 | (cond 651 | [(and (attribute x) (attribute y)) 652 | #'`("[" ,x ":" ,y "]")] 653 | [(attribute x) 654 | #'`("[" ,(- x 1) ": 0" "]")] 655 | [else #'""])))) 656 | 657 | 658 | (define-syntax-parser expression 659 | #:datum-literals 660 | (set ~delay if case else when concat 661 | \|\| \| \~\| ! ~ + - * / % << >> >>> == != >= <= < > && & ~& ^ ~^ ) 662 | [(_ x:integer) 663 | #'x] 664 | [(_ x:number-literal ) 665 | #'x.compiled] 666 | [(_ x:bound-usage) 667 | #:with err-prefix (syntax->error-syntax #'x) 668 | #'`( 669 | ,(when x.oob 670 | (printf "~a: warning - the expression '~a' is out of range\n" err-prefix x.compiled)) 671 | ,x.compiled)] 672 | [(_ x:enum-literal) 673 | #'x.value] 674 | [(_ (f:scoped-function ~! params ... last-param)) 675 | #'`( 676 | ,f.name-stx "(" 677 | ( ,(expression params ) ",") ... 678 | ,(expression last-param) 679 | ")")] 680 | [(_ (~delay ~! x y)) 681 | #'`("#" ,(expression x) " " ,(expression y))] 682 | [(_ (when ~! test true-expr)) 683 | ;special case one-line when in RHS of expression - ternary 684 | #'(~begin (when test true-expr))] 685 | [(_ (concat ~! x y ...+)) 686 | #'`("{" ,(expression x) ( ", ",(expression y)) ... "}" )] 687 | [(_ (if ~! 688 | (~describe "condional test for if" test) 689 | (~describe "true expression for if" true-expr) 690 | (~describe "false expression for if" false-expr))) 691 | #'`("(" 692 | ,(expression test) 693 | " ? " 694 | ,(expression true-expr) 695 | " : " 696 | ,(expression false-expr) 697 | ")")] 698 | [(_ (case val 699 | [test true-expr] 700 | [test2 expr2] ...+ 701 | [else def-expr])) 702 | #'`( 703 | "(" 704 | ,(expression (== val test)) 705 | " ? " 706 | ,(expression true-expr) 707 | " : " 708 | ,(expression (case val [test2 expr2] ... [else def-expr])) 709 | ")")] 710 | [(_ (case val [test true-expr] 711 | [else def-expr])) 712 | #'`( 713 | "(" 714 | ,(expression (== val test)) 715 | " ? " 716 | ,(expression true-expr) 717 | " : " 718 | ,(expression def-expr) 719 | ")")] 720 | [(_ (case ~! val [test true-expr] ...+)) 721 | #:fail-when #t "you must supply an else branch of a case when used as an epxression" 722 | #'(void)] 723 | 724 | ; unary 725 | 726 | [(_ ( (~and op (~or + - ! & ~& ~ \| \~\| ^ ~^)) x)) 727 | #:with op-str (datum->syntax this-syntax (symbol->string (syntax-e #'op))) 728 | #'`(,op-str ,(expression x))] 729 | 730 | ; binary 731 | [(_ ( (~and op (~or + - * / % << >> >>> == != < > <= >= && & \|\| \| ^ ~^)) x y )) 732 | #:with op-str (datum->syntax this-syntax (symbol->string (syntax-e #'op))) 733 | #'`( 734 | "(" 735 | ,(expression x) 736 | " " 737 | ,op-str 738 | " " 739 | ,(expression y) 740 | ")")] 741 | [(_ ( (~and op (~or + - * / % << >> >>> == != <= >= && & \|\| \| ^ ~^)) x y z ... )) 742 | #:with op-str (datum->syntax this-syntax (symbol->string (syntax-e #'op))) 743 | #'`( 744 | "(" 745 | ,(expression x) 746 | " " 747 | ,op-str 748 | " (" 749 | ,(expression (op y z ...)) 750 | ")) " )] 751 | 752 | ;setters and bounds / truncation checking 753 | [(_ (set (~or x:scoped-binding x:bound-usage) y:number-literal)) 754 | #:with op (if is-always-sens #'" <= " #'" = ") 755 | #'`( 756 | ,(when (> y.bits x.size-int) 757 | (printf "\"warning: the literal '~a' does not fit into '~a' and will be truncated\"\n" y.compiled x.name-stx)) 758 | ,(expression x) 759 | op 760 | ,(expression y))] 761 | 762 | [(_ (set (~or x:scoped-binding x:bound-usage) y:enum-literal)) 763 | #:with op (if is-always-sens #'" <= " #'" = ") 764 | #'`( 765 | ,(when (> y.bits x.size-int) 766 | (printf "\"warning: the enum literal '~a' does not fit into '~a' and will be truncated\"\n" y.compiled x.name-stx)) 767 | ,(expression x) 768 | op 769 | ,(expression y))] 770 | 771 | [(_ (set (~or x:scoped-binding x:bound-usage) (~or y:scoped-binding y:bound-usage))) 772 | #:with op (if is-always-sens #'" <= " #'" = ") 773 | #'`( 774 | ,(when (> y.size-int x.size-int) 775 | (printf "\"warning: the expression '~a' does not fit into '~a' and will be truncated\"\n" y.name-stx x.name-stx)) 776 | ,(expression x) 777 | op 778 | ,(expression y))] 779 | 780 | [(_ (set (~or x:scoped-binding x:bound-usage) y:expr)) 781 | #:with op (if is-always-sens #'" <= " #'" = ") 782 | #:with name (datum->syntax this-syntax (format "~a" #'y)) 783 | #'`( 784 | ,(when (and (number? (expression y))(> (string-length (format "~b" (expression y))) x.size-int)) 785 | (printf "\"warning: the expression '~a' does not fit into '~a' and will be truncated\"\n" name x.name-stx)) 786 | ,(expression x) 787 | op 788 | ,(expression y))] 789 | 790 | [(_ (set x y)) 791 | #:with op (if is-always-sens #'" <= " #'" = ") 792 | #'`( 793 | ,(expression x) 794 | op 795 | ,(expression y))] 796 | 797 | [(_ x:expr) 798 | #'x] 799 | 800 | ) 801 | 802 | 803 | (define-syntax-parser ~case 804 | #:datum-literals (else) 805 | [(_ test:bound-usage [lhs:number-literal rhs (~optional comment:string #:defaults ([comment #'""]))] ...) 806 | #'`( 807 | tab 808 | "case (" 809 | ,test.compiled 810 | ")\n" 811 | inc-tab 812 | ( 813 | tab 814 | ,lhs.compiled 815 | " : // " 816 | comment 817 | "\n" 818 | ,(~begin rhs) 819 | "\n" 820 | ) ... 821 | dec-tab 822 | tab 823 | "endcase\n")] 824 | [(_ test:bound-usage [lhs:number-literal rhs (~optional comment:string #:defaults ([comment #'""]))] ... 825 | [else else-expr:expr]) 826 | #'`( 827 | tab 828 | "case (" 829 | ,test.compiled 830 | ")\n" 831 | inc-tab 832 | ( 833 | tab 834 | ,lhs.compiled 835 | " : // " 836 | comment 837 | "\n" 838 | ,(~begin rhs) 839 | "\n" 840 | ) ... 841 | 842 | tab 843 | "default : \n" 844 | ,(~begin else-expr) 845 | "\n" 846 | dec-tab 847 | tab 848 | "endcase\n")] 849 | ) 850 | 851 | (define-syntax-parser ~cond 852 | #:datum-literals (else) 853 | [(_ [first-test first-outcome] [expr-test expr-outcome] ... 854 | [else else-outcome]) 855 | #'`( 856 | ,(~cond 857 | [first-test first-outcome] 858 | [expr-test expr-outcome] ...) 859 | tab 860 | "else\n" 861 | inc-tab 862 | ,(~begin else-outcome) 863 | "\n" 864 | dec-tab 865 | )] 866 | [(_ [first-test first-outcome]) 867 | #'`( 868 | tab 869 | "if(" 870 | ,(expression first-test) 871 | ")\n" 872 | inc-tab 873 | ,(~begin first-outcome) 874 | dec-tab 875 | "\n" 876 | )] 877 | [(_ [first-test first-outcome] [expr-test expr-outcome] ...) 878 | #'`( 879 | tab 880 | "if(" 881 | ,(expression first-test) 882 | ")\n" 883 | inc-tab 884 | ,(~begin first-outcome) 885 | "\n" 886 | dec-tab 887 | (tab 888 | "else if(" 889 | ,(expression expr-test) 890 | ")\n" 891 | inc-tab 892 | ,(~begin expr-outcome) 893 | "\n" 894 | dec-tab 895 | "\n") ... 896 | )]) 897 | 898 | (define-syntax-parser ~if 899 | [(_ (~describe "condional test for if" test-expr) 900 | (~describe "true expression for if" true-expr) 901 | (~describe "false expression for if" false-expr)) 902 | #'(~cond 903 | [test-expr true-expr] 904 | [else false-expr])]) 905 | 906 | (define-syntax-parser ~when 907 | [(_ test-expr true-expr) 908 | #'(~cond 909 | [test-expr true-expr])]) 910 | 911 | (define-syntax-parser list->enum 912 | [(_ name vals) 913 | ;todo: add global support here 914 | (add-enum (syntax-e #'name) (eval #'vals)) 915 | #'(void)]) 916 | 917 | (define-syntax-parser enum 918 | [(_ name kvp:enum-kvp ...+) 919 | #:fail-when (check-duplicate-identifier 920 | (syntax->list #'(kvp.x ...))) 921 | "duplicate enum name" 922 | #:fail-when (check-duplicates 923 | (syntax->datum #'(kvp.y-evaled ...))) 924 | "duplicate enum value" 925 | 926 | (if (syntax-property this-syntax 'module) 927 | (begin 928 | ;a local enum only need exist for this module during this expansion 929 | (add-enum (syntax-e #'name) (syntax->datum #'(kvp.pair ...))) 930 | #'(void)) 931 | ;otherwise we create a static binding for the enum data 932 | ;prefixing the name with global-enum 933 | (with-syntax ([g-name (datum->syntax this-syntax (string->symbol 934 | (string-append "global-enum-" 935 | (symbol->string 936 | (syntax-e #'name)))))]) 937 | (printf "ADDING ENUM ~a\n" #'g-name) 938 | #'(define-syntax g-name 939 | '(kvp.pair ...) 940 | )))] 941 | [(_ name keys:id ...+) 942 | #:fail-when (check-duplicate-identifier 943 | (syntax->list #'(keys ...))) 944 | "duplicate enum name" 945 | (with-syntax 946 | ([(kvps ...) 947 | (for/list 948 | ([n (in-naturals)] 949 | [x (syntax->list #'(keys ...))]) 950 | (cons (format "~a" (syntax-e x)) n))]) 951 | (if (syntax-property this-syntax 'module) 952 | (begin 953 | (add-enum (syntax-e #'name)(syntax->datum #'(kvps ...))) 954 | #'(void)) 955 | (with-syntax ([g-name (datum->syntax this-syntax (string->symbol 956 | (string-append "global-enum-" 957 | (symbol->string 958 | (syntax-e #'name)))))]) 959 | #'(define-syntax g-name 960 | '(kvps ...) 961 | )) 962 | ) 963 | )]) 964 | 965 | (define-syntax-parser ~match-set 966 | [(_ target:bound-usage test:expr enum-name:enum 967 | [key value] ...) 968 | #:fail-when (check-duplicate-identifier (syntax->list #'(key ...))) 969 | "duplicate enum value" 970 | 971 | #:fail-when 972 | (let ([results (filter (λ (v) (not (enum-key-exists? #'enum-name (syntax-e #'enum-name) v))) 973 | (syntax->datum #'(key ...)))]) 974 | (if (not (eq? results '())) 975 | (with-syntax ([res results]) #'res) 976 | #f)) 977 | "some identifiers do not exist in enum" 978 | 979 | #:fail-when 980 | (let* 981 | ([keys (map (λ (v) (format "~a" v)) (syntax->datum #'(key ...)))] 982 | [results (filter (λ (v) (not (member v keys))) 983 | (get-enum-keys #'enum-name (syntax-e #'enum-name)))]) 984 | (if (not (eq? results '())) 985 | (with-syntax ([res results]) #'res) 986 | #f)) 987 | "missing cases in the enum" 988 | 989 | (with-syntax([(enum-vals ...) (map (λ (v) (get-enum-value #'enum-name (syntax-e #'enum-name) v)) 990 | (syntax->datum #'(key ...)))]) 991 | #'(~case test [enum-vals (set target value)] ...))] 992 | ) 993 | 994 | (define-syntax-parser ~match 995 | [(_ test:expr enum-name:enum 996 | [key expr] ...) 997 | #:fail-when (check-duplicate-identifier (syntax->list #'(key ...))) 998 | "duplicate enum value" 999 | 1000 | #:fail-when 1001 | (let ([results (filter (λ (v) (not (enum-key-exists? #'enum-name (syntax-e #'enum-name) v))) 1002 | (syntax->datum #'(key ...)))]) 1003 | (if (not (eq? results '())) 1004 | (with-syntax ([res results]) #'res) 1005 | #f)) 1006 | "some identifiers do not exist in enum" 1007 | 1008 | #:fail-when 1009 | (let* 1010 | ([keys (map (λ (v) (format "~a" v)) (syntax->datum #'(key ...)))] 1011 | [results (filter (λ (v) (not (member v keys))) 1012 | (get-enum-keys #'enum-name (syntax-e #'enum-name)))]) 1013 | (if (not (eq? results '())) 1014 | (with-syntax ([res results]) #'res) 1015 | #f)) 1016 | "missing cases in the enum" 1017 | 1018 | (with-syntax 1019 | ([(enum-vals ...) (map (λ (v) (get-enum-value #'enum-name (syntax-e #'enum-name) v)) 1020 | (syntax->datum #'(key ...)))] 1021 | [(key-str ...) (map (λ (v) (symbol->string v)) 1022 | (syntax->datum #'(key ...)))] ) 1023 | #'(~case test [enum-vals expr key-str] ...))] 1024 | ) 1025 | 1026 | (define-syntax-parser ~case-set 1027 | [(_ target:bound-usage test:expr 1028 | [key:number-literal value] ...) 1029 | #'(~case test [key (set target value)] ...)]) 1030 | 1031 | (define-syntax-parser ~begin-line 1032 | #:datum-literals (~cond locals expression ~when if set ~match-set ~match ~case-set) 1033 | [(_ (expression expr ...)) 1034 | #'`(tab 1035 | ,(expression expr ...) 1036 | ";\n")] 1037 | [(_ (set [x:bound-usage y] ...)) 1038 | #'`( 1039 | (tab 1040 | ,(expression (set x y)) 1041 | ";\n")...)] 1042 | [(_ (set x:bound-usage y)) 1043 | #'`( 1044 | (tab 1045 | ,(expression (set x y)) 1046 | ";\n"))] 1047 | [(_ x:expr) 1048 | #'x] ) 1049 | 1050 | (define-syntax-parser inc 1051 | [( _ x:scoped-binding) 1052 | #'`(tab 1053 | ,(expression (set x (+ x 1))) 1054 | ";\n" 1055 | )]) 1056 | 1057 | (define-syntax-parser ~begin 1058 | [(_ block-name:id expr ...+) 1059 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'block-name))) 1060 | #'`( 1061 | tab 1062 | "begin " 1063 | ,name 1064 | "\n" 1065 | inc-tab 1066 | ,(~begin-line expr) ... 1067 | dec-tab 1068 | tab 1069 | "end \n" 1070 | )] 1071 | [(_ expr ...) 1072 | #'`( 1073 | tab 1074 | "begin\n" 1075 | inc-tab 1076 | ,(~begin-line expr) ... 1077 | dec-tab 1078 | tab 1079 | "end \n" 1080 | )]) 1081 | 1082 | (define-syntax-parser locals 1083 | [(_ params:local-param ...) 1084 | #'`( 1085 | ( 1086 | tab 1087 | ,(push-binding params.name params.size-int params.arity-list) ... 1088 | ( 1089 | ,params.type 1090 | " " 1091 | ,params.size 1092 | " " 1093 | ,params.name 1094 | " " 1095 | ,params.default 1096 | ";\n") ...))]) 1097 | 1098 | (define-syntax-parser assign 1099 | [(_ [x:bound-usage y:expr] ...) 1100 | #'`( 1101 | ("assign " 1102 | ,x.compiled 1103 | " = " 1104 | ,(expression y) 1105 | ";\n") ... )] 1106 | [(_ x:bound-usage y:expr) 1107 | #'`("assign " 1108 | ,x.compiled 1109 | " = " 1110 | ,(expression y) 1111 | ";\n")]) 1112 | 1113 | (define-syntax-parser always-line 1114 | [(_ expr) 1115 | #'expr]) 1116 | 1117 | (define-syntax-parser always 1118 | #:datum-literals (* or) 1119 | [(_ (or sens:sensitivity rest:sensitivity ...) expr ...) 1120 | (printf "always\n") 1121 | (toggle-always-sens) 1122 | #'`( 1123 | tab 1124 | "always @(" 1125 | 1126 | ,sens.edge-type 1127 | " " 1128 | ,sens.compiled 1129 | ( 1130 | " or " 1131 | ,rest.edge-type 1132 | " " 1133 | ,rest.compiled 1134 | ) ... 1135 | ")\n" 1136 | inc-tab 1137 | ,(always-line expr) ... 1138 | dec-tab 1139 | ,(toggle-always-sens))] 1140 | [(_ (sens:sensitivity rest:sensitivity ...) expr ...) 1141 | (toggle-always-sens) 1142 | #'`( 1143 | tab 1144 | "always @(" 1145 | ,sens.edge-type 1146 | " " 1147 | ,sens.compiled 1148 | ( 1149 | " , " 1150 | ,rest.edge-type 1151 | " " 1152 | ,rest.compiled) ... 1153 | ")\n" 1154 | inc-tab 1155 | ,(always-line expr) ... 1156 | dec-tab 1157 | ,(toggle-always-sens) 1158 | )] 1159 | [(_ * expr ...) 1160 | #'`( 1161 | tab 1162 | "always @(*)\n" 1163 | inc-tab 1164 | ,(always-line expr) ... 1165 | dec-tab 1166 | )] 1167 | [(_ expr ...) 1168 | #'`( 1169 | tab 1170 | "always\n" 1171 | inc-tab 1172 | ,(always-line expr) ... 1173 | dec-tab 1174 | )] 1175 | ) 1176 | 1177 | (define-syntax-parser ~module-line 1178 | #:datum-literals (set vmod) 1179 | ;; [(_ mod-id (set [x:bound-usage y] ...)) 1180 | ;; (syntax-property 1181 | ;; #'`((tab 1182 | ;; ,(expression (set x y)) 1183 | ;; "a;\n") ...) 1184 | ;; 'module 1185 | ;; #'mod-id) 1186 | ;; ] 1187 | ;; [(_ mod-id (set x:bound-usage y)) 1188 | ;; (syntax-property 1189 | ;; #'`(tab 1190 | ;; ,(expression (set x y)) 1191 | ;; "b;\n") 1192 | ;; 'module 1193 | ;; #'mod-id) 1194 | ;; ] 1195 | [(_ mod-id (vmod m:id ~! p:module-param ... l:module-param ~!)) 1196 | 1197 | #:fail-unless (module-exists? #'m) 1198 | (format "the module '~a' doesn't exist" #'m (symbol->string (syntax-e #'m))) 1199 | 1200 | #:fail-unless 1201 | (andmap (λ (name) (module-has-port? #'m name)) 1202 | (syntax->datum #'(p.name ... l.name))) 1203 | (format "instantiation of module ~a contains invalid port names: ~a" 1204 | #'m 1205 | (filter (λ (name) (not (module-has-port? #'m name))) 1206 | (syntax->datum #'(p.name ... l.name)))) 1207 | 1208 | #:fail-unless 1209 | (andmap (λ (name) (member name (syntax->datum #'(p.name ... l.name)))) 1210 | (module-port-names #'m)) 1211 | (format "instantiation of module ~a is missing the following ports: ~a" 1212 | #'m 1213 | (filter 1214 | (λ (name) 1215 | (not (member name (syntax->datum #'(p.name ... l.name))))) 1216 | (module-port-names #'m))) 1217 | 1218 | 1219 | (with-syntax([m-name (symbol->string (syntax-e #'m))] 1220 | [i-name (symbol->string (syntax-e #'x))]) 1221 | (syntax-property 1222 | #'`( 1223 | ,m-name 1224 | " (\n" 1225 | inc-tab 1226 | ( 1227 | "." ,p.name "(" ,(expression p.value) "),\n" 1228 | ) ... 1229 | 1230 | "." ,l.name "(" ,(expression l.value) ")\n" 1231 | dec-tab 1232 | ");\n" 1233 | 1234 | ) 1235 | 'module 1236 | #'mod-id)) 1237 | ] 1238 | [(_ mod-id x) 1239 | (syntax-property #'x 'module #'mod-id)]) 1240 | 1241 | (define-syntax-parser function 1242 | [(_ (~optional [x (~optional y)]) 1243 | name-sym:id 1244 | ; output size 1245 | (p:function-param ...) 1246 | expression ...) 1247 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'name-sym))) 1248 | #:with size-int 1249 | (cond 1250 | [(and (attribute x) (attribute y)) 1251 | #'(+ (- x y) 1)] 1252 | [(attribute x) 1253 | #'x] 1254 | [else #'1]) 1255 | #:with size 1256 | (cond 1257 | [(and (attribute x) (attribute y)) 1258 | #'`("[" ,x ":" ,y "]")] 1259 | [(attribute x) 1260 | #'`("[" ,(- x 1) ":0" "]")] 1261 | [else #'""]) 1262 | (push-scoped-stack) 1263 | (add-module-function current-module (symbol->string (syntax-e #'name-sym)) 1264 | (syntax-e #'size-int)) 1265 | #'`( 1266 | "function " ,size " " ,name ";\n" 1267 | inc-tab 1268 | tab 1269 | ;push the name and size of the function as it is used 1270 | ;to set the return value. sticking to Verilog style for now. 1271 | ,(push-binding name size-int #f) 1272 | ,(push-binding p.name p.size-int p.arity-list) ... 1273 | (tab 1274 | ,p.direction 1275 | " " 1276 | ,p.size 1277 | " " 1278 | ,p.name 1279 | ";\n") ... 1280 | ,(~begin 1281 | expression ...) 1282 | dec-tab 1283 | ,(pop-scoped-stack) 1284 | "endfunction\n")]) 1285 | 1286 | (define out-ports (make-hash)) 1287 | (define (ensure-port-open filename) 1288 | ;todo: if already in hash, open for append 1289 | (if (hash-has-key? out-ports filename) 1290 | (let ([p (hash-ref out-ports filename)]) 1291 | (when (port-closed? p) 1292 | (hash-set! out-ports filename 1293 | (open-output-file #:mode 'binary #:exists 'append filename)))) 1294 | (hash-set! out-ports filename 1295 | (open-output-file #:mode 'binary #:exists 'replace filename)))) 1296 | 1297 | (define (get-port filename) 1298 | (ensure-port-open filename) 1299 | (hash-ref out-ports filename)) 1300 | 1301 | (define (ensure-ports-closed) 1302 | (for ([p (hash-values out-ports)]) 1303 | (close-output-port p))) 1304 | 1305 | (define-syntax-parser #%module-begin 1306 | [(_ exprs ...) 1307 | #'(#%plain-module-begin 1308 | exprs ... 1309 | ;todo: we need a nicer way of dealing with knowing when files are done with 1310 | (ensure-ports-closed) 1311 | )]) 1312 | 1313 | (define-syntax-parser test? 1314 | [(_ name) 1315 | (syntax-local-value #'name) 1316 | #'(void)]) 1317 | 1318 | (define-syntax-parser vmod 1319 | [(_ name-sym:id 1320 | (p:param ... last:param) ;inputs 1321 | expression ... ) 1322 | #:with name (datum->syntax this-syntax (symbol->string (syntax-e #'name-sym))) 1323 | (push-scoped-stack) 1324 | (set-current-module (symbol->string (syntax-e #'name-sym))) 1325 | (add-module (syntax-e #'name) 1326 | (map (λ (lst) ;todo: we don't need this anymore, really 1327 | (port-meta 1328 | (list-ref lst 0) 1329 | (list-ref lst 1) 1330 | (list-ref lst 2) 1331 | )) 1332 | (syntax->datum #'(p ... last)))) 1333 | (let* 1334 | ([fn (string-replace 1335 | (path->string (syntax-source-file-name #'name-sym)) ".rkt" ".v")]) 1336 | (with-syntax 1337 | ([nf (datum->syntax this-syntax 1338 | (build-path (syntax-source-directory this-syntax) fn))]) 1339 | (syntax-property 1340 | #'(begin 1341 | (ensure-port-open nf) 1342 | 1343 | (define-syntax name-sym 1344 | (module-meta name 1345 | (map (λ (lst) 1346 | (port-meta 1347 | (list-ref lst 0) 1348 | (list-ref lst 1) 1349 | (list-ref lst 2))) 1350 | (syntax->datum #'(p ... last))) '())) 1351 | 1352 | (provide name-sym) 1353 | 1354 | (code-gen nf 1355 | `( 1356 | ,(format "module ~a (\n" name) 1357 | inc-tab 1358 | ;port declarations 1359 | (tab 1360 | ,p.direction 1361 | " " 1362 | ,p.type 1363 | " " 1364 | ,p.size 1365 | " " 1366 | ,p.name 1367 | " " 1368 | ,p.default 1369 | ",\n") ... 1370 | 1371 | tab 1372 | ,last.direction 1373 | " " 1374 | ,last.type 1375 | " " 1376 | ,last.size 1377 | " " 1378 | ,last.name 1379 | " " 1380 | ,last.default 1381 | ");" 1382 | ,(push-binding p.name p.size-int) ... 1383 | ,(push-binding last.name last.size-int) 1384 | 1385 | "\n" 1386 | dec-tab 1387 | 1388 | ,(~module-line name-sym expression) ... 1389 | 1390 | "endmodule\n" 1391 | ,(pop-scoped-stack) 1392 | ))) 1393 | 'module 1394 | #'name-sym 1395 | )))]) 1396 | 1397 | (define-syntax-parser always-pos 1398 | [(_ clock exprs ...) 1399 | #'(always ([#:posedge clock]) (~begin exprs ...))]) 1400 | 1401 | (define-syntax-parser always-neg 1402 | [(_ clock exprs ...) 1403 | #'(always ([#:negedge clock]) (~begin exprs ...))]) 1404 | 1405 | (define-syntax-parser initial-begin 1406 | [(_ exprs ...) #'`("initial " ,(~begin exprs ...))]) 1407 | 1408 | (define (code-gen fn input) 1409 | (define tab 0) 1410 | (define (aux in) 1411 | (for ([sym in]) 1412 | (cond 1413 | [(or (string? sym) (integer? sym)) 1414 | (begin 1415 | (display sym (get-port fn)))] 1416 | [(eq? 'inc-tab sym) (set! tab (+ 1 tab))] 1417 | [(eq? 'tab sym) (display (make-string (* 2 tab) #\ ) (get-port fn))] 1418 | [(eq? 'dec-tab sym) (set! tab (- tab 1))] 1419 | [(eq? '() sym) '()] 1420 | [(list? sym) (aux sym)] 1421 | [(void? sym) '()] 1422 | [else (printf "unknown ~a\n" sym) ]))) 1423 | (aux input) 1424 | ) 1425 | 1426 | 1427 | (provide 1428 | 1429 | (all-defined-out) 1430 | (for-syntax (all-defined-out)) 1431 | (except-out (all-from-out syntax/parse/define) 1432 | define-syntax-parser) 1433 | (rename-out 1434 | [define-syntax-parser macro])) 1435 | 1436 | --------------------------------------------------------------------------------