Artifact 34bbc4e7f6c3093bbdc2f0fd42ef9e65e72d0462f4aa460ff7375488fb54f90b:

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

• File psl-1983/util/backquote.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: 4156) [annotate] [blame] [check-ins using]

% BACKQUOTE.SL - tool for building partially quoted lists
%
% Author:      Don Morrison
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        Wednesday, 12 May 1982
% Copyright (c) 1981 University of Utah

% Backquote is  similar  to MACLISP's  `  (that's backwards!)   mechanism.   In
% essence the  body  of  the  backquote is  quoted,  except  for  those  things
% surrounded by unquote, which are evaluated at macro expansion time.  UNQUOTEL
% splices in a  list, and  unquoted splices  in a  list destructively.   Mostly
% useful for defining macro's.

(dm backquote (u) (backquote-form (cadr u)))

(de backquote-form (u)
  (cond
    ((vectorp u) (backquote-vector u))
    ((atom u)
      (cond
	((and (idp u) (not (memq u '(t nil)))) (mkquote u))
	(t u)))
    ((eq (car u) 'unquote) (cadr u))
    ((eq (car u) 'backquote) (backquote-form (backquote-form (cadr u))))
    ((memq (car u) '(unquotel unquoted))
      (ContinuableError 99 (BldMsg "%r can't be spliced in here." u)) u)
    ((eqcar (car u) 'unquotel)
      (cond
	((cdr u) (list 'append (cadar u) (backquote-form (cdr u))))
	(t (cadar u))))
    ((eqcar (car u) 'unquoted)
      (cond
	((cdr u) (list 'nconc (cadar u) (backquote-form (cdr u))))
	(t (cadar u))))    
    (t (backquote-list u))))

(de backquote-vector (u)
  ((lambda (n rslt all-quoted)  % can't use LET 'cause it ain't defined yet
     ((lambda (i)
	(while (not (minusp i)) % can't use FOR or DO for the same reason
	  ((lambda (x)
	     (setq all-quoted (and all-quoted (backquote-constantp x)))
	     (setq rslt (cons x rslt)))
	    (backquote-form (getv u i)))
	  (setq i (sub1 i))))
       n)
     (cond
       (all-quoted
	 ((lambda (i vec)
	    (while (not (greaterp i n))
	      (putv vec i (backquote-constant-value (car rslt)))
	      (setq rslt (cdr rslt))
	      (setq i (add1 i)))
	    vec)
	   0
	   (mkvect n)))
       (t (cons 'vector rslt))))
    (upbv u)
    nil
    t))

(de backquote-list (u)
  ((lambda (car-u cdr-u)  % can't use LET 'cause it ain't defined yet
     (cond
       ((null cdr-u)
	 (cond
	   ((backquote-constantp car-u)
	     (list 'quoted-list (backquote-constant-value car-u)))
	   (t (list 'list car-u))))
       ((constantp cdr-u)
	 (cond
	   ((backquote-constantp car-u)
	     (list 'quoted-list* (backquote-constant-value car-u) cdr-u))
	   (t (list 'list* car-u cdr-u))))
       ((and (pairp cdr-u) (memq (car cdr-u) '(list list*)))
	 (cons (car cdr-u) (cons car-u (cdr cdr-u))))
       ((and
	  (pairp cdr-u)
	  (memq (car cdr-u) '(quoted-list quoted-list*)))
	 (cond
	   ((backquote-constantp car-u)
	     (cons
	       (car cdr-u)
	       (cons (backquote-constant-value car-u) (cdr cdr-u))))
	   (t (list
		'list*
		car-u
		(mkquote (backquote-constant-value cdr-u))))))
       ((eqcar cdr-u 'quote)
	 (cond
	   ((backquote-constantp car-u)
	      (list
	       'quoted-list*
	       (backquote-constant-value car-u)
	       (cadr cdr-u)))
	   (t (list 'list* car-u cdr-u))))
       (t (list 'list* car-u cdr-u))))
    (backquote-form (car u))
    (backquote-form (cdr u))))

(de backquote-constantp (u)
  (cond
    ((pairp u) (memq (car u) '(quote quoted-list quoted-list*)))
    (t (not (idp u)))))

(de backquote-constant-value (x)
  (cond
    ((eqcar x 'quote) (cadr x))
    ((eqcar x 'quoted-list) (cdr x))
    ((eqcar x 'quoted-list*)
      (cadr (apply 'quoted-list* (list x))))
    (t x)))

% The following, while possibly useful in themselves, are mostly included
% for use by backquote and friends.

(dm quoted-list (u) (mkquote (cdr u)))
  
(dm list* (u) (expand (cdr u) 'cons))

(dm quoted-list* (u)
  (cond
    ((pairp (cdr u))
      (setq u (reverse (cdr u)))
      ((lambda (a)
	 (foreach elem in (cdr u) do
	   (setq a (cons elem a)))
	 (mkquote a))
	(car u)))))
%     (t (error ... ?     

% Since unquote and friends should be completely stripped out by backquote,
% make it an error to try and evaluate them.  These could be much better...

(dm unquote (u) (ContinuableError
		  99
		  (BldMsg "%r is not within backquote." u)
		  u))

(copyd 'unquotel 'unquote)

(copyd 'unquoted 'unquote)