Artifact 9c373b007f89e37597856ae82e3ad47b77b6594665868f37a89524e1ebc4b77b:

• File psl-1983/3-1/nmode/nmode-attributes.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: 4644) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/nmode/nmode-attributes.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: 4644) [annotate] [blame] [check-ins using]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Nmode-Attributes.SL - macros for NMODE parsing primitives
% [This file used to be Parsing-Attributes.SL]
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        22 November 1982
%
% This file defines Macros!  Load it at compile-time!
%
% See the document NMODE-PARSING.TXT for a description of the parsing strategy.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects fast-int))

% Internal Constants:

% Type attributes:
% Exactly one of these should always be on.

(defconst     OPENER-BITS 2#000000001) % part of an opening "bracket"
(defconst     CLOSER-BITS 2#000000010) % part of a closing "bracket"
(defconst       ATOM-BITS 2#000000100) % part of an "atom"
(defconst     BLANKS-BITS 2#000001000) % part of a "blank region"
(defconst    COMMENT-BITS 2#000010000) % part of a comment

% Secondary attributes:
% Zero or more of these may be on.

(defconst     PREFIX-BITS 2#000100000) % a subclass of opening bracket

% Position attributes:
% One or two of these should always be on.

(defconst      FIRST-BITS 2#001000000) % the first character of an item
(defconst     MIDDLE-BITS 2#010000000) % neither first nor last
(defconst       LAST-BITS 2#100000000) % the last character of an item

% Masks:
(defconst       POSITION-BITS #.(| (const FIRST-BITS) 
				   (| (const MIDDLE-BITS) (const LAST-BITS))))
(defconst        BRACKET-BITS #.(| (const OPENER-BITS) (const CLOSER-BITS)))
(defconst     WHITESPACE-BITS #.(| (const BLANKS-BITS) (const COMMENT-BITS)))

(defconst      NOT-SPACE-BITS #.(| (const BRACKET-BITS) (const ATOM-BITS)))
(defconst   PRIMARY-TYPE-BITS #.(| (const NOT-SPACE-BITS)
				   (const WHITESPACE-BITS)))
(defconst SECONDARY-TYPE-BITS #.(const PREFIX-BITS))
(defconst           TYPE-BITS #.(| (const PRIMARY-TYPE-BITS)
				   (const SECONDARY-TYPE-BITS)))

(de parse-character-attributes (attribute-list)
  % Given a list of attribute names, return an integer containing
  % all of their bits.

  (let ((bits 0))
    (for (in attribute-name attribute-list)
	 (do
	  (selectq attribute-name
	    (OPENER      (setf bits (| bits (const OPENER-BITS))))
	    (CLOSER      (setf bits (| bits (const CLOSER-BITS))))
	    (BRACKET     (setf bits (| bits (const BRACKET-BITS))))
	    (ATOM        (setf bits (| bits (const ATOM-BITS))))
	    (BLANKS      (setf bits (| bits (const BLANKS-BITS))))
	    (COMMENT     (setf bits (| bits (const COMMENT-BITS))))
	    (WHITESPACE  (setf bits (| bits (const WHITESPACE-BITS))))
	    (NOT-SPACE   (setf bits (| bits (const NOT-SPACE-BITS))))
	    (PREFIX      (setf bits (| bits (const PREFIX-BITS))))
	    (FIRST       (setf bits (| bits (const FIRST-BITS))))
	    (MIDDLE      (setf bits (| bits (const MIDDLE-BITS))))
	    (LAST        (setf bits (| bits (const LAST-BITS))))
	    (t (StdError
		(BldMsg "Invalid character attribute: %p" attribute-name)))
	    )))
    bits
    ))

(de unparse-character-attributes (bits)
  % Return a list of attribute names.

  (let ((l ()))
    (if (~= 0 (& bits (const OPENER-BITS))) (setf l (cons 'OPENER l)))
    (if (~= 0 (& bits (const CLOSER-BITS))) (setf l (cons 'CLOSER l)))
    (if (~= 0 (& bits (const ATOM-BITS))) (setf l (cons 'ATOM l)))
    (if (~= 0 (& bits (const BLANKS-BITS))) (setf l (cons 'BLANKS l)))
    (if (~= 0 (& bits (const COMMENT-BITS))) (setf l (cons 'COMMENT l)))
    (if (~= 0 (& bits (const PREFIX-BITS))) (setf l (cons 'PREFIX l)))
    (if (~= 0 (& bits (const LAST-BITS))) (setf l (cons 'LAST l)))
    (if (~= 0 (& bits (const MIDDLE-BITS))) (setf l (cons 'MIDDLE l)))
    (if (~= 0 (& bits (const FIRST-BITS))) (setf l (cons 'FIRST l)))
    l
    ))

(de decode-character-attribute-type (bits)
  % Return a primary type attribute name or NIL.

  (cond
   ((~= 0 (& bits (const OPENER-BITS))) 'OPENER)
   ((~= 0 (& bits (const CLOSER-BITS))) 'CLOSER)
   ((~= 0 (& bits (const ATOM-BITS))) 'ATOM)
   ((~= 0 (& bits (const BLANKS-BITS))) 'BLANKS)
   ((~= 0 (& bits (const COMMENT-BITS))) 'COMMENT)
   (t NIL)
   ))

(de fix-attribute-bits (bits)
  (if (= (& bits (const POSITION-BITS)) 0)
    % No position specified? Then any position will do.
    (setf bits (| bits (const POSITION-BITS))))
  (if (= (& bits (const TYPE-BITS)) 0)
    % No type specified? Then any type will do.
    (setf bits (| bits (const TYPE-BITS))))
  bits
  )

(defmacro attributes attributes-list
  (parse-character-attributes attributes-list)
  )

(defmacro test-attributes attributes-list
  (fix-attribute-bits (parse-character-attributes attributes-list))
  )