#| -*-Scheme-*- Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. MIT/GNU Scheme is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. MIT/GNU Scheme is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with MIT/GNU Scheme; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. |# ;;;; Major Mode for VHDL Programs (define-command vhdl-mode "Enter VHDL mode." () (lambda () (set-current-major-mode! (ref-mode-object vhdl)))) (define-major-mode vhdl fundamental "VHDL" "Major mode specialized for editing VHDL code. \\{vhdl}" (lambda (buffer) (local-set-variable! syntax-table vhdl-mode:syntax-table buffer) (local-set-variable! syntax-ignore-comments-backwards #f buffer) (local-set-variable! comment-column 40 buffer) (local-set-variable! comment-locator-hook vhdl-comment-locate buffer) (local-set-variable! comment-indent-hook vhdl-comment-indentation buffer) (local-set-variable! comment-start "-- " buffer) (local-set-variable! comment-end "" buffer) (standard-alternate-paragraph-style! buffer) (local-set-variable! indent-line-procedure (ref-command keyparser-indent-line) buffer) (local-set-variable! definition-start vhdl-defun-start-regexp buffer) (local-set-variable! require-final-newline #t buffer) (local-set-variable! keyparser-description vhdl-description buffer) (local-set-variable! keyword-table vhdl-keyword-table buffer) (local-set-variable! local-abbrev-table (ref-variable vhdl-mode-abbrev-table buffer) buffer) (event-distributor/invoke! (ref-variable vhdl-mode-hook buffer) buffer))) (define vhdl-mode:syntax-table (let ((syntax-table (make-char-syntax-table))) (for-each (lambda (char) (set-char-syntax! syntax-table char "_")) (string->list "_.#+")) (for-each (lambda (char) (set-char-syntax! syntax-table char ".")) (string->list "*/&|<>=$%")) (set-char-syntax! syntax-table #\\ "\"") (set-char-syntax! syntax-table #\' "\"") (set-char-syntax! syntax-table #\- "_ 56") (set-char-syntax! syntax-table #\newline ">") syntax-table)) (define-key 'vhdl #\linefeed 'reindent-then-newline-and-indent) (define-key 'vhdl #\rubout 'backward-delete-char-untabify) (define-key 'vhdl #\tab 'keyparser-indent-line) (define-key 'vhdl #\c-m-\\ 'keyparser-indent-region) (define-key 'vhdl #\) 'lisp-insert-paren) (define-key 'vhdl #\] 'lisp-insert-paren) (define-key 'vhdl #\} 'lisp-insert-paren) (define-key 'vhdl #\m-tab 'complete-keyword) ;;;; Syntax Description (define (vhdl-comment-locate mark) (let ((state (parse-partial-sexp mark (line-end mark 0)))) (and (parse-state-in-comment? state) (vhdl-comment-match-start (parse-state-comment-start state)) (cons (re-match-start 0) (re-match-end 0))))) (define (vhdl-comment-match-start mark) (re-match-forward "--+[ \t]*" mark)) (define (vhdl-comment-indentation mark) (let ((column (cond ((match-forward "----" mark) 0) ((match-forward "---" mark) (keyparser-compute-indentation mark #t)) ((let ((s.e (let ((ls (line-start mark -1))) (and ls (vhdl-comment-locate ls))))) (and s.e (mark-column (car s.e))))) (else (ref-variable comment-column mark))))) (if (within-indentation? mark) column (max (+ (mark-column (horizontal-space-start mark)) 1) column)))) (define vhdl-defun-start-regexp (string-append "^" (regexp-group "architecture" "configuration" "entity" "library" "package" "use") (regexp-group "[^a-zA-Z0-9_]" "$"))) (define vhdl-keyword-table (alist->string-table (map list '("abs" "access" "after" "alias" "all" "and" "architecture" "array" "assert" "attribute" "begin" "block" "body" "buffer" "bus" "case" "component" "configuration" "constant" "disconnect" "downto" "else" "elsif" "end" "entity" "exit" "file" "for" "function" "generate" "generic" "group" "guarded" "if" "impure" "in" "inertial" "inout" "is" "label" "library" "linkage" "literal" "loop" "map" "mod" "nand" "new" "next" "nor" "not" "null" "of" "on" "open" "or" "others" "out" "package" "port" "postponed" "procedure" "process" "pure" "range" "record" "register" "reject" "rem" "report" "return" "rol" "ror" "select" "severity" "signal" "shared" "sla" "sll" "sra" "srl" "subtype" "then" "to" "transport" "type" "unaffected" "units" "until" "use" "variable" "wait" "when" "while" "with" "xnor" "xor")) #f)) (define (continued-header-indent mark) (+ (mark-indentation mark) (ref-variable vhdl-continued-header-offset mark))) (define (continued-statement-indent mark) (+ (mark-indentation mark) (ref-variable vhdl-continued-statement-offset mark))) (define comatch:skip-whitespace (comatch:general (lambda (start end) (let loop ((start start)) (let ((start (skip-chars-forward " \t\f\n" start end))) (if (match-forward "--" start end) (let ((le (line-end start 0))) (and (mark<= le end) (loop le))) start)))))) (define comatch:identifier-end (comatch:general (lambda (start end) (and (re-match-forward "[^a-zA-Z0-9_]\\|$" start end) start)))) (define comatch:identifier (comatch:append comatch:skip-whitespace (comatch:regexp "[a-zA-Z][a-zA-Z0-9_]*") comatch:identifier-end)) (define (comatch:keyword keyword) (comatch:append comatch:skip-whitespace (comatch:string keyword) comatch:identifier-end)) (define (comatch:matched-sexp comatcher) (comatch:append comatch:skip-whitespace (comatch:and comatcher comatch:sexp))) (define comatch:list (comatch:matched-sexp (comatch:char #\())) (define comatch:name (let ((id-or-string (comatch:or comatch:identifier (comatch:matched-sexp (comatch:char #\"))))) (comatch:append id-or-string (comatch:* (comatch:append comatch:skip-whitespace (comatch:or (comatch:append (comatch:char #\.) (comatch:or id-or-string (comatch:matched-sexp (comatch:char #\')))) comatch:list (comatch:append (comatch:? (comatch:matched-sexp (comatch:char #\[))) (comatch:char #\') comatch:identifier))))))) (define comatch:for-header:control (comatch:append comatch:identifier (comatch:keyword "in"))) (define comatch:for-header:component (comatch:append comatch:identifier (comatch:* (comatch:append comatch:skip-whitespace (comatch:char #\,) comatch:identifier)) comatch:skip-whitespace (comatch:char #\:))) (define comatch:for-header:block (comatch:not (comatch:or comatch:for-header:control comatch:for-header:component))) (define ((parse-forward-past search) start end) (let loop ((start start) (state #f)) (let ((mark (search start end))) (and mark (let ((state (parse-partial-sexp start mark #f #f state))) (if (in-char-syntax-structure? state) (loop mark state) mark)))))) (define (parse-forward-past-char char) (parse-forward-past (lambda (start end) (char-search-forward char start end #f)))) (define parse-forward-past-semicolon (parse-forward-past-char #\;)) (define (parse-forward-past-token token) (parse-forward-past (let ((regexp (string-append (regexp-group "[^a-zA-Z0-9_]" "^") token (regexp-group "[^a-zA-Z0-9_]" "$")))) (lambda (start end) (re-search-forward regexp start end))))) (define parse-forward-past-is (parse-forward-past-token "is")) (define parse-forward-past-then (parse-forward-past-token "then")) (define parse-forward-past-=> (parse-forward-past-token "=>")) (define (parse-forward-noop start end) end start) (define (parse-comatch comatcher) (lambda (start end) (comatch-apply comatcher start end))) (define parse-forward-past-name (parse-comatch comatch:name)) (define (trailing-keyword-matcher keyword . keywords) (let ((parser (parse-forward-past-token (apply regexp-group keyword keywords)))) (lambda (mark stack) stack (let ((m (parser mark (group-end mark)))) (and m (let ((s (backward-one-sexp m))) (and s (let ((e (forward-one-sexp s))) (and e (string-ci=? keyword (extract-string s e)) m))))))))) (define vhdl-description (make-keyparser-description 'FIND-STATEMENT-END parse-forward-past-semicolon 'INDENT-CONTINUED-STATEMENT continued-statement-indent 'INDENT-CONTINUED-COMMENT (lambda (mark) (mark-column (or (vhdl-comment-match-start mark) mark))))) (define-keyparser-statement-leader 'LABEL vhdl-description "[a-zA-Z][a-zA-Z0-9_]*\\s *:" parse-forward-noop) (define (define-matched-keyword pkey keyword match-header parse-header end . rest) (define-keyparser-pattern pkey vhdl-description (cons* (standard-keyword keyword match-header parse-header) end rest))) (define (define-standard-keyword pkey keyword parse-header end . rest) (apply define-matched-keyword pkey keyword #f parse-header end rest)) (define (standard-keyword keyword match-header parse-header . rest) (apply make-keyparser-fragment 'KEYWORD keyword 'MATCH-HEADER match-header 'PARSE-HEADER parse-header 'INDENT-HEADER continued-header-indent 'PARSE-BODY keyparse-forward 'INDENT-BODY continued-statement-indent rest)) (define begin-frag (standard-keyword "begin" #f parse-forward-noop)) (define end-frag (standard-keyword "end" #f parse-forward-past-semicolon)) (define-standard-keyword 'ARCHITECTURE "architecture" parse-forward-past-is end-frag begin-frag) (define-standard-keyword 'BLOCK "block" (parse-comatch (comatch:append (comatch:? comatch:list) (comatch:? (comatch:keyword "is")))) end-frag begin-frag) (define-standard-keyword 'CASE "case" parse-forward-past-is end-frag) (define-standard-keyword 'COMPONENT "component" (parse-comatch (comatch:append comatch:identifier (comatch:? (comatch:keyword "is")))) end-frag begin-frag) (define-standard-keyword 'CONFIGURATION "configuration" parse-forward-past-is end-frag) (define-standard-keyword 'ENTITY "entity" parse-forward-past-is end-frag begin-frag) (define-standard-keyword 'FUNCTION "function" parse-forward-past-is end-frag begin-frag) (define-standard-keyword '(FUNCTION IMPURE) "impure" parse-forward-past-is end-frag begin-frag) (define-standard-keyword '(FUNCTION PURE) "pure" parse-forward-past-is end-frag begin-frag) (define-matched-keyword '(GENERATE FOR) "for" (let ((parser (trailing-keyword-matcher "generate" "loop"))) (lambda (mark stack) (let ((mark (comatch-apply comatch:for-header:control mark))) (and mark (parser mark stack))))) parse-forward-noop end-frag) (define-matched-keyword '(GENERATE IF) "if" (trailing-keyword-matcher "generate" "then") parse-forward-noop end-frag) (define-matched-keyword 'IF "if" (trailing-keyword-matcher "then" "generate") parse-forward-noop end-frag (standard-keyword "elsif" #f parse-forward-past-then) (standard-keyword "else" #f parse-forward-noop)) (define-standard-keyword 'LOOP "loop" parse-forward-noop end-frag) (define-matched-keyword '(LOOP FOR) "for" (let ((parser (trailing-keyword-matcher "loop" "generate"))) (lambda (mark stack) (let ((mark (comatch-apply comatch:for-header:control mark))) (and mark (parser mark stack))))) parse-forward-noop end-frag) (define-standard-keyword '(LOOP WHILE) "while" (parse-forward-past-token "loop") end-frag) (define-standard-keyword 'PACKAGE "package" parse-forward-past-is end-frag) (define-standard-keyword 'PROCEDURE "procedure" parse-forward-past-is end-frag begin-frag) (define-standard-keyword 'PROCESS "process" (parse-comatch (comatch:append (comatch:? comatch:list) (comatch:? (comatch:keyword "is")))) end-frag begin-frag) (define-standard-keyword '(PROCESS POSTPONED) "postponed" (parse-comatch (comatch:append (comatch:keyword "process") (comatch:? comatch:list) (comatch:? (comatch:keyword "is")))) end-frag begin-frag) (define-standard-keyword 'RECORD "record" parse-forward-noop end-frag) (define-standard-keyword 'UNITS "range" (parse-forward-past-token "units") end-frag) (define-standard-keyword 'WHEN "when" parse-forward-past-=> (standard-keyword "end" #f parse-forward-past-semicolon 'POP-CONTAINER 1) (standard-keyword "when" #f parse-forward-past-=>)) (define-standard-keyword 'WITH "with" (parse-forward-past-token "select") #f) (define-matched-keyword 'COMPONENT-SPECIFICATION "for" (lambda (mark stack) (let ((mark (comatch-apply comatch:for-header:component mark))) (and mark (in-configuration? stack) mark))) parse-forward-past-name end-frag) (define-matched-keyword 'CONFIGURATION-SPECIFICATION "for" (lambda (mark stack) (let ((mark (comatch-apply comatch:for-header:component mark))) (and mark (not (in-configuration? stack)) mark))) parse-forward-past-name #f) (define (in-configuration? stack) (any (lambda (entry) (equal? 'CONFIGURATION (keyparser-stack-entry/keyword entry))) stack)) (define-matched-keyword 'BLOCK-CONFIGURATION "for" (lambda (mark stack) stack (and (comatch-apply comatch:for-header:block mark) mark)) parse-forward-noop end-frag)