From: Chris Hanson Date: Mon, 10 Mar 1997 05:40:35 +0000 (+0000) Subject: * Create interface to allow keyparser description to be built up X-Git-Tag: 20090517-FFI~5237 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1d74e00446db9b7d3657f3863344df9018bc4d1c;p=mit-scheme.git * Create interface to allow keyparser description to be built up incrementally. This aids in development and debugging of descriptions. * Modify indentation computation so that comment lines are indented properly. Previously they were indented just like code lines. * Change definition of MATCH-HEADER so that it accepts the keyparser stack as an argument. Also open up the stack-entry abstraction. These changes allow MATCH-HEADER to use contextual information in its decision-making process. * Fix some problems in the VHDL implementation. Use new MATCH-HEADER extension to distinguish two cases of FOR keyword that are otherwise syntactically identical. --- diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 38ebb0f75..62d208081 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.208 1997/03/07 23:34:48 cph Exp $ +$Id: edwin.pkg,v 1.209 1997/03/10 05:40:35 cph Exp $ Copyright (c) 1989-97 Massachusetts Institute of Technology @@ -1824,6 +1824,10 @@ MIT in each case. |# (files "keyparse") (parent (edwin)) (export (edwin) + define-keyparser-pattern + define-keyparser-statement-leader + delete-keyparser-pattern + delete-keyparser-statement-leader edwin-command$complete-keyword edwin-command$keyparser-indent-line edwin-command$keyparser-indent-region @@ -1834,6 +1838,23 @@ MIT in each case. |# keyparse-partial keyparser-compute-indentation keyparser-compute-indentation-1 + keyparser-fragment/indent-body + keyparser-fragment/indent-header + keyparser-fragment/keyword + keyparser-fragment/match-header + keyparser-fragment/parse-body + keyparser-fragment/parse-header + keyparser-fragment/pop-container + keyparser-fragment? + keyparser-patterns + keyparser-stack-entry/end? + keyparser-stack-entry/fragment + keyparser-stack-entry/index + keyparser-stack-entry/keyword + keyparser-stack-entry/pattern + keyparser-stack-entry/start + keyparser-stack-entry? + keyparser-statement-leaders make-keyparser-description make-keyparser-fragment)) diff --git a/v7/src/edwin/keyparse.scm b/v7/src/edwin/keyparse.scm index 0b24e5739..c52b5e577 100644 --- a/v7/src/edwin/keyparse.scm +++ b/v7/src/edwin/keyparse.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: keyparse.scm,v 1.1 1997/03/07 23:31:15 cph Exp $ +;;; $Id: keyparse.scm,v 1.2 1997/03/10 05:40:02 cph Exp $ ;;; ;;; Copyright (c) 1996-97 Massachusetts Institute of Technology ;;; @@ -51,7 +51,7 @@ (conc-name description/)) ;; A list of patterns describing the syntax structures recognized by ;; this language. The patterns are matched left to right. - (patterns #f read-only #t) + (patterns '()) ;; A list of "leaders" that can appear at the beginning of a ;; statement. These leaders are considered to be part of the @@ -62,7 +62,7 @@ ;; the leader. The procedure gets two arguments: the result of the ;; regexp match and the END mark, and returns a mark pointing at the ;; end of the leader, or #F if the leader doesn't end by END. - (statement-leaders #f read-only #t) + (statement-leaders '()) ;; A procedure that finds the end of a simple statement given two ;; marks: the beginning of the statement and the end of the parse. @@ -76,6 +76,41 @@ ;; continuation lines of that object. (indent-continued-statement #f read-only #t) (indent-continued-comment #f read-only #t)) + +(define (define-keyparser-pattern keyword description fragments) + (let ((patterns (description/patterns description))) + (let ((entry (assoc keyword patterns))) + (if entry + (set-cdr! entry fragments) + (set-description/patterns! + description + (append! patterns (list (cons keyword fragments)))))))) + +(define (delete-keyparser-pattern keyword description) + (set-description/patterns! + description + (del-assoc! keyword (description/patterns description)))) + +(define (define-keyparser-statement-leader name description regexp parser) + (let ((leaders (description/statement-leaders description)) + (regexp + (if (compiled-regexp? regexp) + (re-compile-pattern regexp #f) + regexp))) + (let ((entry (assoc name leaders))) + (if entry + (set-cdr! entry (list regexp parser)) + (set-description/statement-leaders! + description + (append! leaders (list (list name regexp parser)))))))) + +(define (delete-keyparser-statement-leader name description) + (set-description/statement-leaders! + description + (del-assoc! name (description/statement-leaders description)))) + +(define keyparser-patterns description/patterns) +(define keyparser-statement-leaders description/statement-leaders) ;; A structure pattern is a list of pattern fragments, which define ;; the parts of the structure. The START and END define how the @@ -87,9 +122,11 @@ ;; continations are "ELSIF THEN " and "ELSE ;; ". -(define-integrable (pattern/start pattern) (car pattern)) -(define-integrable (pattern/end pattern) (cadr pattern)) -(define-integrable (pattern/continuations pattern) (cddr pattern)) +(define-integrable (pattern/keyword pattern) (car pattern)) +(define-integrable (pattern/fragments pattern) (cdr pattern)) +(define-integrable (pattern/start pattern) (cadr pattern)) +(define-integrable (pattern/end pattern) (caddr pattern)) +(define-integrable (pattern/current-level pattern) (cddr pattern)) ;; A pattern fragment is a header followed by an indented body. (This ;; is sometimes called a "hanging indentation" style.) The pattern @@ -97,9 +134,14 @@ ;; it is identified, how much to indent the header should it span ;; multiple lines, and how to parse and indent the body. -(define-structure (fragment +(define-structure (keyparser-fragment (keyword-constructor make-keyparser-fragment) - (conc-name fragment/)) + (conc-name keyparser-fragment/) + (print-procedure + (standard-unparser-method 'KEYPARSER-FRAGMENT + (lambda (fragment port) + (write-char #\space port) + (write (keyparser-fragment/keyword fragment) port))))) ;; Keyword that introduces the structure. (keyword #f read-only #t) @@ -142,13 +184,41 @@ "Top-level description of buffer's syntax, for use by keyword parser." #f) +(define-variable keyword-table + "String table of keywords, to control keyword-completion. +See \\[complete-keyword]." + #f) + +(define-command complete-keyword + "Perform completion on keyword preceding point." + () + (lambda () + (let ((end + (let ((point (current-point))) + (let ((end (group-end point))) + (or (re-match-forward "\\sw+" point end #f) + (and (mark< (group-start point) point) + (re-match-forward "\\sw+" (mark-1+ point) end #f)) + (editor-error "No keyword preceding point")))))) + (let ((start (backward-word end 1 'LIMIT))) + (standard-completion (extract-string start end) + (lambda (prefix if-unique if-not-unique if-not-found) + (string-table-complete (ref-variable keyword-table) + prefix + if-unique + if-not-unique + if-not-found)) + (lambda (completion) + (delete-string start end) + (insert-string completion start))))))) + (define-command keyparser-indent-line "Indent current line using the keyword syntax for this buffer." "d" (lambda (#!optional mark) (let* ((mark (if (default-object? mark) (current-point) mark)) (point? (mark= (line-start mark 0) (line-start (current-point) 0)))) - (indent-line mark (keyparser-compute-indentation mark)) + (indent-line mark (keyparser-compute-indentation mark #f)) (if point? (let ((point (current-point))) (if (within-indentation? point) @@ -169,7 +239,8 @@ (indent-line start (keyparser-compute-indentation-1 dstart start - state))) + state + #f))) (let ((start* (line-start start 1 'LIMIT))) (if (mark<= start* end) (let ((state (keyparse-partial start start* state))) @@ -183,79 +254,66 @@ (if (not (= indentation (mark-column indent-point))) (change-indentation indentation indent-point)))) -(define (keyparser-compute-indentation mark) +(define (keyparser-compute-indentation mark comment?) (let ((dstart (or (this-definition-start mark) (group-start mark))) (end (line-start mark 0))) (keyparser-compute-indentation-1 dstart end - (keyparse-initial dstart end)))) + (keyparse-initial dstart end) + comment?))) -(define (keyparser-compute-indentation-1 dstart lstart state) +(define (keyparser-compute-indentation-1 dstart lstart state comment?) ;; DSTART is the start of a top-level definition. LSTART is the ;; start of a line within that definition. STATE is the keyparser - ;; state obtained by parsing from DSTART to LSTART. + ;; state obtained by parsing from DSTART to LSTART. COMMENT? is + ;; true iff this procedure is being called from the comment + ;; indenter, in which case we must not use the comment indenter to + ;; compute the indentation. (let ((char-state (keyparser-state/char-state state)) (description (ref-variable keyparser-description dstart))) - (if (and char-state (in-char-syntax-structure? char-state)) - (cond ((parse-state-in-comment? char-state) - ((description/indent-continued-comment description) - (parse-state-comment-start char-state))) - ((> (parse-state-depth char-state) 0) - (+ (mark-column - (or (parse-state-containing-sexp char-state) - (parse-state-containing-sexp - (parse-partial-sexp dstart lstart)))) - 1)) - (else 0)) - (let ((restart-point (keyparser-state/restart-point state)) - (stack (keyparser-state/stack state))) - (if restart-point - ((if (eq? 'HEADER (keyparser-state/restart-type state)) - (fragment/indent-header (stack-entry/fragment (car stack))) - (description/indent-continued-statement description)) - restart-point) - (if (null? stack) - 0 - (let ((entry (at-current-level? description lstart stack))) - (if entry - (mark-indentation - (stack-entry/start - (car (if (stack-entry/end? entry) - (pop-containers - stack - (stack-entry/fragment entry)) - stack)))) - (let ((entry (car stack))) - ((fragment/indent-body (stack-entry/fragment entry)) - (stack-entry/start entry))))))))))) - -(define-variable keyword-table - "String table of keywords, to control keyword-completion. -See \\[complete-keyword]." - #f) - -(define-command complete-keyword - "Perform completion on keyword preceding point." - () - (lambda () - (let ((end - (let ((point (current-point))) - (let ((end (group-end point))) - (or (re-match-forward "\\sw+" point end #f) - (and (mark< (group-start point) point) - (re-match-forward "\\sw+" (mark-1+ point) end #f)) - (editor-error "No keyword preceding point")))))) - (let ((start (backward-word end 1 'LIMIT))) - (standard-completion (extract-string start end) - (lambda (prefix if-unique if-not-unique if-not-found) - (string-table-complete (ref-variable keyword-table) - prefix - if-unique - if-not-unique - if-not-found)) - (lambda (completion) - (delete-string start end) - (insert-string completion start))))))) + (cond ((and char-state (in-char-syntax-structure? char-state)) + (cond ((parse-state-in-comment? char-state) + ((description/indent-continued-comment description) + (parse-state-comment-start char-state))) + ((> (parse-state-depth char-state) 0) + (+ (mark-column + (or (parse-state-containing-sexp char-state) + (parse-state-containing-sexp + (parse-partial-sexp dstart lstart)))) + 1)) + (else 0))) + ((and (not comment?) + (let ((s.e + ((ref-variable comment-locator-hook dstart) lstart))) + (and s.e + (within-indentation? (car s.e)) + (car s.e)))) + => (ref-variable comment-indent-hook dstart)) + (else + (let ((restart-point (keyparser-state/restart-point state)) + (stack (keyparser-state/stack state))) + (if restart-point + ((if (eq? 'HEADER (keyparser-state/restart-type state)) + (keyparser-fragment/indent-header + (keyparser-stack-entry/fragment (car stack))) + (description/indent-continued-statement description)) + restart-point) + (if (null? stack) + 0 + (let ((entry + (at-current-level? description lstart stack))) + (if entry + (mark-indentation + (keyparser-stack-entry/start + (car (if (keyparser-stack-entry/end? entry) + (pop-containers + stack + (keyparser-stack-entry/fragment entry)) + stack)))) + (let ((entry (car stack))) + ((keyparser-fragment/indent-body + (keyparser-stack-entry/fragment entry)) + (keyparser-stack-entry/start entry)))))))))))) (define-structure (keyparser-state (conc-name keyparser-state/)) ;; CHAR-STATE is the result from the character parser. @@ -283,26 +341,26 @@ See \\[complete-keyword]." ;; we're in, and a START mark pointing to the beginning of the ;; structure. -(define-structure (stack-entry - (conc-name stack-entry/) +(define-structure (keyparser-stack-entry + (conc-name keyparser-stack-entry/) (print-procedure - (standard-unparser-method 'STACK-ENTRY + (standard-unparser-method 'KEYPARSER-STACK-ENTRY (lambda (entry port) (write-char #\space port) - (write (fragment/keyword - (pattern/start - (stack-entry/pattern entry))) - port))))) + (write (keyparser-stack-entry/keyword entry) port))))) (pattern #f read-only #t) (index #f read-only #t) (start #f read-only #t)) -(define-integrable (stack-entry/end? entry) - (= 1 (stack-entry/index entry))) +(define-integrable (keyparser-stack-entry/end? entry) + (= 1 (keyparser-stack-entry/index entry))) + +(define (keyparser-stack-entry/fragment entry) + (list-ref (pattern/fragments (keyparser-stack-entry/pattern entry)) + (keyparser-stack-entry/index entry))) -(define (stack-entry/fragment entry) - (list-ref (stack-entry/pattern entry) - (stack-entry/index entry))) +(define (keyparser-stack-entry/keyword entry) + (pattern/keyword (keyparser-stack-entry/pattern entry))) (define (keyparse-initial dstart mark) (let ((lstart (line-start mark 0)) @@ -347,26 +405,22 @@ See \\[complete-keyword]." (call-with-values (lambda () (if (and (not (null? stack)) - (not (stack-entry/end? (car stack)))) - (match-current-level (stack-entry/pattern (car stack)) - kstart) + (not (keyparser-stack-entry/end? (car stack)))) + (match-current-level kstart stack) (values #f #f))) - (lambda (match index) + (lambda (match entry) (if match - (continue-after-match - description sstart match end - (cons (make-stack-entry (stack-entry/pattern (car stack)) - index - (stack-entry/start (car stack))) - (cdr stack))) + (continue-after-match description sstart match end + (cons entry (cdr stack))) (call-with-values (lambda () - (match-structure-start description kstart)) + (match-structure-start description kstart stack)) (lambda (match pattern) (if match (continue-after-match description sstart match end - (cons (make-stack-entry pattern 0 sstart) + (cons (make-keyparser-stack-entry + pattern 0 sstart) stack)) (let ((se ((description/find-statement-end @@ -388,16 +442,10 @@ See \\[complete-keyword]." (lambda (sstart kstart) sstart (and kstart - (call-with-values - (lambda () - (match-current-level (stack-entry/pattern (car stack)) - kstart)) - (lambda (match index) + (call-with-values (lambda () (match-current-level kstart stack)) + (lambda (match entry) match - (and match - (make-stack-entry (stack-entry/pattern (car stack)) - index - (stack-entry/start (car stack)))))))))) + entry)))))) (define (parse-forward-to-statement description start end) (let ((sstart (skip-whitespace start end))) @@ -407,9 +455,9 @@ See \\[complete-keyword]." (let loop ((leaders (description/statement-leaders description))) (if (null? leaders) (values sstart mark) - (let ((mark* (re-match-forward (caar leaders) mark))) + (let ((mark* (re-match-forward (cadar leaders) mark))) (if mark* - (let ((mark* ((cdar leaders) mark* end))) + (let ((mark* ((caddar leaders) mark* end))) (if mark* (outer (skip-whitespace mark* end)) (values sstart #f))) @@ -419,21 +467,22 @@ See \\[complete-keyword]." (backward-prefix-chars (forward-to-sexp-start start end) start)) (define (continue-after-match description start match end stack) - (let ((fragment (stack-entry/fragment (car stack)))) + (let ((fragment (keyparser-stack-entry/fragment (car stack)))) (let ((mark (and (mark<= match end) - ((fragment/parse-header fragment) match end)))) + ((keyparser-fragment/parse-header fragment) match end)))) (cond ((not mark) (values stack start 'HEADER)) - ((stack-entry/end? (car stack)) + ((keyparser-stack-entry/end? (car stack)) (continue-after-statement-end description mark end (pop-containers (cdr stack) fragment))) (else - ((fragment/parse-body fragment) description mark end stack)))))) + ((keyparser-fragment/parse-body fragment) + description mark end stack)))))) (define (pop-containers stack fragment) - (let loop ((stack stack) (n (fragment/pop-container fragment))) + (let loop ((stack stack) (n (keyparser-fragment/pop-container fragment))) (if (and (pair? stack) (> n 0)) (loop (cdr stack) (- n 1)) stack))) @@ -445,39 +494,48 @@ See \\[complete-keyword]." end (let loop ((stack stack)) (if (and (pair? stack) - (not (pattern/end (stack-entry/pattern (car stack))))) + (not (pattern/end (keyparser-stack-entry/pattern (car stack))))) (loop (cdr stack)) stack)))) -(define (match-current-level pattern start) - (let loop ((fragments (cdr pattern)) (index 1)) +(define (match-current-level start stack) + (let loop + ((fragments + (pattern/current-level (keyparser-stack-entry/pattern (car stack)))) + (index 1)) (if (null? fragments) (values #f #f) (let ((mark (and (car fragments) - (match-fragment (car fragments) start)))) + (match-fragment (car fragments) start stack)))) (if mark - (values mark index) + (values mark + (make-keyparser-stack-entry + (keyparser-stack-entry/pattern (car stack)) + index + (keyparser-stack-entry/start (car stack)))) (loop (cdr fragments) (+ index 1))))))) -(define (match-structure-start description start) +(define (match-structure-start description start stack) (let loop ((patterns (description/patterns description))) (if (null? patterns) (values #f #f) (let* ((pattern (car patterns)) - (mark (match-fragment (pattern/start pattern) start))) + (mark (match-fragment (pattern/start pattern) start stack))) (if mark (values mark pattern) (loop (cdr patterns))))))) -(define (match-fragment fragment mark) - (let ((end (match-forward (fragment/keyword fragment) mark))) +(define (match-fragment fragment mark stack) + (let ((end (match-forward (keyparser-fragment/keyword fragment) mark))) (and end (or (line-end? end) - (char=? #\space - (char->syntax-code (ref-variable syntax-table end) - (mark-right-char end)))) - (let ((match-header (fragment/match-header fragment))) + (let ((code + (char->syntax-code (ref-variable syntax-table end) + (mark-right-char end)))) + (not (or (char=? #\w code) + (char=? #\_ code))))) + (let ((match-header (keyparser-fragment/match-header fragment))) (if match-header - (match-header end) + (match-header end stack) end))))) \ No newline at end of file diff --git a/v7/src/edwin/verilog.scm b/v7/src/edwin/verilog.scm index 818b3f6d9..0b794560c 100644 --- a/v7/src/edwin/verilog.scm +++ b/v7/src/edwin/verilog.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: verilog.scm,v 1.3 1997/03/07 23:34:54 cph Exp $ +;;; $Id: verilog.scm,v 1.4 1997/03/10 05:40:20 cph Exp $ ;;; ;;; Copyright (c) 1996-97 Massachusetts Institute of Technology ;;; @@ -71,9 +71,7 @@ buffer) (local-set-variable! definition-start verilog-defun-start-regexp buffer) (local-set-variable! require-final-newline #t buffer) - (local-set-variable! keyparser-description - verilog-keyparser-description - buffer) + (local-set-variable! keyparser-description verilog-description buffer) (local-set-variable! keyword-table verilog-keyword-table buffer) (event-distributor/invoke! (ref-variable verilog-mode-hook buffer) buffer))) @@ -118,7 +116,7 @@ (match-forward "////" mark)) 0) ((match-forward "///" mark) - (keyparser-compute-indentation mark)) + (keyparser-compute-indentation mark #t)) (else (ref-variable comment-column mark))))) (if (within-indentation? mark) @@ -179,63 +177,101 @@ (+ (mark-indentation mark) (ref-variable verilog-continued-statement-offset mark))) -(define verilog-keyparser-description +(define verilog-description (make-keyparser-description - 'PATTERNS - (map (lambda (entry) - (list - (make-keyparser-fragment 'KEYWORD - (car entry) - 'PARSE-HEADER - (caddr entry) - 'INDENT-HEADER - continued-header-indent - 'PARSE-BODY - keyparse-forward - 'INDENT-BODY - continued-statement-indent) - (and (cadr entry) - (make-keyparser-fragment 'KEYWORD - (cadr entry) - 'PARSE-HEADER - parse-forward-noop - 'INDENT-HEADER - continued-header-indent - 'PARSE-BODY - #f - 'INDENT-BODY - #f)))) - `(("always" #f ,parse-forward-noop) - ("begin" "end" ,parse-forward-past-block-tag) - ("case" "endcase" ,forward-one-sexp) - ("casex" "endcase" ,forward-one-sexp) - ("casez" "endcase" ,forward-one-sexp) - ("else" #f ,parse-forward-noop) - ("for" #f ,forward-one-sexp) - ("forever" #f ,parse-forward-noop) - ("fork" "join" ,parse-forward-past-block-tag) - ("function" "endfunction" ,parse-forward-past-semicolon) - ("if" #f ,forward-one-sexp) - ("initial" #f ,parse-forward-noop) - ("macromodule" "endmodule" ,parse-forward-past-semicolon) - ("module" "endmodule" ,parse-forward-past-semicolon) - ("primitive" "endprimitive" ,parse-forward-past-semicolon) - ("repeat" #f ,forward-one-sexp) - ("table" "endtable" ,parse-forward-noop) - ("task" "endtask" ,parse-forward-past-semicolon) - ("while" #f ,forward-one-sexp))) - - 'STATEMENT-LEADERS - `((,(re-compile-char #\# #f) . ,forward-one-sexp) - (,(re-compile-char #\@ #f) . ,forward-one-sexp)) - 'FIND-STATEMENT-END parse-forward-past-semicolon - 'INDENT-CONTINUED-STATEMENT continued-statement-indent - 'INDENT-CONTINUED-COMMENT (lambda (mark) - (mark-column (or (verilog-comment-match-start mark) mark))) - )) \ No newline at end of file + (mark-column (or (verilog-comment-match-start mark) mark))))) + +(define-keyparser-statement-leader #\# verilog-description + (re-compile-char #\# #f) + forward-one-sexp) + +(define-keyparser-statement-leader #\@ verilog-description + (re-compile-char #\@ #f) + forward-one-sexp) + +(define (define-standard-keyword keyword end parse-header) + (define-keyparser-pattern keyword verilog-description + (make-keyparser-fragment 'KEYWORD + keyword + 'PARSE-HEADER + parse-header + 'INDENT-HEADER + continued-header-indent + 'PARSE-BODY + keyparse-forward + 'INDENT-BODY + continued-statement-indent) + (and end + (make-keyparser-fragment 'KEYWORD + end + 'PARSE-HEADER + parse-forward-noop + 'INDENT-HEADER + continued-header-indent + 'PARSE-BODY + #f + 'INDENT-BODY + #f)))) + +(define-standard-keyword "always" #f + parse-forward-noop) + +(define-standard-keyword "begin" "end" + parse-forward-past-block-tag) + +(define-standard-keyword "case" "endcase" + forward-one-sexp) + +(define-standard-keyword "casex" "endcase" + forward-one-sexp) + +(define-standard-keyword "casez" "endcase" + forward-one-sexp) + +(define-standard-keyword "else" #f + parse-forward-noop) + +(define-standard-keyword "for" #f + forward-one-sexp) + +(define-standard-keyword "forever" #f + parse-forward-noop) + +(define-standard-keyword "fork" "join" + parse-forward-past-block-tag) + +(define-standard-keyword "function" "endfunction" + parse-forward-past-semicolon) + +(define-standard-keyword "if" #f + forward-one-sexp) + +(define-standard-keyword "initial" #f + parse-forward-noop) + +(define-standard-keyword "macromodule" "endmodule" + parse-forward-past-semicolon) + +(define-standard-keyword "module" "endmodule" + parse-forward-past-semicolon) + +(define-standard-keyword "primitive" "endprimitive" + parse-forward-past-semicolon) + +(define-standard-keyword "repeat" #f + forward-one-sexp) + +(define-standard-keyword "table" "endtable" + parse-forward-noop) + +(define-standard-keyword "task" "endtask" + parse-forward-past-semicolon) + +(define-standard-keyword "while" #f + forward-one-sexp) \ No newline at end of file diff --git a/v7/src/edwin/vhdl.scm b/v7/src/edwin/vhdl.scm index d96349168..118713393 100644 --- a/v7/src/edwin/vhdl.scm +++ b/v7/src/edwin/vhdl.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: vhdl.scm,v 1.3 1997/03/08 00:21:37 cph Exp $ +;;; $Id: vhdl.scm,v 1.4 1997/03/10 05:40:10 cph Exp $ ;;; ;;; Copyright (c) 1997 Massachusetts Institute of Technology ;;; @@ -70,9 +70,7 @@ 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-keyparser-description - buffer) + (local-set-variable! keyparser-description vhdl-description buffer) (local-set-variable! keyword-table vhdl-keyword-table buffer) (event-distributor/invoke! (ref-variable vhdl-mode-hook buffer) buffer))) @@ -114,7 +112,13 @@ (cond ((match-forward "----" mark) 0) ((match-forward "---" mark) - (keyparser-compute-indentation 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) @@ -127,7 +131,7 @@ "^" (regexp-group "architecture" "configuration" "entity" "library" "package" "use") - (regexp-group "\\s " "$"))) + (regexp-group "[^a-zA-Z0-9_]" "$"))) (define vhdl-keyword-table (alist->string-table @@ -154,18 +158,6 @@ (+ (mark-indentation mark) (ref-variable vhdl-continued-statement-offset mark))) -(define comatch:identifier-start - (comatch:general - (lambda (start end) - (and (re-match-forward "\\s \\|^" start end) - start)))) - -(define comatch:identifier-end - (comatch:general - (lambda (start end) - (and (re-match-forward "\\s \\|$" start end) - start)))) - (define comatch:skip-whitespace (comatch:general (lambda (start end) @@ -177,6 +169,12 @@ (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_]*") @@ -187,23 +185,32 @@ (comatch:string keyword) comatch:identifier-end)) -(define comatch:list +(define (comatch:matched-sexp comatcher) (comatch:append comatch:skip-whitespace - (comatch:and (comatch:char #\() + (comatch:and comatcher comatch:sexp))) - -(define (match-for-loop mark) - (and (comatch-apply comatch:for-header:control mark) - mark)) - -(define (match-for-component mark) - (and (comatch-apply comatch:for-header:component mark) - mark)) -(define (match-for-block mark) - (and (not (or (comatch-apply comatch:for-header:control mark) - (comatch-apply comatch:for-header:component mark))) - mark)) +(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 @@ -218,24 +225,9 @@ comatch:skip-whitespace (comatch:char #\:))) -(define (match-if-then mark) - (and (eq? 'THEN (classify-if-header mark)) - mark)) - -(define (match-if-generate mark) - (and (eq? 'GENERATE (classify-if-header mark)) - mark)) - -(define (classify-if-header mark) - (let ((m (parse-forward-past-generate/then mark (group-end mark)))) - (and m - (let ((s (backward-one-sexp m))) - (and s - (let ((e (forward-one-sexp s))) - (and e - (if (string-ci=? "then" (extract-string s e)) - 'THEN - 'GENERATE)))))))) +(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)) @@ -256,9 +248,9 @@ (define (parse-forward-past-token token) (parse-forward-past (let ((regexp - (string-append (regexp-group "\\s " "^") + (string-append (regexp-group "[^a-zA-Z0-9_]" "^") token - (regexp-group "\\s " "$")))) + (regexp-group "[^a-zA-Z0-9_]" "$")))) (lambda (start end) (re-search-forward regexp start end))))) @@ -268,104 +260,224 @@ (define parse-forward-past-then (parse-forward-past-token "then")) -(define parse-forward-past-generate/then - (parse-forward-past-token (regexp-group "generate" "then"))) +(define parse-forward-past-=> + (parse-forward-past-token "=>")) (define (parse-forward-noop start end) end start) -(define (parse-process-header start end) - (comatch-apply comatch:process-header start end)) - -(define comatch:process-header - (comatch:append (comatch:? comatch:list) - (comatch:? (comatch:keyword "is")))) - -(define (parse-postponed-header start end) - (comatch-apply comatch:postponed-header start end)) - -(define comatch:postponed-header - (comatch:append (comatch:keyword "process") - comatch:process-header)) - -(define (parse-component-header start end) - (comatch-apply comatch:component-header start end)) - -(define comatch:component-header - (comatch:append comatch:identifier - (comatch:? (comatch:keyword "is")))) +(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-keyparser-description +(define vhdl-description (make-keyparser-description - 'PATTERNS - (let ((standard-keyword - (lambda (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)))) - (let ((begin-frag (standard-keyword "begin" #f parse-forward-noop)) - (end-frag (standard-keyword "end" #f parse-forward-past-semicolon))) - (append - (map (lambda (entry) - (cons* (standard-keyword (car entry) (cadr entry) (caddr entry)) - end-frag - (cdddr entry))) - `(("architecture" #f ,parse-forward-past-is ,begin-frag) - ("block" #f ,parse-process-header ,begin-frag) - ("case" #f ,parse-forward-past-is) - ("component" #f ,parse-component-header ,begin-frag) - ("configuration" #f ,parse-forward-past-is) - ("entity" #f ,parse-forward-past-is ,begin-frag) - ("for" ,match-for-block ,parse-forward-noop) - ("for" ,match-for-component ,(parse-forward-past-char #\:)) - ("for" ,match-for-loop - ,(parse-forward-past-token - (regexp-group "generate" "loop"))) - ("function" #f ,parse-forward-past-is ,begin-frag) - ("pure" #f ,parse-forward-past-is ,begin-frag) - ("impure" #f ,parse-forward-past-is ,begin-frag) - ("if" ,match-if-then - ,parse-forward-past-then - ,(standard-keyword "elsif" #f parse-forward-past-then) - ,(standard-keyword "else" #f parse-forward-noop)) - ("if" ,match-if-generate ,parse-forward-past-generate/then) - ("loop" #f ,parse-forward-noop) - ("package" #f ,parse-forward-past-is) - ("procedure" #f ,parse-forward-past-is ,begin-frag) - ("process" #f ,parse-process-header ,begin-frag) - ("postponed" #f ,parse-postponed-header ,begin-frag) - ("range" #f ,(parse-forward-past-token "units")) - ("record" #f ,parse-forward-noop) - ("while" #f ,(parse-forward-past-token "loop")))) - (list - (let ((when - (standard-keyword "when" #f (parse-forward-past-token "=>")))) - (list when - (standard-keyword "end" #f parse-forward-past-semicolon - 'POP-CONTAINER 1) - when)))))) - - 'STATEMENT-LEADERS - `((,(re-compile-pattern "[a-zA-Z0-9_]+\\s *:" #f) . ,parse-forward-noop)) - '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))))) \ No newline at end of file + (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) + (there-exists? stack + (lambda (entry) + (equal? 'CONFIGURATION (keyparser-stack-entry/keyword entry))))) + +(define-matched-keyword 'BLOCK-CONFIGURATION "for" + (lambda (mark stack) + stack + (and (comatch-apply comatch:for-header:block mark) + mark)) + parse-forward-noop + end-frag) \ No newline at end of file