#| -*-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
(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
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))
;;; -*-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
;;;
(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
;; 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.
;; 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)
\f
;; A structure pattern is a list of pattern fragments, which define
;; the parts of the structure. The START and END define how the
;; continations are "ELSIF <expression> THEN <statements>" and "ELSE
;; <statements>".
-(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
;; 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)
"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)
(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)))
(if (not (= indentation (mark-column indent-point)))
(change-indentation indentation indent-point))))
\f
-(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))))))))))))
\f
(define-structure (keyparser-state (conc-name keyparser-state/))
;; CHAR-STATE is the result from the character parser.
;; 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))
(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
(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))))))
\f
(define (parse-forward-to-statement description start end)
(let ((sstart (skip-whitespace start end)))
(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)))
(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)))
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))))
\f
-(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
;;; -*-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
;;;
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)))
(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)
(+ (mark-indentation mark)
(ref-variable verilog-continued-statement-offset mark)))
\f
-(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))))
+\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
;;; -*-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
;;;
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)))
(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)
"^"
(regexp-group "architecture" "configuration" "entity"
"library" "package" "use")
- (regexp-group "\\s " "$")))
+ (regexp-group "[^a-zA-Z0-9_]" "$")))
(define vhdl-keyword-table
(alist->string-table
(+ (mark-indentation mark)
(ref-variable vhdl-continued-statement-offset mark)))
\f
-(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)
(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: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)))
-\f
-(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
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)))
\f
(define ((parse-forward-past search) start end)
(let loop ((start start) (state #f))
(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)))))
(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)))))))))
\f
-(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)
+\f
+(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)
+\f
+(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
projects / mit-scheme.git / commitdiff