Artifact 419cbb38348dde977d1846fd104d992d6e4cc45517ab8a0ae42677513070d242:

• File psl-1983/3-1/kernel/char-macro.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: 1721) [annotate] [blame] [check-ins using] [more...]

%
% CHAR-MACRO.SL - Character constant macro
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        10 August 1981
% Copyright (c) 1981 University of Utah
%

% Edit by Cris Perdue,  1 Feb 1983 1355-PST
% pk:char.red merged with the version in USEFUL.  Some symbolic names
% for characters removed (not needed, I hope).

(dm Char (U)		%. Character constant macro
  (DoChar (cadr U)))

% Table driven char macro expander
(de DoChar (u)
  (cond
    ((idp u) (or
	       (get u 'CharConst)
	       ((lambda (n) (cond ((lessp n 128) n))) (id2int u))
	       (CharError u)))
    ((pairp u) % Here's the real change -- let users add "functions"
      ((lambda (fn)
	 (cond
	   (fn (apply fn (list (dochar (cadr u)))))
	   (t (CharError u))))
       (cond ((idp (car u)) (get (car u) 'char-prefix-function)))))
    ((and (fixp u) (geq u 0) (leq u 9)) (plus u (char 0)))
    (t (CharError u))))

(deflist
  (list
    (list 'lower (function (lambda(x) (lor x 2#100000))))
    (list 'quote (function (lambda(x) x)))
    (list 'control (function (lambda(x) (land x 2#11111))))
    (list 'cntrl (function (lambda(x) (land x 2#11111))))
    (list 'meta (function (lambda(x) (lor x 2#10000000)))))
  'char-prefix-function)

(de CharError (u)
  (ErrorPrintF "*** Unknown character constant: %r" u)
  0)

(DefList '((NULL 0)
	   (BELL 7)
	   (BACKSPACE 8)
	   (TAB 8#11)
	   (LF 8#12)
	   % (RETURN 8#12)	% RETURN is LF: it's end-of-line.  Out! /csp
	   (EOL 8#12)
	   (FF 8#14)
	   (CR 8#15)
	   (ESC 27)
	   (ESCAPE 27)
	   (BLANK 32)
	   (SPACE 32)
	   (RUB 8#177)
	   (RUBOUT 8#177)
	   (DEL 8#177)
	   (DELETE 8#177)
	   ) 'CharConst)