1#| -*-Scheme-*- 2 3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts 6 Institute of Technology 7 8This file is part of MIT/GNU Scheme. 9 10MIT/GNU Scheme is free software; you can redistribute it and/or modify 11it under the terms of the GNU General Public License as published by 12the Free Software Foundation; either version 2 of the License, or (at 13your option) any later version. 14 15MIT/GNU Scheme is distributed in the hope that it will be useful, but 16WITHOUT ANY WARRANTY; without even the implied warranty of 17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18General Public License for more details. 19 20You should have received a copy of the GNU General Public License 21along with MIT/GNU Scheme; if not, write to the Free Software 22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 23USA. 24 25|# 26 27;;;; Major Mode for VHDL Programs 28 29(declare (usual-integrations)) 30 31(define-command vhdl-mode 32 "Enter VHDL mode." 33 () 34 (lambda () (set-current-major-mode! (ref-mode-object vhdl)))) 35 36(define-major-mode vhdl fundamental "VHDL" 37 "Major mode specialized for editing VHDL code. 38 39\\{vhdl}" 40 (lambda (buffer) 41 (local-set-variable! syntax-table vhdl-mode:syntax-table buffer) 42 (local-set-variable! syntax-ignore-comments-backwards #f buffer) 43 (local-set-variable! comment-column 40 buffer) 44 (local-set-variable! comment-locator-hook vhdl-comment-locate buffer) 45 (local-set-variable! comment-indent-hook vhdl-comment-indentation buffer) 46 (local-set-variable! comment-start "-- " buffer) 47 (local-set-variable! comment-end "" buffer) 48 (standard-alternate-paragraph-style! buffer) 49 (local-set-variable! indent-line-procedure 50 (ref-command keyparser-indent-line) 51 buffer) 52 (local-set-variable! definition-start vhdl-defun-start-regexp buffer) 53 (local-set-variable! require-final-newline #t buffer) 54 (local-set-variable! keyparser-description vhdl-description buffer) 55 (local-set-variable! keyword-table vhdl-keyword-table buffer) 56 (local-set-variable! local-abbrev-table 57 (ref-variable vhdl-mode-abbrev-table buffer) 58 buffer) 59 (event-distributor/invoke! (ref-variable vhdl-mode-hook buffer) 60 buffer))) 61 62(define vhdl-mode:syntax-table 63 (let ((syntax-table (make-char-syntax-table))) 64 (for-each (lambda (char) (set-char-syntax! syntax-table char "_")) 65 (string->list "_.#+")) 66 (for-each (lambda (char) (set-char-syntax! syntax-table char ".")) 67 (string->list "*/&|<>=$%")) 68 (set-char-syntax! syntax-table #\\ "\"") 69 (set-char-syntax! syntax-table #\' "\"") 70 (set-char-syntax! syntax-table #\- "_ 56") 71 (set-char-syntax! syntax-table #\newline ">") 72 syntax-table)) 73 74(define-key 'vhdl #\linefeed 'reindent-then-newline-and-indent) 75(define-key 'vhdl #\rubout 'backward-delete-char-untabify) 76(define-key 'vhdl #\tab 'keyparser-indent-line) 77(define-key 'vhdl #\c-m-\\ 'keyparser-indent-region) 78(define-key 'vhdl #\) 'lisp-insert-paren) 79(define-key 'vhdl #\] 'lisp-insert-paren) 80(define-key 'vhdl #\} 'lisp-insert-paren) 81(define-key 'vhdl #\m-tab 'complete-keyword) 82 83;;;; Syntax Description 84 85(define (vhdl-comment-locate mark) 86 (let ((state (parse-partial-sexp mark (line-end mark 0)))) 87 (and (parse-state-in-comment? state) 88 (vhdl-comment-match-start (parse-state-comment-start state)) 89 (cons (re-match-start 0) (re-match-end 0))))) 90 91(define (vhdl-comment-match-start mark) 92 (re-match-forward "--+[ \t]*" mark)) 93 94(define (vhdl-comment-indentation mark) 95 (let ((column 96 (cond ((match-forward "----" mark) 97 0) 98 ((match-forward "---" mark) 99 (keyparser-compute-indentation mark #t)) 100 ((let ((s.e 101 (let ((ls (line-start mark -1))) 102 (and ls 103 (vhdl-comment-locate ls))))) 104 (and s.e 105 (mark-column (car s.e))))) 106 (else 107 (ref-variable comment-column mark))))) 108 (if (within-indentation? mark) 109 column 110 (max (+ (mark-column (horizontal-space-start mark)) 1) 111 column)))) 112 113(define vhdl-defun-start-regexp 114 (string-append 115 "^" 116 (regexp-group "architecture" "configuration" "entity" 117 "library" "package" "use") 118 (regexp-group "[^a-zA-Z0-9_]" "$"))) 119 120(define vhdl-keyword-table 121 (alist->string-table 122 (map list 123 '("abs" "access" "after" "alias" "all" "and" "architecture" "array" 124 "assert" "attribute" "begin" "block" "body" "buffer" "bus" "case" 125 "component" "configuration" "constant" "disconnect" "downto" "else" 126 "elsif" "end" "entity" "exit" "file" "for" "function" "generate" 127 "generic" "group" "guarded" "if" "impure" "in" "inertial" "inout" 128 "is" "label" "library" "linkage" "literal" "loop" "map" "mod" "nand" 129 "new" "next" "nor" "not" "null" "of" "on" "open" "or" "others" "out" 130 "package" "port" "postponed" "procedure" "process" "pure" "range" 131 "record" "register" "reject" "rem" "report" "return" "rol" "ror" 132 "select" "severity" "signal" "shared" "sla" "sll" "sra" "srl" 133 "subtype" "then" "to" "transport" "type" "unaffected" "units" "until" 134 "use" "variable" "wait" "when" "while" "with" "xnor" "xor")) 135 #f)) 136 137(define (continued-header-indent mark) 138 (+ (mark-indentation mark) 139 (ref-variable vhdl-continued-header-offset mark))) 140 141(define (continued-statement-indent mark) 142 (+ (mark-indentation mark) 143 (ref-variable vhdl-continued-statement-offset mark))) 144 145(define comatch:skip-whitespace 146 (comatch:general 147 (lambda (start end) 148 (let loop ((start start)) 149 (let ((start (skip-chars-forward " \t\f\n" start end))) 150 (if (match-forward "--" start end) 151 (let ((le (line-end start 0))) 152 (and (mark<= le end) 153 (loop le))) 154 start)))))) 155 156(define comatch:identifier-end 157 (comatch:general 158 (lambda (start end) 159 (and (re-match-forward "[^a-zA-Z0-9_]\\|$" start end) 160 start)))) 161 162(define comatch:identifier 163 (comatch:append comatch:skip-whitespace 164 (comatch:regexp "[a-zA-Z][a-zA-Z0-9_]*") 165 comatch:identifier-end)) 166 167(define (comatch:keyword keyword) 168 (comatch:append comatch:skip-whitespace 169 (comatch:string keyword) 170 comatch:identifier-end)) 171 172(define (comatch:matched-sexp comatcher) 173 (comatch:append comatch:skip-whitespace 174 (comatch:and comatcher 175 comatch:sexp))) 176 177(define comatch:list 178 (comatch:matched-sexp (comatch:char #\())) 179 180(define comatch:name 181 (let ((id-or-string 182 (comatch:or comatch:identifier 183 (comatch:matched-sexp (comatch:char #\"))))) 184 (comatch:append 185 id-or-string 186 (comatch:* 187 (comatch:append 188 comatch:skip-whitespace 189 (comatch:or (comatch:append 190 (comatch:char #\.) 191 (comatch:or id-or-string 192 (comatch:matched-sexp (comatch:char #\')))) 193 comatch:list 194 (comatch:append 195 (comatch:? (comatch:matched-sexp (comatch:char #\[))) 196 (comatch:char #\') 197 comatch:identifier))))))) 198 199(define comatch:for-header:control 200 (comatch:append comatch:identifier 201 (comatch:keyword "in"))) 202 203(define comatch:for-header:component 204 (comatch:append comatch:identifier 205 (comatch:* 206 (comatch:append comatch:skip-whitespace 207 (comatch:char #\,) 208 comatch:identifier)) 209 comatch:skip-whitespace 210 (comatch:char #\:))) 211 212(define comatch:for-header:block 213 (comatch:not (comatch:or comatch:for-header:control 214 comatch:for-header:component))) 215 216(define ((parse-forward-past search) start end) 217 (let loop ((start start) (state #f)) 218 (let ((mark (search start end))) 219 (and mark 220 (let ((state (parse-partial-sexp start mark #f #f state))) 221 (if (in-char-syntax-structure? state) 222 (loop mark state) 223 mark)))))) 224 225(define (parse-forward-past-char char) 226 (parse-forward-past 227 (lambda (start end) (char-search-forward char start end #f)))) 228 229(define parse-forward-past-semicolon 230 (parse-forward-past-char #\;)) 231 232(define (parse-forward-past-token token) 233 (parse-forward-past 234 (let ((regexp 235 (string-append (regexp-group "[^a-zA-Z0-9_]" "^") 236 token 237 (regexp-group "[^a-zA-Z0-9_]" "$")))) 238 (lambda (start end) 239 (re-search-forward regexp start end))))) 240 241(define parse-forward-past-is 242 (parse-forward-past-token "is")) 243 244(define parse-forward-past-then 245 (parse-forward-past-token "then")) 246 247(define parse-forward-past-=> 248 (parse-forward-past-token "=>")) 249 250(define (parse-forward-noop start end) 251 end 252 start) 253 254(define (parse-comatch comatcher) 255 (lambda (start end) 256 (comatch-apply comatcher start end))) 257 258(define parse-forward-past-name 259 (parse-comatch comatch:name)) 260 261(define (trailing-keyword-matcher keyword . keywords) 262 (let ((parser 263 (parse-forward-past-token (apply regexp-group keyword keywords)))) 264 (lambda (mark stack) 265 stack 266 (let ((m (parser mark (group-end mark)))) 267 (and m 268 (let ((s (backward-one-sexp m))) 269 (and s 270 (let ((e (forward-one-sexp s))) 271 (and e 272 (string-ci=? keyword (extract-string s e)) 273 m))))))))) 274 275(define vhdl-description 276 (make-keyparser-description 277 'FIND-STATEMENT-END 278 parse-forward-past-semicolon 279 'INDENT-CONTINUED-STATEMENT 280 continued-statement-indent 281 'INDENT-CONTINUED-COMMENT 282 (lambda (mark) 283 (mark-column (or (vhdl-comment-match-start mark) mark))))) 284 285(define-keyparser-statement-leader 'LABEL vhdl-description 286 "[a-zA-Z][a-zA-Z0-9_]*\\s *:" 287 parse-forward-noop) 288 289(define (define-matched-keyword pkey keyword match-header parse-header end 290 . rest) 291 (define-keyparser-pattern pkey vhdl-description 292 (cons* (standard-keyword keyword match-header parse-header) 293 end 294 rest))) 295 296(define (define-standard-keyword pkey keyword parse-header end . rest) 297 (apply define-matched-keyword pkey keyword #f parse-header end rest)) 298 299(define (standard-keyword keyword match-header parse-header . rest) 300 (apply make-keyparser-fragment 301 'KEYWORD keyword 302 'MATCH-HEADER match-header 303 'PARSE-HEADER parse-header 304 'INDENT-HEADER continued-header-indent 305 'PARSE-BODY keyparse-forward 306 'INDENT-BODY continued-statement-indent 307 rest)) 308 309(define begin-frag (standard-keyword "begin" #f parse-forward-noop)) 310(define end-frag (standard-keyword "end" #f parse-forward-past-semicolon)) 311 312(define-standard-keyword 'ARCHITECTURE "architecture" 313 parse-forward-past-is 314 end-frag 315 begin-frag) 316 317(define-standard-keyword 'BLOCK "block" 318 (parse-comatch 319 (comatch:append (comatch:? comatch:list) 320 (comatch:? (comatch:keyword "is")))) 321 end-frag 322 begin-frag) 323 324(define-standard-keyword 'CASE "case" 325 parse-forward-past-is 326 end-frag) 327 328(define-standard-keyword 'COMPONENT "component" 329 (parse-comatch 330 (comatch:append comatch:identifier 331 (comatch:? (comatch:keyword "is")))) 332 end-frag 333 begin-frag) 334 335(define-standard-keyword 'CONFIGURATION "configuration" 336 parse-forward-past-is 337 end-frag) 338 339(define-standard-keyword 'ENTITY "entity" 340 parse-forward-past-is 341 end-frag 342 begin-frag) 343 344(define-standard-keyword 'FUNCTION "function" 345 parse-forward-past-is 346 end-frag 347 begin-frag) 348 349(define-standard-keyword '(FUNCTION IMPURE) "impure" 350 parse-forward-past-is 351 end-frag 352 begin-frag) 353 354(define-standard-keyword '(FUNCTION PURE) "pure" 355 parse-forward-past-is 356 end-frag 357 begin-frag) 358 359(define-matched-keyword '(GENERATE FOR) "for" 360 (let ((parser (trailing-keyword-matcher "generate" "loop"))) 361 (lambda (mark stack) 362 (let ((mark (comatch-apply comatch:for-header:control mark))) 363 (and mark 364 (parser mark stack))))) 365 parse-forward-noop 366 end-frag) 367 368(define-matched-keyword '(GENERATE IF) "if" 369 (trailing-keyword-matcher "generate" "then") 370 parse-forward-noop 371 end-frag) 372 373(define-matched-keyword 'IF "if" 374 (trailing-keyword-matcher "then" "generate") 375 parse-forward-noop 376 end-frag 377 (standard-keyword "elsif" #f parse-forward-past-then) 378 (standard-keyword "else" #f parse-forward-noop)) 379 380(define-standard-keyword 'LOOP "loop" 381 parse-forward-noop 382 end-frag) 383 384(define-matched-keyword '(LOOP FOR) "for" 385 (let ((parser (trailing-keyword-matcher "loop" "generate"))) 386 (lambda (mark stack) 387 (let ((mark (comatch-apply comatch:for-header:control mark))) 388 (and mark 389 (parser mark stack))))) 390 parse-forward-noop 391 end-frag) 392 393(define-standard-keyword '(LOOP WHILE) "while" 394 (parse-forward-past-token "loop") 395 end-frag) 396 397(define-standard-keyword 'PACKAGE "package" 398 parse-forward-past-is 399 end-frag) 400 401(define-standard-keyword 'PROCEDURE "procedure" 402 parse-forward-past-is 403 end-frag 404 begin-frag) 405 406(define-standard-keyword 'PROCESS "process" 407 (parse-comatch 408 (comatch:append (comatch:? comatch:list) 409 (comatch:? (comatch:keyword "is")))) 410 end-frag 411 begin-frag) 412 413(define-standard-keyword '(PROCESS POSTPONED) "postponed" 414 (parse-comatch 415 (comatch:append (comatch:keyword "process") 416 (comatch:? comatch:list) 417 (comatch:? (comatch:keyword "is")))) 418 end-frag 419 begin-frag) 420 421(define-standard-keyword 'RECORD "record" 422 parse-forward-noop 423 end-frag) 424 425(define-standard-keyword 'UNITS "range" 426 (parse-forward-past-token "units") 427 end-frag) 428 429(define-standard-keyword 'WHEN "when" 430 parse-forward-past-=> 431 (standard-keyword "end" #f parse-forward-past-semicolon 'POP-CONTAINER 1) 432 (standard-keyword "when" #f parse-forward-past-=>)) 433 434(define-standard-keyword 'WITH "with" 435 (parse-forward-past-token "select") 436 #f) 437 438(define-matched-keyword 'COMPONENT-SPECIFICATION "for" 439 (lambda (mark stack) 440 (let ((mark (comatch-apply comatch:for-header:component mark))) 441 (and mark 442 (in-configuration? stack) 443 mark))) 444 parse-forward-past-name 445 end-frag) 446 447(define-matched-keyword 'CONFIGURATION-SPECIFICATION "for" 448 (lambda (mark stack) 449 (let ((mark (comatch-apply comatch:for-header:component mark))) 450 (and mark 451 (not (in-configuration? stack)) 452 mark))) 453 parse-forward-past-name 454 #f) 455 456(define (in-configuration? stack) 457 (there-exists? stack 458 (lambda (entry) 459 (equal? 'CONFIGURATION (keyparser-stack-entry/keyword entry))))) 460 461(define-matched-keyword 'BLOCK-CONFIGURATION "for" 462 (lambda (mark stack) 463 stack 464 (and (comatch-apply comatch:for-header:block mark) 465 mark)) 466 parse-forward-noop 467 end-frag)