reduce-historical/psl-1983/nmode/lisp-parser.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Lisp-Parser.SL - NMODE's Lisp parser
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        10 December 1982
% Revised:     18 February 1983
%
% See the document NMODE-PARSING.TXT for a description of the parsing strategy.
%
% 18-Feb-1983 Alan Snyder
%  Removed use of "obsolete" #\ names.
% 6-Jan-83 Alan Snyder
%   Use LOAD instead of FASLIN to get macros (for portability).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects fast-int fast-strings fast-vectors nmode-attributes))

% Imported variables:

(fluid '(nmode-defun-predicate
	 nmode-defun-scanner
	 nmode-current-parser
	 ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de establish-lisp-parser ()
  (setf nmode-defun-predicate #'lisp-current-line-is-defun?)
  (setf nmode-defun-scanner #'lisp-scan-past-defun)
  (setf nmode-current-parser #'lisp-parse-line)
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% This file defines the basic primitive used by NMODE to
% analyze Lisp source code.  It currently recognizes:
%
%      ( and ) as list brackets
%      [ and ] as vector brackets
%      comments beginning with %
%      #/x as character constants
%      " ... " as string literals
%      !x as a quoted character
%      ' ` #' #. , ,@ as prefixes to ( and [

(de lisp-parse-line (str vec)
  % Fill Vec[i] to be the attributes of Str[i].

  (let* ((previous-attributes -1)
	 attributes ch is-first
	 (high (string-upper-bound str))
	 (in-comment NIL)
	 (in-string NIL)
	 (last-was-sharp NIL)
	 (last-was-sharp-slash NIL)
	 (last-was-sharp-quote NIL)
	 (last-was-sharp-dot NIL)
	 (last-was-quoter NIL)
	 (last-was-comma NIL)
	 (last-was-comma-atsign NIL)
	 (last-prefix-ending-index NIL)
	 (last-prefix-length NIL)
	 )
    (for (from i 0 high)
	 (do
	  (setf ch (string-fetch str i))
	  % Determine the type attributes of the current character and update
	  % the parsing state for the next character.
	  (cond
	   (in-comment (setf attributes (attributes COMMENT)))
	   (in-string
	    (setf attributes (attributes ATOM))
	    (setf in-string (not (= ch #/")))
	    )
	   (last-was-sharp-slash
	    (setf attributes (attributes ATOM))
	    (setf last-was-sharp-slash NIL)
	    )
	   (last-was-quoter
	    (setf attributes (attributes ATOM))
	    (setf last-was-quoter NIL)
	    )
	   (t
	    (setf attributes (lisp-character-attributes ch))
	    (setf in-comment (= ch #/%))
	    (setf in-string (= ch #/"))
	    (setf last-was-sharp-slash (and last-was-sharp (= ch #//)))
	    (setf last-was-sharp-quote (and last-was-sharp (= ch #/')))
	    (setf last-was-sharp-dot (and last-was-sharp (= ch #/.)))
	    (setf last-was-sharp (= ch #/#))
	    (setf last-was-quoter (= ch #/!))
	    (setf last-was-comma-atsign (and last-was-comma (= ch #/@)))
	    (setf last-was-comma (= ch #/,))
	    (let ((prefix-length
		   (cond
		    (last-was-sharp-quote 2)
		    (last-was-sharp-dot 2)
		    ((= ch #/') 1)
		    ((= ch #/`) 1)
		    (last-was-comma 1)
		    (last-was-comma-atsign 1) % is 1 because comma is a prefix
		    (t 0)
		    )))
	      (when (> prefix-length 0)
		% We just passed a prefix.
		% Does it merge with the previous prefix?
		(if (and last-prefix-ending-index
			 (= last-prefix-ending-index (- i prefix-length))
			 )
		  (setf last-prefix-length (+ last-prefix-length prefix-length))
		  % Otherwise
		  (setf last-prefix-length prefix-length)
		  )
		(setf last-prefix-ending-index i)
		))
	    ))
	  % Determine the position attributes:
	  % LISP is simple: brackets are single characters (except for
	  % prefixes, which are handled below), atoms are maximal
	  % contiguous strings of atomic-characters.
	  (setf is-first (or (= attributes (attributes OPENER))
			     (= attributes (attributes CLOSER))
			     (~= attributes previous-attributes)))
	  (setf previous-attributes attributes)
	  (cond 
	   % First we test for an open bracket immediately preceded
	   % by one or more prefixes.
	   ((and (= attributes (attributes OPENER))
		 last-prefix-ending-index
		 (= last-prefix-ending-index (- i 1))
		 )
	    (let ((prefix-start (- i last-prefix-length)))
	      (vector-store vec prefix-start (attributes FIRST PREFIX OPENER))
	      (lp-set-last vec (- prefix-start 1))
	      (for (from j (+ prefix-start 1) (- i 1))
		   (do (vector-store vec j (attributes MIDDLE PREFIX OPENER))))
	      ))
	   (is-first
	    (setf attributes (| attributes (attributes FIRST)))
	    (lp-set-last vec (- i 1))
	    )
	   (t
	    (setf attributes (| attributes (attributes MIDDLE)))
	    ))
	  (vector-store vec i attributes)
	  ))
    (lp-set-last vec high)
    ))

(de lisp-character-attributes (ch)
  (selectq ch
    (NIL (attributes))
    ((#/( #/[) (attributes OPENER))
    ((#/) #/]) (attributes CLOSER))
    ((#\SPACE #\TAB #\LF #\CR) (attributes BLANKS))
    (#/% (attributes COMMENT))
    (t (attributes ATOM))
    ))

(de lp-set-last (vec i)
  (if (>= i 0)
    (vector-store vec i (& (| (attributes LAST) (vector-fetch vec i))
			   (~ (attributes MIDDLE))))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Lisp Defun Primitives
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de lisp-current-line-is-defun? ()
  (and (not (current-line-empty?))
       (= (current-line-fetch 0) #/()
       ))

(de lisp-scan-past-defun ()
  % This function should be called with point at the start of a defun.
  % It will scan past the end of the defun (not to the beginning of the
  % next line, however).  If the end of the defun is not found, it returns
  % NIL and leaves point unchanged.

  (move-forward-form)
  )