Artifact 71e3c6ee462e6f24d7f1150f986815ac4a905d60d18b4fab2d9aa52b94f836c3:

• File psl-1983/3-1/nmode/nmode-parsing.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4498) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/nmode/nmode-parsing.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4498) [annotate] [blame] [check-ins using]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% NMODE-Parsing.SL - NMODE parsing primitives
% [This file used to be Parsing-Functions.SL]
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        10 December 1982
% Revised:     6 January 1983
%
% This file defines Macros!  Load it at compile-time!
%
% This file defines the basic primitives used by NMODE functions to analyze
% source code.  See the document NMODE-PARSING.TXT for a description of the
% parsing strategy.
%
% 6-Jan-83 Alan Snyder
%   Use LOAD instead of FASLIN to get macros (for portability).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

% Global Variables:

(fluid '(nmode-current-parser))
(setf nmode-current-parser 'lisp-parse-line)

% Internal Static Variables:

(fluid '(nmode-parsed-line
         nmode-parsed-line-info
	 ))

(setf nmode-parsed-line NIL)
(setf nmode-parsed-line-info (make-vector 200 0))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% These are the exported functions:
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro test-current-attributes attributes-list
  `(test-current-attributes-bits (test-attributes ,@attributes-list))
  )

(defmacro move-forward-to attributes-list
  `(move-forward-to-bits (test-attributes ,@attributes-list))
  )

(defmacro move-backward-to attributes-list
  `(move-backward-to-bits (test-attributes ,@attributes-list))
  )

(defmacro move-forward-within-line-to attributes-list
  `(move-forward-within-line-to-bits (test-attributes ,@attributes-list))
  )

(defmacro move-backward-within-line-to attributes-list
  `(move-backward-within-line-to-bits (test-attributes ,@attributes-list))
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% These are internal, non-primitive functions:
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de test-current-attributes-bits (bits)
  (let* ((x (current-attributes))
	 (match-bits (& x bits))
	 )
    (and (~= 0 (& match-bits (const POSITION-BITS)))
	 (~= 0 (& match-bits (const TYPE-BITS)))
	 )))

(de move-forward-to-bits (bits)
  (move-forward-to-bits-until bits #'at-buffer-end?))

(de move-backward-to-bits (bits)
  (move-backward-to-bits-until bits #'at-buffer-start?))

(de move-forward-within-line-to-bits (bits)
  (move-forward-to-bits-until bits #'at-line-end?))

(de move-backward-within-line-to-bits (bits)
  (move-backward-to-bits-until bits #'at-line-start?))

(de move-forward-to-bits-until (bits stop-predicate)
  (let ((old-pos (buffer-get-position)))
    (while T
      (when (apply stop-predicate ()) (buffer-set-position old-pos) (exit NIL))
      (when (test-current-attributes-bits bits)
	(exit (decode-character-attribute-type (current-attributes))))
      (move-forward-character)
      )))

(de move-backward-to-bits-until (bits stop-predicate)
  (let ((old-pos (buffer-get-position)))
    (while T
      (when (test-current-attributes-bits bits)
	(exit (decode-character-attribute-type (current-attributes))))
      (when (apply stop-predicate ()) (buffer-set-position old-pos) (exit NIL))
      (move-backward-character)
      )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% The (internal) primitive parsing function:
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de current-attributes ()
  (let* ((str (current-line))
	 (len (string-length str))
	 (pos (current-char-pos))
	 )
    (if (>= pos len)
      (attributes FIRST LAST BLANKS)
      % Otherwise
      (when (not (eq nmode-parsed-line str))
	(setf nmode-parsed-line str)
	(if (< (vector-size nmode-parsed-line-info) len)
	  (setf nmode-parsed-line-info (make-vector len 0)))
	(apply nmode-current-parser
	       (list nmode-parsed-line nmode-parsed-line-info))
	)
      (vector-fetch nmode-parsed-line-info pos)
      )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Testing code:
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load extended-char))
(de show-current-character ()
  (write-prompt
   (bldmsg "%l" (unparse-character-attributes (current-attributes)))))
%(set-text-command (x-char C-=) 'show-current-character)