Artifact ca89515cdbb5bdf8b7782a6ea96b654ec4d7765f53c9c6474210a01ffa8cdaea:

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

%
% HOMEDIR.SL - USER-HOMEDIR-STRING function for Tops-20
% 
% Author:      Eric Benson
%              Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        21 September 1982
% Copyright (c) 1982 University of Utah
%

(compiletime (progn
 (load monsym syslisp)
 (put 'get-user-number 'opencode '((gjinf)))
 (flag '(user-homedir-string-aux get-dir-string)
       'internalfunction)))

% Returns a string which is the init file for program-name.
% Optional HOST is not supported.
(de init-file-string (program-name)
  (concat (user-homedir-string) (concat program-name ".INIT")))

% Returns a string which is the users home directory name.
% Optional HOST is not supported.
(lap '((*entry user-homedir-string expr 0)
       (movei (reg 1) (indexed (reg st) 1))	% Pointer into the stack
       (*alloc 20)				% allocate space
       (*call user-homedir-string-aux)	% call the real function
       (*exit 20)))				% deallocate and return

(de user-homedir-string-aux (p)
  (concat "PS:<" (mkstr (get-dir-string p (get-user-number)))))

(lap '((*entry get-dir-string expr 2)
       (*move (reg 1) (reg 5))			% save original addr in ac5
       (hrli (reg 1) 8#10700)			% make a byte pointer
       (*move (reg 1) (reg 3))			% save it in ac3
       (dirst)
         (erjmp cant-get-dir)
       (movei (reg 4) 62)			% put a closing > on it
       (idpb (reg 4) (reg 1))
       (setz (reg 4) 0)				% put a null char on the end
       (idpb (reg 4) (reg 1))
       (seto (reg 4) 0)				% initialize length to -1
string-length-loop
       (ildb (reg 2) (reg 3))
       (jumpe (reg 2) done-computing-length)
       (aoja (reg 4) string-length-loop)
done-computing-length
       (movem (reg 4) (indexed (reg 5) 0))	% put len in string header
       (*move (reg 5) (reg 1))			% return original pointer
       (*exit 0)
cant-get-dir
       (*move (reg 1) '"UNKNOWN>")
       (*exit 0)))