# Pathnames für CLISP
# Bruno Haible 31.12.1994
# Logical Pathnames: Marcus Daniels 16.9.1994

#include "lispbibl.c"


#ifdef UNIX
  # Library-Funktion realpath implementieren:
  # [Copyright: SUN Microsystems, B. Haible]
  # TITLE
  #   REALPATH(3)
  # SYNOPSIS
  #   char* realpath (char* path, char resolved_path[MAXPATHLEN]);
  # DESCRIPTION
  #   realpath() expands all symbolic links  and  resolves  refer-
  #   ences  to '/./', '/../' and extra '/' characters in the null
  #   terminated string named by path and stores the canonicalized
  #   absolute pathname in the buffer named by resolved_path.  The
  #   resulting path will have no symbolic links  components,  nor
  #   any '/./' or '/../' components.
  # RETURN VALUES
  #   realpath() returns a pointer to the  resolved_path  on  suc-
  #   cess.   On  failure, it returns NULL, sets errno to indicate
  #   the error, and places in resolved_path the absolute pathname
  #   of the path component which could not be resolved.
  #define realpath  my_realpath  # Consensys deklariert realpath() bereits...
  local char* realpath (char* path, char* resolved_path);
  # Methode: benutze getwd und readlink.
  local char* realpath(path,resolved_path)
    char* path;
    char* resolved_path;
    { char mypath[MAXPATHLEN];
      int symlinkcount = 0; # Anzahl bisher aufgetretener symbolischer Links
      char* resolved_limit = &resolved_path[MAXPATHLEN-1];
      # Gültige Pointer sind die mit resolved_path <= ptr <= resolved_limit.
      # In *resolved_limit darf höchstens noch ein Nullbyte stehen.
      # (Analog mit mypath.)
      char* resolve_start;
      { char* resolved_ptr = resolved_path; # (bleibt stets <= resolved_limit)
        # evtl. Working-Directory benutzen:
        if (!(path[0]=='/')) # kein absoluter Pathname ?
          { if (getwd(resolved_path) == NULL) { return NULL; }
            resolved_ptr = resolved_path;
            while (*resolved_ptr) { resolved_ptr++; }
            if (resolved_ptr < resolved_limit) { *resolved_ptr++ = '/'; }
            resolve_start = resolved_ptr;
          }
          else
          { resolve_start = resolved_ptr = &resolved_path[0]; }
        # Dann path selber einkopieren:
       {char* path_ptr = path;
        while ((resolved_ptr < resolved_limit) && *path_ptr)
          { *resolved_ptr++ = *path_ptr++; }
        # Mit '/' und einem Nullbyte abschließen:
        if (resolved_ptr < resolved_limit) { *resolved_ptr++ = '/'; }
        *resolved_ptr = 0;
      }}
      # Los geht's nun in resolved_path ab resolve_start.
      { char* from_ptr = resolve_start;
        char* to_ptr = resolve_start;
        while ((to_ptr < resolved_limit) && (*from_ptr))
          # Bis hierher hat der Pfad in  resolved_path[0]...to_ptr[-1]
          # die Gestalt '/subdir1/subdir2/.../txt',
          # wobei 'txt' evtl. leer, aber kein subdir leer.
          { char next = *from_ptr++; *to_ptr++ = next;
            if ((next == '/') && (to_ptr > resolved_path+1))
              # to_ptr[-1]='/'  ->  Directory ...to_ptr[-2] auflösen:
              { char* last_subdir_end = &to_ptr[-2];
                switch (*last_subdir_end)
                  { case '/':
                      # '//' wird zu '/' vereinfacht:
                      to_ptr--;
                      break;
                    case '.':
                      { char* last_subdir_ptr = &last_subdir_end[-1];
                        switch (*last_subdir_ptr)
                          { case '.':
                              if (*--last_subdir_ptr == '/')
                                # letztes subdir war '/../'
                                # Dafür das subdir davor entfernen:
                                { while ((last_subdir_ptr > resolved_path) && !(*--last_subdir_ptr == '/'));
                                  to_ptr = last_subdir_ptr+1;
                                }
                              break;
                            case '/':
                              # letztes subdir war '/./'
                              # entfernen:
                              to_ptr = last_subdir_end;
                              break;
                      }   }
                      break;
                    default:
                      # nach einem normalen subdir
                      #ifdef HAVE_READLINK
                      # symbolischen Link lesen:
                      to_ptr[-1]=0; # '/' durch 0 ersetzen
                      { int linklen = readlink(resolved_path,mypath,sizeof(mypath)-1);
                        if (linklen >=0)
                          # war ein symbolisches Link
                          { if (++symlinkcount > MAXSYMLINKS) { errno = ELOOP_VALUE; return NULL; }
                            # noch aufzulösenden path-Anteil an den Link-Inhalt anhängen:
                            { char* mypath_ptr = &mypath[linklen]; # ab hier ist Platz
                              char* mypath_limit = &mypath[MAXPATHLEN-1]; # bis hierher
                              if (mypath_ptr < mypath_limit) { *mypath_ptr++ = '/'; } # erst ein '/' anhängen
                              # dann den Rest:
                              while ((mypath_ptr <= mypath_limit) && (*mypath_ptr = *from_ptr++)) { mypath_ptr++; }
                              *mypath_ptr = 0; # und mit 0 abschließen
                            }
                            # Dies ersetzt bzw. ergänzt den path:
                            if (mypath[0] == '/')
                              # ersetzt den path:
                              { from_ptr = &mypath[0]; to_ptr = resolved_path;
                                while (*to_ptr++ = *from_ptr++);
                                from_ptr = resolved_path;
                              }
                              else
                              # ergänzt den path:
                              { # Linknamen streichen. Dazu bis zum letzten '/' suchen:
                                { char* ptr = &to_ptr[-1];
                                  while ((ptr > resolved_path) && !(*--ptr == '/'));
                                  from_ptr = &ptr[1];
                                }
                                { char* mypath_ptr = &mypath[0]; to_ptr = from_ptr;
                                  while ((to_ptr <= resolved_limit) && (*to_ptr++ = *mypath_ptr++));
                              } }
                            to_ptr = from_ptr;
                          }
                          else
                          #if defined(UNIX_IRIX)
                          if ((errno == EINVAL) || (errno == ENXIO))
                          #elif defined(UNIX_MINT)
                          if ((errno == EINVAL) || (errno == EACCESS))
                          #else
                          if (errno == EINVAL)
                          #endif
                            # kein symbolisches Link
                            { to_ptr[-1] = '/'; } # wieder den '/' eintragen
                          else
                            { return NULL; } # Fehler
                      }
                      #endif
                      break;
              }   }
          } # dann zum nächsten subdir
        # ein '/' am Ende streichen:
        if ((to_ptr[-1] == '/') && (to_ptr > resolved_path+1)) { to_ptr--; }
        to_ptr[0] = 0; # durch 0 abschließen
        return resolved_path; # fertig
    } }
#endif
#ifdef RISCOS
  # SYNOPSIS
  #   char* realpath (char* path, char resolved_path[MAXPATHLEN]);
  # RETURN VALUES
  #   realpath() returns a pointer to the resolved_path on success.
  #   On failure, it returns NULL and sets errno to indicate the error.
  local char* realpath (char* path, char* resolved_path);
  #include <sys/os.h>
  local char* realpath(path,resolved_path)
    var char* path;
    var char* resolved_path;
    { var int handle;
      var int r[10];
      #if 0 # Both of these implementations should work.
      if (os_fopen(0x40,path,&handle)) { return NULL; }
      r[0] = 7; r[1] = handle; r[2] = (long)resolved_path; r[5] = MAXPATHLEN;
      os_swi(9,r);
      os_fclose(handle);
      #else
      var os_error* err;
      r[0] = 37; r[1] = (long)path; r[2] = (long)resolved_path;
      r[3] = 0; r[4] = 0; r[5] = MAXPATHLEN;
      err = os_swi(0x29,r);
      if (err) { __seterr(err); return NULL; }
      #endif
      if (r[5] <= 0)
        { errno = ENOMEM /* ENAMETOOLONG would be better, but does not yet exist */;
          return NULL;
        }
      return resolved_path;
    }
#endif


# ==============================================================================
#                         P A T H N A M E S

#ifdef PATHNAME_ATARI
# Komponenten:
# HOST          stets NIL
# DEVICE        NIL oder :WILD oder "A"|...|"Z"
# DIRECTORY     (Disknummer Startpoint . Subdirs) wobei
#                Disknummer = NIL oder die Seriennummer der Diskette ist,
#                Startpoint = :RELATIVE | :ABSOLUTE
#                Subdirs = () | (subdir . Subdirs)
#                subdir = :CURRENT (bedeutet ".") oder
#                subdir = :PARENT (bedeutet "..") oder
#                subdir = :WILD-INFERIORS (bedeutet "...", alle Subdirectories) oder
#                subdir = (name . type)
#                 name = :WILD oder Simple-String mit max. 8 Zeichen
#                 type = :WILD oder Simple-String mit max. 3 Zeichen
# NAME          NIL oder :WILD oder Simple-String mit max. 8 Zeichen
# TYPE          NIL oder :WILD oder Simple-String mit max. 3 Zeichen
# VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
# Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
# ist :WILD, :WILD-INFERIORS nicht erlaubt, bei NAME evtl. auch nicht NIL.
# Externe Notation: A123456:\sub1.typ\sub2.typ\name.typ
# mit Defaults:             \sub1.typ\sub2.typ\name.typ
# oder                                         name.typ
# oder                    *:\sub1.typ\*.*\name.*
# oder Ähnliches.
#endif

#ifdef PATHNAME_MSDOS
# Komponenten:
# HOST          stets NIL
# DEVICE        NIL oder :WILD oder "A"|...|"Z"
# DIRECTORY     (Startpoint . Subdirs) wobei
#                Startpoint = :RELATIVE | :ABSOLUTE
#                Subdirs = () | (subdir . Subdirs)
#                subdir = :CURRENT (bedeutet ".") oder
#                subdir = :PARENT (bedeutet "..") oder
#                subdir = :WILD-INFERIORS (bedeutet "...", alle Subdirectories) oder
#                subdir = (name . type)
#                 name = :WILD oder Simple-String mit max. 8 Zeichen
#                 type = :WILD oder Simple-String mit max. 3 Zeichen
# NAME          NIL oder :WILD oder Simple-String mit max. 8 Zeichen
# TYPE          NIL oder :WILD oder Simple-String mit max. 3 Zeichen
# VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
# Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
# ist :WILD, :WILD-INFERIORS nicht erlaubt, bei NAME evtl. auch nicht NIL.
# Externe Notation:       A:\sub1.typ\sub2.typ\name.typ
# mit Defaults:             \sub1.typ\sub2.typ\name.typ
# oder                                         name.typ
# oder                    *:\sub1.typ\*.*\name.*
# oder Ähnliches.
# Statt '\' ist - wie unter DOS üblich - auch '/' erlaubt.
#endif

#ifdef PATHNAME_AMIGAOS
# Komponenten:
# HOST          stets NIL
# DEVICE        NIL oder Simple-String
# DIRECTORY     (Startpoint . Subdirs) wobei
#                Startpoint = :RELATIVE | :ABSOLUTE
#                Subdirs = () | (subdir . Subdirs)
#                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
#                subdir = :PARENT (bedeutet "/" statt "subdir/") oder
#                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
# NAME          NIL oder
#               Simple-String, evtl. mit Wildcard-Zeichen ? und *
#               (auch :WILD bei der Eingabe)
# TYPE          NIL oder
#               Simple-String, evtl. mit Wildcard-Zeichen ? und *
#               (auch :WILD bei der Eingabe)
# VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
# Constraint: Startpoint = :RELATIVE nur, falls Device = NIL;
#             bei angegebenem Device gibt es also nur absolute Pathnames!
# Ein AMIGAOS-Filename wird folgendermaßen in Name und Typ aufgespalten:
#   falls kein '.' im Filename: Name = alles, Typ = NIL,
#   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
# Groß-/Klein-Schreibung innerhalb der Strings wird bei Vergleichen ignoriert,
# aber ansonsten findet keine Groß/Klein-Umwandlung statt.
# Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
# ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
# Strings, bei NAME evtl. auch nicht NIL.
# Externe Notation:  device:sub1.typ/sub2.typ/name.typ
# mit Defaults:             sub1.typ/sub2.typ/name.typ
# oder                                        name.typ
# oder                      sub1.typ/ ** /sub3.typ/x*.lsp  (ohne Spaces!)
# oder Ähnliches.
# Formal:
#   ch ::= beliebgiges Character außer ':','/' und '*','?'
#   name ::= {ch}+
#   device ::= [ <leer> | ':' | name ':' ]
#              ; leer = aktuelles Device, relativ ab aktuellem Directory
#              ; ':'  = aktuelles Device, absolut (ab root bei Disks)
#              ; name ':' = angegebenes Device, absolut (ab root bei Disks)
#   subdir ::= [ <leer> | name ]                ; leer = '..'
#   pathname ::= device { subdir '/' }* name
# Beispiele:
#   String        Device    Directory                unser Pathname
#   ------        ------    ---------                --------------
#   'c:foo'       'C',     device->foo               "c" (:ABSOLUTE "foo")
#   'c:foo/'      'C',     device->foo               "c" (:ABSOLUTE "foo")
#   'c:foo/bar'   'C',     device->foo->bar          "c" (:ABSOLUTE "foo" "bar")
#   'c:/foo'      'C',     device->up->foo           "c" (:ABSOLUTE :PARENT "foo")
#   'c:'          'C',     device                    "c" (:ABSOLUTE)
#   ':foo'        current, device->root->foo         NIL (:ABSOLUTE "foo")
#   'foo'         current, device->foo               NIL (:RELATIVE "foo")
#   '/foo'        current, device->up->foo           NIL (:RELATIVE :PARENT "foo")
#   '//foo/bar'   current, device->up->up->foo->bar  NIL (:RELATIVE :PARENT :PARENT "foo" "bar")
#   ''            current, device                    NIL (:RELATIVE)
# An einen Pathstring, der nichtleer ist und der nicht mit ':' oder '/'
# endet, kann ein '/' angehängt werden, ohne seine Semantik zu verändern.
# Dieser '/' muß angehängt werden, bevor man eine weitere nichtleere
# Komponente anhängen kann.
# An einen Pathstring, der leer ist oder mit ':' oder '/' endet, ein '/'
# anzuhängen, bedeutet aber, zum Parent Directory aufzusteigen!
# Bei uns wird jeder Pathstring, der leer ist oder mit ':' oder '/' endet,
# als Directory-Pathname (mit Name=NIL und Type=NIL) interpretiert.
#endif

#ifdef PATHNAME_UNIX
# Komponenten:
# HOST          stets NIL
# DEVICE        stets NIL
# DIRECTORY     (Startpoint . Subdirs) wobei
#                Startpoint = :RELATIVE | :ABSOLUTE
#                Subdirs = () | (subdir . Subdirs)
#                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
#                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
# NAME          NIL oder
#               Simple-String, evtl. mit Wildcard-Zeichen ? und *
#               (auch :WILD bei der Eingabe)
# TYPE          NIL oder
#               Simple-String, evtl. mit Wildcard-Zeichen ? und *
#               (auch :WILD bei der Eingabe)
# VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
# Ein UNIX-Filename wird folgendermaßen in Name und Typ aufgespalten:
#   falls kein '.' im Filename: Name = alles, Typ = NIL,
#   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
# Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
# ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
# Strings, bei NAME evtl. auch nicht NIL.
# Externe Notation:  server:/sub1.typ/sub2.typ/name.typ
# mit Defaults:             /sub1.typ/sub2.typ/name.typ
# oder                                         name.typ
# oder                      /sub1.typ/ ** /sub3.typ/x*.lsp  (ohne Spaces!)
# oder Ähnliches.
#endif

#ifdef PATHNAME_OS2
# Komponenten:
# HOST          stets NIL
# DEVICE        NIL oder :WILD oder "A"|...|"Z"
# DIRECTORY     (Startpoint . Subdirs) wobei
#                Startpoint = :RELATIVE | :ABSOLUTE
#                Subdirs = () | (subdir . Subdirs)
#                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
#                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
# NAME          NIL oder
#               Simple-String, evtl. mit Wildcard-Zeichen ? und *
#               (auch :WILD bei der Eingabe)
# TYPE          NIL oder
#               Simple-String, evtl. mit Wildcard-Zeichen ? und *
#               (auch :WILD bei der Eingabe)
# VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
# Ein OS/2-Filename wird folgendermaßen in Name und Typ aufgespalten:
#   falls kein '.' im Filename: Name = alles, Typ = NIL,
#   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
# Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
# ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
# Strings, bei NAME evtl. auch nicht NIL.
# Externe Notation:       A:\sub1.typ\sub2.typ\name.typ
# mit Defaults:             \sub1.typ\sub2.typ\name.typ
# oder                                         name.typ
# oder                    *:\sub1.typ\**\sub3.typ\x*.lsp
# oder Ähnliches.
# Statt '\' ist - wie unter DOS üblich - auch '/' erlaubt.
#endif

#ifdef PATHNAME_RISCOS
#
# Peter Burwood <clisp@arcangel.demon.co.uk> writes:
#
# RISC OS provides several filing systems as standard (ADFS, IDEFS, NetFS,
# RamFS, NetPrint) and support for extra filing systems (DOSFS, ResourceFS and
# DeviceFS).
#
# A module called FileSwitch is at the centre of all filing system operation
# in RISC OS. FileSwicth provides a common core of functions used by all
# filing systems. It only provides the parts of these services that are device
# independent. The device dependant services that control the hardware are
# provided by separate modules, which are the actual filing systems.
# FileSwitch keeps track of active filing systems and switches betwen them as
# necessary.
#
# One of the filing system modules that RISC OS provides is FileCore. It takes
# the normal calls that FileSwitch sneds to a filing system module, and
# converts them to a simpler set of calls to modules that control the
# hardware. Unlike FileSwitch it creates a fresh instantiation of itself for
# each module that it supports. Using FileCore to build filing system modules
# imposes a more rigid structure on it, as more of the filing system is
# predefined.
#
# As well as standard filing systems, FileSwitch supports image filing
# systems. These provide facilities for RISC OS to handle media in foreign
# formats, and to support `image files' (or partitions) in those formats.
# Rather than accessing the hardware directly they rely on standard RISC OS
# filing systems to do so. DOSFS is an example of an image filing system used
# to handle DOS format discs.
#
# Terminology
#
# A pathname may include a filing system name, a special field, a media name
# (e.g., a disc name), directory name(s), and the name of the object itself;
# each of these parts of a pathname is known as an `element' of the pathname.
#
# Filenames
#
# Filename `elements' may be up to ten characters in length on FileCore-based
# filing systems and on NetFS. These characters may be digits or letters.
# FileSwitch makes no distinction between upper and lower case, although
# filing systems can do so. As a general rule, you should not use top-bit-set
# characters in filenames, although some filing systems (such as
# FileCore-based ones) support them. Other characters may be used provided
# they do not have a special significance. Those that do are listed below :
#
#    .   Separates directory specifications, e.g., $.fred
#    :   Introduces a drive or disc specification, e.g., :0, :bigdisc. It also
#        marks the end of a filing system name, e.g., adfs:
#    *   Acts as a `wildcard' to match zero or more characters.
#    #   Acts as a `wildcard' to match any single character.
#    $   is the name of the root directory of the disc.
#    &   is the user root directory (URD)
#    @   is the currently selected directory (CSD)
#    ^   is the `parent' directory
#    %   is the currently selected library (CSL)
#    \   is the previously selected directory (PSD)
#
# Directories
#
# The root directory, $, forms the top of the directory hierarchy
# of the media which contains the CSD. $ does not have a parent directory,
# trying to access its parent will just access $. Each directory name is
# separated by a '.' character. For example:
#
#    $.Documents.Memos
#    %.cc
#
# Filing Systems
#
# Files may also be accessed on filing systems other than the current one by
# prefixing the filename with a filing system specification. A filing system
# name may appear between '-' characters, or suffixed by a ':', though the
# latter is advised since '-' can also be used to introduce a parameter on a
# command line, or as part of a file name. For example:
#
#    -net-$.SystemMesg
#    adfs:%.aasm
#
# Special Fields
#
# Special fields are used to supply more information to the filing system than
# you can using standard path names; for example NetFS and NetPrint use them
# to specify server addresses or names. They are introduced by a '#'
# character; a variety of syntaxes are possible:
#
#    net#MJHardy::disc1.mike
#       #MJHardy::disc1.mike
#   -net#MJHardy-:disc1.mike
#      -#MJHardy-:disc1.mike
#
# The special fields here are all MJHardy, and give the name of the fileserver
# to use. Special fields may use any character except for control characters,
# double quote '"', solidus '|' and space. If a special field contains a hypen
# you may only use the first two syntaxes given above.
#
# File$Path and Run$Path
#
# These two special variables control exactly where a file will be looked for,
# according to the operation being performed on it.
#
#    File$Path   for read operations
#    Run$Path    for execute operations
#
# The contents of each variable should expand to a list or prefixes, separated
# by commas. When a read operation is performed then the prefixes in File$Path
# are used in the order in which they are listed. The first object that
# matches is used, whether it be a file or directory. Similarly any execute
# operation uses the prefixes in Run$Path. These search paths are only used
# when the pathname does not contain an explicit filing system reference,
# e.g., executing adfs:file will not use Run$Path.
#
# Other path variables
#
# You can set up other path variables and use them as pseudo filing systems.
# For example if you typed:
#
#    *Set Source$Path adfs:$.src.,adfs:$.public.src.
#
# you could then refer to the pseudo filing system as Source: or (less
# preferable) as -Source-. These path variables work in the same was as
# File$Path and Run$Path.
#
#
# from Lisp-string notation to internal representation
# ----------------------------------------------------
# NO swapping. "foo.lsp" means file type "lsp" and file name "foo".
# This is pseudo-BNF:
#
# legal character ::= any ISO latin-1 graphic character >= ' ' except
#                     '.' ':' '*' '#' '$' '&' '@' '^' '%' '\' '?'
#
# extended legal character ::= any ISO latin-1 graphic character >= ' ' except
#                              ':' '"' '|'
#
# legal-wild char ::= legal char | '*' | '#' | '?'
#
# host ::=   '-' { extended legal char except '-' }+ '-'
#          | { extended legal char except '-' } { extended legal char }* ':'
#          | empty
#
# device ::=   ':' { legal char }+ '.'
#            | empty
#
# directory ::=   { '$' | '&' | '@' | '%' | '\' } '.' { subdirectory }*
#               | { subdirectory }+
#               | empty
# In the first case, '&', '%', '\' get resolved. (Or maybe they are not
# yet resolved, but get treated similarly to '@' -> :ABSOLUTE :CURRENT.)
# '$' -> :ABSOLUTE :ROOT, '@' -> :ABSOLUTE :CURRENT, else :RELATIVE.
#
# subdirectory ::= { '^' | { legal-wild char }+ } '.'
#                  '^' -> :PARENT
#
# filename ::= { { legal-wild char }+ | empty }
#
# filetype ::= { '.' { legal-wild char }+ | empty }
#
# pathname ::= host device directory filename filetype
#
# Examples:
# String                          Hostname Device  Directory            Name         Type
# -net-$.SystemMesg                "net"   NIL     (:ABSOLUTE :ROOT)    "SystemMesg" NIL
# net#MJHardy::disc1.mike    "net#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
# #MJHardy::disc1.mike          "#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
# -net#MJHardy-:disc1.mike   "net#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
# -#MJHardy-:disc1.mike         "#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
# @.foo                            NIL     NIL     (:ABSOLUTE :CURRENT) "foo"        NIL
# foo                              NIL     NIL     (:RELATIVE)          "foo"        NIL
# ^.                               NIL     NIL     (:RELATIVE :PARENT)  NIL          NIL
# @.^.                             NIL     NIL     (:ABSOLUTE :CURRENT :PARENT) NIL  NIL
# foo.bar                          NIL     NIL     (:RELATIVE)          "foo"        "bar"
# foo.bar.baz                      NIL     NIL     (:RELATIVE "foo")    "bar"        "baz"
# foo.bar.                         NIL     NIL     (:RELATIVE "foo" "bar") NIL       NIL
# foo.@.                       illegal
#
# from internal representation to RISCOS string
# ---------------------------------------------
#
# with swapping _only_ of name/type components.
# Assume '%' refers to "$.lib."
#
# Hostname    Device  Directory                   Name    Type      RISCOS String
#
# "net"       "disc1" (:ABSOLUTE :ROOT)           "foo"   NIL       "net::disc1.$.foo"
# "net#MJ"    "disc1" (:ABSOLUTE :ROOT "foo")     "bar"   "baz"     "net#MJ::disc1.$.foo.baz.bar"
# "adfs"      "4"     (:ABSOLUTE :ROOT "foo" "bar") NIL   NIL       "adfs::4.$.foo.bar"
# NIL         "disc1" (:ABSOLUTE :ROOT "foo")     "bar"   NIL       ":disc1.$.foo.bar"
# NIL         "disc1" (:ABSOLUTE :CURRENT)        NIL     NIL       illegal here
# NIL         "disc1" (:RELATIVE)                 NIL     NIL       ":disc1."
# NIL         "disc1" NIL                         NIL     NIL       ":disc1."
# NIL         NIL     (:ABSOLUTE :ROOT)           "foo"   NIL       "$.foo"
# NIL         NIL     (:ABSOLUTE :CURRENT)        "foo"   NIL       "@.foo"
# NIL         NIL     (:RELATIVE)                 "foo"   "bar"     "bar.foo"
# NIL         NIL     (:RELATIVE "foo")           "bar"   "baz"     "foo.baz.bar"
# NIL         NIL     (:ABSOLUTE :ROOT "%")       "bar"   NIL       "$.lib.bar"
# NIL         NIL     (:ABSOLUTE :ROOT "%" "foo") "bar"   NIL       "$.lib.foo.bar"
# NIL         NIL     (:RELATIVE)                 "foo"   "bar"     "bar.foo"
# NIL         NIL     (:RELATIVE "foo")           "bar"   NIL       "foo.bar"
# NIL         NIL     (:RELATIVE "foo")           NIL     "bar"     illegal here
#
# That is, the RISCOS string is the flattenation-concatenation of
#   (append
#     (if (null hostname) "" (append hostname ":"))
#     (if (null device) "" (append ":" device "."))
#     (case (pop directory)
#       (:ABSOLUTE (case (pop directory) (:ROOT "$.") (:CURRENT "@.")))
#       (:RELATIVE "")
#     )
#     (mapcar (lambda (subdir) (append subdir ".")) directory)
#     (if (null name)
#       (if (null type) "" (error "type with name illegal here"))
#       (if (null type)
#         name
#         (append type "." name)
#   ) ) )
#
# internal representation
# -----------------------
#
# Komponenten:
# HOST          Simple-String oder NIL
# DEVICE        Simple-String oder NIL
# DIRECTORY     (Startpoint . Subdirs) wobei
#                Startpoint = :RELATIVE | :ABSOLUTE Anker
#                Anker = :ROOT | :HOME | :CURRENT | :LIBRARY | :PREVIOUS
#                Subdirs = () | (subdir . Subdirs)
#                subdir = :PARENT oder
#                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
# NAME          NIL oder
#               Simple-String, evtl. mit Wildcard-Zeichen ? und *
#               (auch :WILD bei der Eingabe)
# TYPE          NIL oder
#               Simple-String, evtl. mit Wildcard-Zeichen ? und *
#               (auch :WILD bei der Eingabe)
# VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
#
#endif

#ifdef LOGICAL_PATHNAMES
# Komponenten von Logical Pathnames:
# HOST          Simple-String oder NIL
# DEVICE        stets NIL
# DIRECTORY     (Startpoint . Subdirs) wobei
#                Startpoint = :RELATIVE | :ABSOLUTE
#                Subdirs = () | (subdir . Subdirs)
#               subdir = :WILD-INFERIORS (bedeutet "**", alle Subdirectories) oder
#               subdir = :WILD (bedeutet "*") oder
#               subdir = Simple-String, evtl. mit Wildcard-Zeichen *
# NAME          NIL oder
#               :WILD (bedeutet "*") oder
#               Simple-String, evtl. mit Wildcard-Zeichen *
# TYPE          NIL oder
#               :WILD (bedeutet "*") oder
#               Simple-String, evtl. mit Wildcard-Zeichen *
# VERSION       NIL oder :NEWEST oder :WILD oder Integer
# Externe Notation: siehe CLtl2 S. 628-629.
#endif

# Wandelt Groß-/Klein-Schreibung zwischen :LOCAL und :COMMON um.
# common_case(string)
# > string: Simple-String oder Symbol/Zahl
# < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
# kann GC auslösen
  local object common_case (object string);
# Dasselbe, rekursiv wie mit SUBST:
  local object subst_common_case (object obj);
#if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS) || defined(PATHNAME_AMIGAOS)
  # Betriebssystem mit Vorzug für Kleinbuchstaben oder Capitalize
  local object common_case(string)
    var reg6 object string;
    { if (!simple_string_p(string))
        return string;
     {var reg7 uintL len = TheSstring(string)->length;
      # Suche, ob Groß- oder Kleinbuchstaben (oder beides) vorkommen:
      var reg5 boolean all_upper = TRUE;
      var reg4 boolean all_lower = TRUE;
      { var reg2 uintB* ptr = &TheSstring(string)->data[0];
        var reg3 uintL count;
        dotimesL(count,len,
          { var reg1 uintB ch = *ptr++;
            if (!(ch == up_case(ch))) { all_upper = FALSE; }
            if (!(ch == down_case(ch))) { all_lower = FALSE; }
            if (!all_upper && !all_lower) break;
          });
      }
      if (all_upper == all_lower)
        # all_upper = all_lower = TRUE: Nichts zu konvertieren.
        # all_upper = all_lower = FALSE: "Mixed case represents itself."
        return string;
      if (all_upper)
        # all_upper = TRUE, all_lower = FALSE: STRING-DOWNCASE
        return string_downcase(string);
        else
        # all_upper = FALSE, all_lower = TRUE: STRING-UPCASE
        return string_upcase(string);
    }}
  local object subst_common_case(obj)
    var reg1 object obj;
    { if (atomp(obj))
        { return common_case(obj); }
      check_STACK(); check_SP();
      pushSTACK(obj);
      # rekursiv für den CAR aufrufen:
      { var reg2 object new_car = subst_common_case(Car(obj));
        pushSTACK(new_car);
      }
      # rekursiv für den CDR aufrufen:
      { var reg2 object new_cdr = subst_common_case(Cdr(STACK_1));
        if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
          { obj = STACK_1; skipSTACK(2); return obj; }
          else
          # (CONS new_car new_cdr)
          { STACK_1 = new_cdr;
           {var reg1 object new_cons = allocate_cons();
            Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
            return new_cons;
    } }   }}
#else # defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  # Betriebssystem mit Vorzug für Großbuchstaben
  #define common_case(string)  string
  #define subst_common_case(obj)  obj
#endif

#ifdef LOGICAL_PATHNAMES

local boolean legal_logical_word_char (uintB ch);
local boolean legal_logical_word_char(ch)
  var reg1 uintB ch;
  { ch = up_case(ch);
    if (((ch >= 'A') && (ch <= 'Z'))
        || ((ch >= '0') && (ch <= '9'))
        || (ch == '-')
       )
      return TRUE;
      else
      return FALSE;
  }

#endif

#if HAS_HOST

# UP: Stellt fest, ob ein Character als Zeichen im Host-Teil eines Namestring
# erlaubt ist.
# legal_hostchar(ch)
# > uintB ch: Character-Code
# < ergebnis: TRUE falls erlaubt, FALSE sonst
  local boolean legal_hostchar (uintB ch);
# NB: legal_logical_word_char(ch) impliziert legal_hostchar(ch).
  local boolean legal_hostchar(ch)
    var reg1 uintB ch;
    {
      #ifdef PATHNAME_RISCOS
      return (graphic_char_p(ch) && !(ch==':') && !(ch=='"') && !(ch=='|'));
      #else
      return alphanumericp(ch) || (ch=='-');
      #endif
    }

# UP: Überprüft ein optionales Host-Argument.
# test_optional_host(host,convert)
# > host: Host-Argument
# > convert: Flag, ob Case-Konversion erwünscht ist
# > subr_self: Aufrufer (ein SUBR)
# < ergebnis: gültige Host-Komponente
# kann GC auslösen
  local object test_optional_host (object host, boolean convert);
  local object test_optional_host(host,convert)
    var reg4 object host;
    var reg5 boolean convert;
    { if (eq(host,unbound)) { return NIL; } # nicht angegeben -> NIL
      if (nullp(host)) goto OK; # NIL ist OK
      # Sonst muß host ein String sein, dessen Zeichen alphanumerisch sind:
      if (!stringp(host))
        { pushSTACK(host); # Wert für Slot DATUM von TYPE-ERROR
          pushSTACK(O(type_host)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
          pushSTACK(host);
          pushSTACK(TheSubr(subr_self)->name);
          fehler(type_error,
                 DEUTSCH ? "~: Host muß NIL oder ein String sein, nicht ~" :
                 ENGLISH ? "~: host should be NIL or a string, not ~" :
                 FRANCAIS ? "~ : Le nom de machine hôte doit être NIL ou de type STRING et non ~" :
                 ""
                );
        }
      host = coerce_ss(host); # als Simple-String
      if (convert) { host = common_case(host); }
      { var reg3 uintL len = TheSstring(host)->length;
        var reg2 uintB* charptr = &TheSstring(host)->data[0];
        dotimesL(len,len,
          { var reg1 uintB ch = *charptr++;
            if (!legal_hostchar(ch)) goto badhost;
          });
      }
      OK: return host;
      badhost:
        { pushSTACK(host);
          pushSTACK(TheSubr(subr_self)->name);
          fehler(error,
                 DEUTSCH ? "~: syntaktisch illegaler Hostname ~" :
                 ENGLISH ? "~: illegal hostname ~" :
                 FRANCAIS ? "~ : Syntaxe incorrecte pour un nom de machine hôte: ~" :
                 ""
                );
        }
    }

#else

#ifdef LOGICAL_PATHNAMES

# UP: Überprüft ein optionales Host-Argument.
# test_optional_host(host)
# > host: Host-Argument
# > subr_self: Aufrufer (ein SUBR)
# < ergebnis: gültige Host-Komponente
# kann GC auslösen
  local object test_optional_host (object host);
  local object test_optional_host(host)
    var reg4 object host;
    { if (eq(host,unbound)) { return NIL; } # nicht angegeben -> NIL
      if (nullp(host)) goto OK; # NIL ist OK
      # Sonst muß host ein String sein, dessen Zeichen alphanumerisch sind:
      if (!stringp(host))
        { pushSTACK(host); # Wert für Slot DATUM von TYPE-ERROR
          pushSTACK(O(type_host)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
          pushSTACK(host);
          pushSTACK(TheSubr(subr_self)->name);
          fehler(type_error,
                 DEUTSCH ? "~: Host muß NIL oder ein String sein, nicht ~" :
                 ENGLISH ? "~: host should be NIL or a string, not ~" :
                 FRANCAIS ? "~ : Le nom de machine hôte doit être NIL ou de type STRING et non ~" :
                 ""
                );
        }
      host = coerce_ss(host); # als Simple-String
      { var reg3 uintL len = TheSstring(host)->length;
        var reg2 uintB* charptr = &TheSstring(host)->data[0];
        dotimesL(len,len,
          { var reg1 uintB ch = *charptr++;
            if (!legal_logical_word_char(ch)) goto badhost;
          });
      }
      OK: return host;
      badhost:
        { pushSTACK(host);
          pushSTACK(TheSubr(subr_self)->name);
          fehler(error,
                 DEUTSCH ? "~: syntaktisch illegaler Hostname ~" :
                 ENGLISH ? "~: illegal hostname ~" :
                 FRANCAIS ? "~ : Syntaxe incorrecte pour un nom de machine hôte: ~" :
                 ""
                );
        }
    }

#else

# UP: Überprüft ein optionales Host-Argument.
# test_optional_host(host);
# > host: Host-Argument
# > subr_self: Aufrufer (ein SUBR)
# < ergebnis: gültige Host-Komponente
  local object test_optional_host (object host);
  local object test_optional_host(host)
    var reg1 object host;
    { if (!eq(host,unbound)) # nicht angegeben -> OK
        { if (!nullp(host)) # angegeben -> sollte =NIL sein
            { pushSTACK(host); # Wert für Slot DATUM von TYPE-ERROR
              pushSTACK(S(null)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
              pushSTACK(host);
              pushSTACK(TheSubr(subr_self)->name);
              fehler(type_error,
                     DEUTSCH ? "~: Host muß NIL sein, nicht ~" :
                     ENGLISH ? "~: host should be NIL, not ~" :
                     FRANCAIS ? "~ : Le nom de machine hôte doit être NIL et non ~" :
                     ""
                    );
            }
        }
      return NIL;
    }

#endif

#endif

# Stellt fest, ob zwei Characters als Zeichen in Pathnames als gleich gelten.
# equal_pathchar(ch1,ch2)
# > uintB ch1,ch2: Character-Codes
# < ergebnis: TRUE falls gleich, FALSE sonst
  #if !(defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2))
    #define equal_pathchar(ch1,ch2)  ((ch1)==(ch2))
  #else # defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
    # Case-insensitive, aber normalerweise ohne Konversion
    #define equal_pathchar(ch1,ch2)  (up_case(ch1)==up_case(ch2))
  #endif

# UP: Stellt fest, ob ein Character als Zeichen im Namens-/Typ-Teil eines
# Namestring erlaubt ist.
# legal_namechar(ch)
# > uintB ch: Character-Code
# < ergebnis: TRUE falls erlaubt, FALSE sonst
  local boolean legal_namechar (uintB ch);
  local boolean legal_namechar(ch)
    var reg1 uintB ch;
    {
      #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
      return ((ch=='_') || (ch=='-') || alphanumericp(ch));
      #endif
      #ifdef PATHNAME_AMIGAOS
      return (graphic_char_p(ch) && !(ch=='/') && !(ch==':'));
      #endif
      #ifdef PATHNAME_UNIX
      return ((ch>=' ') && (ch<='~') && !(ch=='/'));
      #endif
      #ifdef PATHNAME_OS2
      return (graphic_char_p(ch) && !(ch=='\\') && !(ch=='/') && !(ch==':'));
      #endif
      #ifdef PATHNAME_RISCOS
      return (graphic_char_p(ch) && !(ch==':') && !(ch=='.')
              && !(ch=='$') && !(ch=='&') && !(ch=='@')
              && !(ch=='^') && !(ch=='%') && !(ch=='\\')
              # Wild Characters '*' '#' '?' sind hier erlaubt.
             );
      #endif
    }

# Stellt fest, ob ein Character ein Wildcard-Platzhalter für ein einzelnes
# Zeichen ist.
# singlewild_char_p(ch)
# > uintB ch: Character-Code
# < ergebnis: TRUE falls ja, FALSE sonst
  #if !defined(PATHNAME_RISCOS)
    #define singlewild_char_p(ch)  ((ch)=='?')
  #else # defined(PATHNAME_RISCOS)
    #define singlewild_char_p(ch)  (((ch)=='?') || ((ch)=='#'))
  #endif

# Wandelt ein Objekt in einen Pathname um.
  local object coerce_xpathname (object obj); # später

# Wandelt ein Objekt in einen nicht-Logical Pathname um.
  local object coerce_pathname (object obj); # später
#if !defined(LOGICAL_PATHNAMES)
  #define coerce_pathname(obj)  coerce_xpathname(obj)
#endif

# Liefert den Default-Pathname.
  local object defaults_pathname (void); # später

# Überprüft einen Default-Pathname.
# test_default_pathname(defaults)
# > defaults: Defaults-Argument
# < ergebnis: Wert des Defaults-Arguments, ein Pathname
# kann GC auslösen
  local object test_default_pathname (object defaults);
  local object test_default_pathname(defaults)
    var reg1 object defaults;
    { if (eq(defaults,unbound))
        # nicht angegeben -> Wert von *DEFAULT-PATHNAME-DEFAULTS* nehmen:
        { return defaults_pathname(); }
        else
        # angegeben -> zu einem Pathname machen:
        { return coerce_xpathname(defaults); }
    }

# Fehlermeldung wegen illegalem Pathname-Argument.
# fehler_thing(thing);
# > thing: (fehlerhaftes) Argument
# > subr_self: Aufrufer (ein SUBR)
  nonreturning_function(local, fehler_thing, (object thing));
  local void fehler_thing(thing)
    var reg1 object thing;
    { pushSTACK(thing);
      pushSTACK(TheSubr(subr_self)->name);
      fehler(error, # type_error ??
             DEUTSCH ? "~: Argument muß ein String, Symbol, File-Stream oder Pathname sein, nicht ~" :
             ENGLISH ? "~: argument should be a string, symbol, file stream or pathname, not ~" :
             FRANCAIS ? "~ : L'argument doit être une chaîne, un symbole, un «stream» de fichier ou un «pathname» et non ~" :
             ""
            );
    }

# Verfolgt eine Kette von Synonym-Streams, solange bis bei einem File-Stream
# angelangt.
# as_file_stream(stream)
# > stream: Stream
# < stream: File-Stream
  local object as_file_stream (object stream);
  local object as_file_stream(stream)
    var reg2 object stream;
    { var reg1 object s = stream;
      loop
        { if_strm_file_p(s, { return s; } , ; );
          if (!(TheStream(s)->strmtype == strmtype_synonym)) break;
          s = Symbol_value(TheStream(stream)->strm_synonym_symbol);
          if (!streamp(s)) break;
        }
      fehler_thing(stream);
    }

#if defined(UNIX) || defined(MSDOS) || defined(RISCOS)

#if defined(UNIX) || defined(MSDOS)
  #define slash  '/'
#endif
#ifdef RISCOS
  #define slash  '.'
#endif

# UP: Wandelt eine Unix-Directory-Angabe in ein Pathname um.
# asciz_dir_to_pathname(path)
# > const char* path: path als ASCIZ-String
# < ergebnis: als Pathname ohne Name und Typ
  local object asciz_dir_to_pathname (const char* path);
  local object asciz_dir_to_pathname(path)
    var reg4 const char* path;
     { var reg1 const char* pathptr = path;
       var reg2 uintL len = 0; # Stringlänge
       until (*pathptr == 0) { pathptr++; len++; } # ASCIZ-Stringende suchen
       # Sofern der String nicht schon mit '/' endet, wird ein '/' angefügt:
       if (!((len>0) && (pathptr[-1]==slash))) { len++; }
       # und in einen String umwandeln:
      {var reg3 object pathname = make_string((const uintB*)path,len);
       TheSstring(pathname)->data[len-1] = slash; # abschließendes '/' unterbringen
       # und in ein Pathname umwandeln:
       return coerce_pathname(pathname);
     }}

#endif

# Typ für PARSE-NAMESTRING:
# Der String wird durchlaufen.
  typedef struct { uintL index; # Index (incl. Offset)
                   object FNindex; # Index als Fixnum
                   uintL count; # Anzahl der verbleibenden Characters
                 }
          zustand;

#ifdef LOGICAL_PATHNAMES

# Parst einen Logical-Pathname.
# parse_logical_pathnamestring(z)
# > STACK_1: Datenvektor
# > STACK_0: neuer Logical Pathname
# > zustand z: Start-Zustand
# < STACK_0: selber Logical Pathname, ausgefüllt
# < ergebnis: Anzahl der übriggebliebenen Zeichen
# kann GC auslösen
local uintL parse_logical_pathnamestring (zustand z);

# Trennzeichen zwischen subdirs
#define slashp(c)  ((c) == ';')

# Parst Name/Type/Version-Teil (subdirp=FALSE) bzw. subdir-Teil (subdirp=TRUE).
# Liefert Simple-String oder :WILD oder :WILD-INFERIORS oder NIL.
local object parse_logical_word (zustand* z, boolean subdirp);
local object parse_logical_word(z,subdirp)
  var reg1 zustand* z;
  var reg7 boolean subdirp;
  { var zustand startz = *z; # Start-Zustand
    var reg4 uintB ch;
    # Kommt eine Folge von alphanumerischen Zeichen oder '*',
    # keine zwei '*' adjazent (ausgenommen "**", falls subdirp),
    # und, falls subdirp, ein ';' ?
    var reg8 boolean last_was_star = FALSE;
    var reg9 boolean seen_starstar = FALSE;
    loop
      { if (z->count == 0) break;
        ch = TheSstring(STACK_2)->data[z->index]; # nächstes Character
        if (!legal_logical_word_char(ch))
          { if (ch == '*')
              { if (last_was_star)
                  { if (subdirp && (z->index - startz.index == 1))
                      seen_starstar = TRUE;
                      else
                      break; # adjazente '*' sind verboten
                  }
                  else
                  last_was_star = TRUE;
              }
              else
              break;
          }
        # Character übergehen:
        z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
      }
   {var reg5 uintL len = z->index - startz.index;
    if (subdirp)
      { if ((z->count == 0) || !slashp(ch))
          { *z = startz; return NIL; } # kein ';' -> kein subdir
        # Character ';' übergehen:
        z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
      }
    if (len==0)
      { return NIL; }
    elif ((len==1) && (TheSstring(STACK_2)->data[startz.index]=='*'))
      { return S(Kwild); }
    elif ((len==2) && seen_starstar)
      { return S(Kwild_inferiors); }
    else # String bilden:
      { var reg6 object result = allocate_string(len);
        # und füllen:
        {var reg2 uintB* ptr1 = &TheSstring(STACK_2)->data[startz.index];
         var reg3 uintB* ptr2 = &TheSstring(result)->data[0];
         dotimespL(len,len, { *ptr2++ = up_case(*ptr1++); });
        }
        return result;
      }
  }}

# Test auf Ziffernfolge:
local boolean all_digits (object string);
local boolean all_digits(string)
  var reg4 object string;
  { var reg2 uintB* charptr = &TheSstring(string)->data[0];
    var reg3 uintL len = TheSstring(string)->length;
    dotimesL(len,len,
      { var reg1 uintB ch = *charptr++;
        if (!((ch >= '0') && (ch <= '9'))) return FALSE;
      });
    return TRUE;
  }

local uintL parse_logical_pathnamestring(z)
  var zustand z;
  { # Host-Specification parsen:
    { var reg5 object host;
      var zustand startz = z; # Start-Zustand
      var reg1 uintB ch;
      # Kommt eine Folge von alphanumerischen Zeichen und dann ein ':' ?
      loop
        { if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
          ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
          if (!legal_logical_word_char(ch)) break;
          # alphanumerisches Character übergehen:
          z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
        }
      if (!(ch==':')) goto no_hostspec; # kein ':' -> kein Host
      # Host-String bilden:
      { var reg4 uintL len = z.index - startz.index;
        host = allocate_string(len);
        # und füllen:
       {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
        var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
        dotimesL(len,len, { *ptr2++ = up_case(*ptr1++); });
      }}
      # Character ':' übergehen:
      z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
      goto hostspec_ok;
     no_hostspec: # keine Host-Specification
      z = startz; # zum Start zurück
      host = STACK_(3+2); # Default-Host
     hostspec_ok:
      # Host eintragen:
      TheLogpathname(STACK_0)->pathname_host = host;
    }
    # Directory-Start eintragen:
    { var reg1 object new_cons = allocate_cons(); # neues Cons für Startpoint
      TheLogpathname(STACK_0)->pathname_directory = new_cons;
      pushSTACK(new_cons); # neues (last (pathname-directory Pathname))
    }
    # Stackaufbau: Datenvektor, Pathname, (last (pathname-directory Pathname)).
    # Subdirectories parsen:
    # Falls sofort ein ';' kommt, wird er übergangen, und es kommt :RELATIVE
    # (sonst :ABSOLUTE) als erstes subdir:
    if ((!(z.count == 0)) && slashp(TheSstring(STACK_2)->data[z.index]))
      # Es kommt sofort ein ';'.
      { # Character übergehen:
        z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
        Car(STACK_0) = S(Krelative); # Startpoint = :RELATIVE
      }
      else
      # Es kommt nicht sofort ein ';'.
      { Car(STACK_0) = S(Kabsolute); } # Startpoint = :ABSOLUTE
    loop
      { # Versuche, ein weiteres Unterdirectory zu parsen.
        var reg2 object subdir = parse_logical_word(&z,TRUE);
        if (nullp(subdir)) break;
        # (pathname-directory pathname) um Subdir verlängern:
        pushSTACK(subdir);
       {var reg1 object new_cons = allocate_cons(); # neues Cons
        Car(new_cons) = popSTACK(); # = (cons subdir NIL)
        Cdr(STACK_0) = new_cons; # verlängert (pathname-directory Pathname)
        STACK_0 = new_cons; # neues (last (pathname-directory Pathname))
      }}
    # Name parsen:
    { var reg1 object name = parse_logical_word(&z,FALSE);
      TheLogpathname(STACK_1)->pathname_name = name;
      if ((z.count > 0) && (TheSstring(STACK_2)->data[z.index]=='.'))
        { var zustand z_name = z;
          # Character '.' übergehen:
          z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
          # Typ parsen:
         {var reg2 object type = parse_logical_word(&z,FALSE);
          TheLogpathname(STACK_1)->pathname_type = type;
          if (!nullp(type))
            { if ((z.count > 0) && (TheSstring(STACK_2)->data[z.index]=='.'))
                { var zustand z_type = z;
                  # Character '.' übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                  # Version parsen:
                 {var reg3 object version = parse_logical_word(&z,FALSE);
                  if (eq(version,S(Kwild))) { }
                  elif (equal(version,Symbol_name(S(Knewest))))
                    { version = S(Knewest); }
                  elif (all_digits(version))
                    { pushSTACK(version); funcall(L(parse_integer),1); # version in Integer umwandeln
                      version = value1;
                    }
                  else
                    { version = NIL; }
                  TheLogpathname(STACK_1)->pathname_version = version;
                  if (nullp(version))
                    { z = z_type; } # Character '.' wieder zurück
                }}
                else
                { TheLogpathname(STACK_1)->pathname_version = NIL; }
            }
            else
            { z = z_name; # Character '.' wieder zurück
              TheLogpathname(STACK_1)->pathname_version = NIL;
            }
        }}
        else
        { TheLogpathname(STACK_1)->pathname_type = NIL;
          TheLogpathname(STACK_1)->pathname_version = NIL;
        }
    }
    skipSTACK(1);
    return z.count;
  }

#undef slashp

# Erkennung eines logischen Hosts, vgl. CLtL2 S. 631
# (defun logical-host-p (host)
#   (and (simple-string-p host)
#        (gethash host sys::*logical-pathname-translations*)
#        t
# ) )
  local boolean logical_host_p (object host);
  local boolean logical_host_p(host)
    var reg1 object host;
    { return (simple_string_p(host)
              # Fehlt host = string_upcase(host); ??
              && !eq(gethash(host,Symbol_value(S(logpathname_translations))),
                     nullobj
             )      );
    }

#endif

#ifdef PATHNAME_EXT83
# Hilfsfunktion für PARSE-NAMESTRING:
# Parst einen Namens- oder Typteil.
# parse_name_or_type(&z,stdlen,def)
# > stdlen: Standard-Länge des Teils
# > def: Defaultwert
# > STACK_3: Datenvektor des Strings
# > z: Zustand
# < z: Zustand
# < ergebnis: Namens- oder Typteil (=default, falls leer)
# kann GC auslösen
  local object parse_name_or_type (zustand* z, uintL stdlen, object def);
  local object parse_name_or_type(z,stdlen,def)
    var reg1 zustand* z;
    var reg5 uintL stdlen;
    var reg6 object def;
    { var reg3 uintL z_start_index = z->index; # Index beim Start des Namens
      loop
        { var reg2 uintB ch;
          if (z->count == 0) break;
          ch = TheSstring(STACK_3)->data[z->index]; # nächstes Character
          ch = up_case(ch); # als Großbuchstabe
          if (ch == '.') break;
          if (ch == '*')
            # '*' angetroffen.
            { # nicht am Anfang des Namens -> beendet den Namen:
              if (!(z->index == z_start_index)) break;
              # Character übergehen:
              z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
              return S(Kwild); # Name := :WILD
            }
          if (!legal_namechar(ch)) break; # gültiges Character ?
          # ja -> Teil des Namens
          # Character übergehen:
          z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
        }
      # Ende des Namens erreicht.
      # Name := Teilstring von STACK_3 von z_start_index (einschließlich)
      #                                bis z->index (ausschließlich).
     {var reg3 uintL len = z->index - z_start_index;
      # kein Name angegeben -> default zurück:
      if (len==0) { return def; }
      #ifndef EMUNIX_PORTABEL # unter OS/2 gilt die 8+3-Regel nicht mehr
      # bei len > stdlen setze len:=stdlen :
      if (len > stdlen) { len = stdlen; }
      #endif
      {var reg4 object string = allocate_string(len); # String der Länge len
       # füllen:
       var reg1 uintB* ptr1 = &TheSstring(STACK_3)->data[z_start_index];
       var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
       dotimespL(len,len, { *ptr2++ = up_case(*ptr1++); });
       # Name fertig.
       return string;
    }}}
#endif

#ifdef PATHNAME_NOEXT
# Hilfsfunktion für PARSE-NAMESTRING:
# Spaltet einen String (beim letzten Punkt) in Name und Typ auf.
# split_name_type(skip);
# > STACK_0: Simple-String
# > skip: 1 falls ein Punkt an erster Stelle nicht aufspaltend wirken soll, 0 sonst
# < STACK_1: Name
# < STACK_0: Typ
# Erniedrigt STACK um 1
# kann GC auslösen
  local void split_name_type (uintL skip);
  local void split_name_type(skip)
    var reg2 uintL skip;
    { var reg5 object string = STACK_0;
      var reg7 uintL length = TheSstring(string)->length;
      # Nach dem letzten Punkt suchen:
      var reg4 uintL index = length;
      { var reg1 uintB* ptr = &TheSstring(string)->data[index];
        while (index>skip)
          { if (*--ptr == '.') goto punkt;
            index--;
      }   }
      # kein Punkt gefunden -> Typ := NIL
      pushSTACK(NIL);
      goto name_type_ok;
      punkt: # Punkt bei index gefunden
      { # type := (substring string index)
        var reg3 uintL count = length-index;
        var reg6 object type = allocate_string(count);
        var reg1 uintB* ptr2 = &TheSstring(type)->data[0];
        var reg2 uintB* ptr1 = &TheSstring(STACK_0)->data[index];
        dotimesL(count,count, { *ptr2++ = *ptr1++; } );
        pushSTACK(type);
      }
      { # name := (substring string 0 (1- index))
        var reg3 uintL count = index-1;
        var reg6 object name = allocate_string(count);
        var reg1 uintB* ptr2 = &TheSstring(name)->data[0];
        var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[0];
        dotimesL(count,count, { *ptr2++ = *ptr1++; } );
        STACK_1 = name;
      }
      name_type_ok: ;
    }
#endif

LISPFUN(parse_namestring,1,2,norest,key,3,\
        (kw(start),kw(end),kw(junk_allowed)) )
# (PARSE-NAMESTRING thing [host [defaults [:start] [:end] [:junk-allowed]]]),
# CLTL S. 414
  { # Stackaufbau: thing, host, defaults, start, end, junk-allowed.
    var reg6 boolean junk_allowed;
    var reg7 boolean parse_logical = FALSE;
    # 1. junk-allowed überprüfen:
    { var reg1 object obj = popSTACK(); # junk-allowed-Argument
      if (eq(obj,unbound))
        { junk_allowed = FALSE; }
        else
        if (nullp(obj)) { junk_allowed = FALSE; } else { junk_allowed = TRUE; }
    }
    # Stackaufbau: thing, host, defaults, start, end.
    # 2. Default-Wert für start ist 0:
    { if (eq(STACK_1,unbound)) { STACK_1 = Fixnum_0; }}
    # 3. host überprüfen:
    #if HAS_HOST || defined(LOGICAL_PATHNAMES)
    { var reg2 object host;
      #if HAS_HOST
      host = test_optional_host(STACK_3,FALSE);
      #else
      host = test_optional_host(STACK_3);
      #endif
      if (nullp(host))
        { # host := (PATHNAME-HOST defaults)
          var reg1 object defaults = test_default_pathname(STACK_2);
          #ifdef LOGICAL_PATHNAMES
          if (logpathnamep(defaults))
            { parse_logical = TRUE; host = TheLogpathname(defaults)->pathname_host; }
            else
          #endif
            {
              #if HAS_HOST
              host = ThePathname(defaults)->pathname_host;
              #else
              host = NIL;
              #endif
            }
        }
      #ifdef LOGICAL_PATHNAMES
      elif (logical_host_p(host))
        { parse_logical = TRUE; host = string_upcase(host); }
      #endif
      STACK_3 = host;
    }
    #else
    { test_optional_host(STACK_3); }
    #endif
    # 4. thing muß ein String sein:
    { var reg5 object thing = STACK_4;
      if (xpathnamep(thing)) # Pathname?
        { value1 = thing; # 1. Wert thing
          fertig:
          value2 = STACK_1; mv_count=2; # 2. Wert start
          skipSTACK(5); return;
        }
      if (streamp(thing)) # Stream?
        { thing = as_file_stream(thing);
          value1 = TheStream(thing)->strm_file_name; # 1. Wert: Filename
          goto fertig; # 2. Wert wie oben
        }
      # thing sollte nun wenigstens ein String oder Symbol sein:
      if (!stringp(thing))
        { if (!symbolp(thing)) { fehler_thing(thing); }
          thing = Symbol_name(thing); # Symbol -> Symbolname verwenden
          if (!parse_logical)
            {
              #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS)
              # Betriebssystem mit Vorzug für Kleinbuchstaben
              thing = copy_string(thing); # ja -> mit STRING-DOWNCASE umwandeln
              nstring_downcase(&TheSstring(thing)->data[0],TheSstring(thing)->length);
              #endif
              #ifdef PATHNAME_AMIGAOS
              # Betriebssystem mit Vorzug für Capitalize
              thing = copy_string(thing); # ja -> mit STRING-CAPITALIZE umwandeln
              nstring_capitalize(&TheSstring(thing)->data[0],TheSstring(thing)->length);
              #endif
            }
          STACK_4 = thing; # und in den Stack zurückschreiben
        }
      # thing = STACK_4 ist jetzt ein String.
      { # Er wird durchlaufen.
        var zustand z; # laufender Zustand
        #ifdef PATHNAME_RISCOS
        # Hilfsvariablen zur Umsetzung eines new_thing-relativen FNindex
        # in einen thing-relativen FNindex.
        var object FNindex_limit = Fixnum_0;
        var sintL FNindex_offset = 0;
        var object FNindex_fallback;
        #endif
       {var object string; # String thing
        # Grenzen überprüfen, mit thing, start, end als Argumenten:
        pushSTACK(thing); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
        test_string_limits(&string,&z.index,&z.count);
        # z.index = Wert des start-Arguments,
        # z.count = Anzahl der Characters.
        z.FNindex = fixnum(z.index);
        # z.FNindex = start-Index als Fixnum.
        string = array_displace_check(string,z.count,&z.index); # Datenvektor holen,
        # z.index = Offset + Startindex = Startoffset
        pushSTACK(string);
       }
        #ifdef LOGICAL_PATHNAMES
        if (parse_logical)
          { pushSTACK(allocate_logpathname());
            # Stackaufbau: ..., Datenvektor, Pathname.
           {var reg1 uintL remaining = parse_logical_pathnamestring(z);
            z.index += z.count-remaining; z.FNindex = fixnum_inc(z.FNindex,z.count-remaining); z.count = remaining;
          }}
          else
        #endif
          {
            #ifdef PATHNAME_RISCOS
              # If the string starts with a system variable in <...> syntax,
              # then perform the substitution
              # (string-concat "<" var ">" tail) --> (string-concat (sys::getenv var) tail).
              if ((!(z.count==0)) && (TheSstring(STACK_0)->data[z.index] == '<'))
                { var zustand startz = z; # Start-Zustand
                  var reg1 uintB ch;
                  # Character '<' übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                  loop
                    { if (z.count==0) goto no_envvar;
                      ch = TheSstring(STACK_0)->data[z.index]; # nächstes Character
                      if (ch=='>') break;
                      if (!(graphic_char_p(ch) && !(ch=='*') && !(ch=='#'))) goto no_envvar;
                      # gültiges Character übergehen:
                      z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                    }
                  FNindex_fallback = z.FNindex;
                  # Character '>' übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                  # Environment-Variable als ASCIZ-String bauen:
                 {var reg4 object envvar;
                  { var reg3 uintL len = z.index - startz.index - 2;
                    if (len==0) goto no_envvar;
                    envvar = allocate_string(len+1);
                    # und füllen:
                   {var reg2 uintB* ptr1 = &TheSstring(STACK_0)->data[startz.index+1];
                    var reg1 uintB* ptr2 = &TheSstring(envvar)->data[0];
                    dotimesL(len,len, { *ptr2++ = *ptr1++; });
                    *ptr2 = '\0';
                  }}
                  # Dessen Wert holen:
                   begin_system_call();
                  {var reg1 const char* envval = getenv(TheAsciz(envvar));
                   end_system_call();
                   if (envval==NULL)
                     { pushSTACK(envvar);
                       pushSTACK(S(parse_namestring));
                       fehler(error,
                              DEUTSCH ? "~: Es gibt keine Environment-Variable ~." :
                              ENGLISH ? "~: there is no environment variable ~" :
                              FRANCAIS ? "~ : Il n'y a pas de variable ~ dans l'environnement." :
                              ""
                             );
                     }
                   pushSTACK(asciz_to_string(envval)); # Wert der Variablen als String
                 }}
                  # Reststück bilden:
                  { var reg4 uintL len = z.count;
                    var reg3 object tail = allocate_string(len);
                    var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[z.index];
                    var reg1 uintB* ptr2 = &TheSstring(tail)->data[0];
                    dotimesL(len,len, { *ptr2++ = *ptr1++; } );
                    pushSTACK(tail);
                  }
                  # Beides zusammenhängen, thing ersetzen:
                  { var reg2 uintL envval_len = TheSstring(STACK_1)->length;
                    var reg1 object new_thing = string_concat(2);
                    STACK_(4+1) = STACK_0 = new_thing;
                    # Der 2. Wert FNindex muß nachher noch modifiziert werden.
                    FNindex_limit = fixnum(envval_len);
                    FNindex_offset = (sintL)posfixnum_to_L(z.FNindex) - (sintL)envval_len;
                    z.index = 0; z.count = TheSstring(new_thing)->length; z.FNindex = Fixnum_0;
                  }
                  goto envvar_ok;
                 no_envvar: # keine Environment-Variable
                  z = startz; # zum Start zurück
                }
              envvar_ok: ;
            #endif
            pushSTACK(allocate_pathname());
            # Stackaufbau: ..., Datenvektor, Pathname.
            #if HAS_HOST
              # Host-Specification parsen:
              {var reg3 object host;
               { var zustand startz = z; # Start-Zustand
                 var reg1 uintB ch;
                 #if defined(PATHNAME_RISCOS)
                   # Kommt eine Folge von Zeichen, eingeschlossen in '-',
                   # oder eine Folge von Zeichen und dann eine ':' ?
                   if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
                   ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                   if (ch=='-')
                     { # '-' übergehen:
                       z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                       loop
                         { if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
                           ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                           if (ch=='-') break;
                           if (!legal_hostchar(ch)) goto no_hostspec;
                           # gültiges Character übergehen:
                           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                         }
                       # Host-String bilden:
                       { var reg4 uintL len = z.index - startz.index - 1;
                         if (len==0) goto no_hostspec;
                         host = allocate_string(len);
                         # und füllen:
                        {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index+1];
                         var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
                         dotimesL(len,len, { *ptr2++ = *ptr1++; });
                       }}
                     }
                     else
                     { loop
                         { if (!legal_hostchar(ch)) goto no_hostspec;
                           # gültiges Character übergehen:
                           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                           if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
                           ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                           if (ch==':') break;
                         }
                       # Host-String bilden:
                       { var reg4 uintL len = z.index - startz.index;
                         host = allocate_string(len);
                         # und füllen:
                        {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
                         var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
                         dotimesL(len,len, { *ptr2++ = *ptr1++; });
                       }}
                     }
                   # Character '-' bzw. ':' übergehen:
                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                   goto hostspec_ok;
                 #else
                   # Kommt eine Folge von alphanumerischen Zeichen und dann ein ':' bzw. '::' ?
                   loop
                     { if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
                       ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                       if (!alphanumericp(ch)) break;
                       # alphanumerisches Character übergehen:
                       z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                     }
                   if (!(ch==':')) goto no_hostspec; # kein ':' -> kein Host
                   # Host-String bilden:
                   { var reg4 uintL len = z.index - startz.index;
                     host = allocate_string(len);
                     # und füllen:
                    {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
                     var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
                     dotimesL(len,len, { *ptr2++ = *ptr1++; });
                   }}
                   # Character ':' übergehen:
                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                   goto hostspec_ok;
                 #endif
                 no_hostspec: # keine Host-Specification
                   z = startz; # zum Start zurück
                   host = STACK_(3+2); # Default-Host
               }
               hostspec_ok:
               # Host eintragen:
               ThePathname(STACK_0)->pathname_host = host;
              }
            #endif
            #if HAS_DEVICE
             #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
              # Einbuchstabige Device-Specification und evtl. Seriennummer parsen:
              {var reg3 object device = NIL; # Device := NIL
               #if HAS_SERNR
               var reg4 object seriennummer = NIL; # Seriennummer := NIL
               #endif
               # Drive-Specification parsen:
               # Kommt evtl. ein Buchstabe ('*','A'-'Z','a'-'z'), evtl. eine
               # Seriennummer (Integer >=0, <2^24) und dann ein ':' ?
               { var zustand startz = z; # Start-Zustand
                 var reg1 uintB ch;
                 if (z.count==0) goto no_drivespec; # String schon zu Ende ?
                 ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                 ch = up_case(ch); # als Großbuchstabe
                 if (ch == '*')
                   # ch = '*' -> Device := :WILD
                   { device = S(Kwild); }
                 elif ((ch >= 'A') && (ch <= 'Z'))
                   # 'A' <= ch <= 'Z' -> Device := "ch"
                   { var reg1 object string = allocate_string(1); # String der Länge 1
                     TheSstring(string)->data[0] = ch; # mit ch als einzigem Buchstaben
                     device = string;
                   }
                 else goto no_device;
                 # Device OK, Character übergehen:
                 z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                 if (z.count==0) goto no_drivespec; # String schon zu Ende ?
                 ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                 ch = up_case(ch); # als Großbuchstabe
                 no_device:
                 #if HAS_SERNR
                 # Kommt eventuell eine Seriennummer ?
                 if ((ch >= '0') && (ch <= '9'))
                   { # ja.
                     var reg2 uintL akku = 0; # Hilfsregister zum Aufbau der Seriennummer
                     loop
                       { ch = ch - '0'; # Wert der Ziffer
                         akku = 10*akku+ch; # Seriennummer um eine Ziffer erweitern
                         if (akku > (uintL)(bitm(oint_data_len)-1))
                           goto no_drivespec; # >=2^24 geworden -> ist wohl keine Seriennummer
                         # Character übergehen:
                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                         if (z.count==0) goto no_drivespec; # String schon zu Ende ?
                         ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                         ch = up_case(ch); # als Großbuchstabe
                         # noch eine Ziffer -> zählt zur Seriennummer
                         if (!((ch >= '0') && (ch <= '9'))) break;
                       }
                     # Seriennummer zu Ende
                     seriennummer = fixnum(akku); # akku als Fixnum
                   }
                 #endif
                 # mit Doppelpunkt abgeschlossen?
                 if (!(ch == ':')) goto no_drivespec;
                 # Character übergehen:
                 z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                 goto drivespec_ok;
                 no_drivespec:
                 # Es ist nicht gelungen, eine Drive-Specification zu parsen.
                 z = startz; # Start-Zustand wiederherstellen
                 device = NIL; # Device := NIL
                 #if HAS_SERNR
                 seriennummer = NIL; # Seriennummer := NIL
                 #endif
               }
               drivespec_ok:
               ThePathname(STACK_0)->pathname_device = device; # Device eintragen
               #if HAS_SERNR
               if (!NIL_IS_CONSTANT) { pushSTACK(seriennummer); } # Seriennummer retten (kann NIL oder ein Fixnum sein)
               { var reg1 object new_cons = allocate_cons(); # neues Cons
                 if (!NIL_IS_CONSTANT) { seriennummer = popSTACK(); } # Seriennummer zurück
                 Car(new_cons) = seriennummer; # = (cons Seriennummer NIL)
                 ThePathname(STACK_0)->pathname_directory = new_cons;
                 pushSTACK(new_cons);
                 new_cons = allocate_cons(); # neues Cons für Startpoint
                 Cdr(STACK_0) = new_cons; # verlängert (pathname-directory Pathname)
                 STACK_0 = new_cons; # neues (last (pathname-directory Pathname))
               }
               #define HAVE_Startpoint_Cons
               #endif
              }
             #endif
             #ifdef PATHNAME_AMIGAOS
              # Device-Specification parsen:
              {var reg3 object device;
               # Kommt eine nichtleere Folge von alphanumerischen Zeichen und dann ein ':' ?
               { var zustand startz = z; # Start-Zustand
                 var reg1 uintB ch;
                 loop
                   { if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
                     ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                     if (!legal_namechar(ch)) break;
                     # alphanumerisches Character übergehen:
                     z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                   }
                 if (!(ch==':')) goto no_devicespec; # kein ':' -> kein Device
                 if (z.index==startz.index) goto no_devicespec; # ':' am Anfang ist kein Device
                 # Device-String bilden:
                 { var reg4 uintL len = z.index - startz.index;
                   device = allocate_string(len);
                   # und füllen:
                  {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
                   var reg3 uintB* ptr2 = &TheSstring(device)->data[0];
                   dotimesL(len,len, { *ptr2++ = *ptr1++; });
                 }}
                 # Character ':' nicht übergehen; das ergibt dann :ABSOLUTE.
                 goto devicespec_ok;
                 no_devicespec: # keine Device-Specification
                   z = startz; # zum Start zurück
                   device = NIL; # Device NIL
               }
               devicespec_ok:
               # Device eintragen:
               ThePathname(STACK_0)->pathname_device = device;
              }
             #endif
             #ifdef PATHNAME_RISCOS
              # Device-Specification parsen:
              {var reg3 object device;
               # Kommt ein ':', eine nichtleere Folge von Zeichen und dann ein '.' ?
               { var zustand startz = z; # Start-Zustand
                 var reg1 uintB ch;
                 if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
                 ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                 if (!(ch==':')) goto no_devicespec; # kein ':' -> kein Device
                 # Character ':' übergehen:
                 z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                 loop
                   { if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
                     ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
                     if (!(legal_namechar(ch) && !(ch=='*') && !singlewild_char_p(ch))) break;
                     # gültiges Character übergehen:
                     z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                   }
                 if (!(ch=='.')) goto no_devicespec; # kein '.' -> kein Device
                 # Device-String bilden:
                 { var reg4 uintL len = z.index - startz.index - 1;
                   if (len==0) goto no_devicespec;
                   device = allocate_string(len);
                   # und füllen:
                  {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index+1];
                   var reg3 uintB* ptr2 = &TheSstring(device)->data[0];
                   dotimesL(len,len, { *ptr2++ = *ptr1++; });
                 }}
                 # Character '.' übergehen:
                 z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                 goto devicespec_ok;
                 no_devicespec: # keine Device-Specification
                   z = startz; # zum Start zurück
                   device = NIL; # Device NIL
               }
               devicespec_ok:
               # Device eintragen:
               ThePathname(STACK_0)->pathname_device = device;
              }
             #endif
            #endif
            #ifndef HAVE_Startpoint_Cons # falls nicht oben schon erledigt
            # Directory-Start eintragen:
            { var reg1 object new_cons = allocate_cons(); # neues Cons für Startpoint
              ThePathname(STACK_0)->pathname_directory = new_cons;
              pushSTACK(new_cons); # neues (last (pathname-directory Pathname))
            }
            #endif
            # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)).
            # Subdirectories parsen:
            # Trennzeichen zwischen subdirs ist unter MSDOS sowohl '\' als auch '/':
            #ifdef PATHNAME_ATARI
             #define slashp(c)  ((c) == '\\')
            #endif
            #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
             #define slashp(c)  (((c) == '\\') || ((c) == '/'))
            #endif
            #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)
             #define slashp(c)  ((c) == '/')
            #endif
            #ifdef PATHNAME_RISCOS
             #define slashp(c)  ((c) == '.')
            #endif
            {
              #if defined(USER_HOMEDIR) && defined(PATHNAME_UNIX)
              # Falls sofort ein '~' kommt, wird bis zum nächsten '/' oder Stringende
              # ein Username gelesen und das Home-Directory dieses Users eingesetzt:
              if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '~'))
                # Es kommt sofort ein '~'.
                { # Character übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                 {var reg6 object userhomedir; # Pathname des User-Homedir
                  # nächsten '/' suchen:
                  var reg2 uintB* charptr = &TheSstring(STACK_2)->data[z.index];
                  var reg3 uintL charcount = 0;
                  { var reg4 uintL count;
                    dotimesL(count,z.count,
                      { if (*charptr++ == '/') break;
                        charcount++;
                      });
                  }
                  # Username hat charcount Zeichen
                  if (charcount==0)
                    { userhomedir = O(user_homedir); } # nur '~' -> User-Homedir
                    else
                    { # Username als ASCIZ-String bauen:
                      var reg5 object username = allocate_string(charcount+1);
                      { var reg1 uintB* charptr2 = &TheSstring(username)->data[0];
                        var reg4 uintL count;
                        charptr = &TheSstring(STACK_2)->data[z.index];
                        dotimespL(count,charcount, { *charptr2++ = *charptr++; } );
                        *charptr2 = '\0';
                      }
                      # Dessen Home-Directory aus dem Passwort-File holen:
                      begin_system_call();
                      errno = 0;
                     {var reg1 struct passwd * userpasswd = getpwnam(TheAsciz(username));
                      end_system_call();
                      if (userpasswd == (struct passwd *)NULL) # erfolglos?
                        { if (!(errno==0)) { OS_error(); } # Error melden
                          # sonst: Fehler
                          pushSTACK(username);
                          pushSTACK(S(parse_namestring));
                          fehler(error,
                                 DEUTSCH ? "~: Es gibt keinen Benutzer mit Namen ~." :
                                 ENGLISH ? "~: there is no user named ~" :
                                 FRANCAIS ? "~ : Il n'y a pas d'utilisateur de nom ~." :
                                 ""
                                );
                        }
                      userhomedir = asciz_dir_to_pathname(userpasswd->pw_dir); # Homedir als Pathname
                    }}
                  # Directory aus dem Pathname userhomedir kopieren:
                  # (copy-list dir) = (nreconc (reverse dir) nil),
                  # dabei dessen letztes Cons merken.
                  userhomedir = reverse(ThePathname(userhomedir)->pathname_directory);
                  STACK_0 = userhomedir; userhomedir = nreconc(userhomedir,NIL);
                  ThePathname(STACK_1)->pathname_directory = userhomedir;
                  # username-Characters übergehen:
                  z.index += charcount; z.FNindex = fixnum_inc(z.FNindex,charcount); z.count -= charcount;
                  # Falls der String zu Ende ist: fertig,
                  # sonst kommt sofort ein '/', es wird übergangen:
                  if (z.count==0)
                    { pushSTACK(NIL); pushSTACK(NIL); goto after_name_type; } # Name und Typ := NIL
                  # Character übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                }}
              else
              #endif
              #if defined(PATHNAME_UNIX) && 0 # Wozu braucht man das, außer für $HOME ?
              # Falls sofort ein '$' kommt, wird bis zum nächsten '/' oder Stringende
              # eine Environment-Variable gelesen und ihr Wert eingesetzt:
              if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '$'))
                # Es kommt sofort ein '$'.
                { # Character übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                 {var reg6 object envval_dir;
                  # nächsten '/' suchen:
                  var reg2 uintB* charptr = &TheSstring(STACK_2)->data[z.index];
                  var reg3 uintL charcount = 0;
                  { var reg4 uintL count;
                    dotimesL(count,z.count,
                      { if (*charptr++ == '/') break;
                        charcount++;
                      });
                  }
                  # Environment-Variable hat charcount Zeichen,
                  # als ASCIZ-String bauen:
                  { var reg5 object envvar = allocate_string(charcount+1);
                    { var reg1 uintB* charptr2 = &TheSstring(envvar)->data[0];
                      var reg4 uintL count;
                      charptr = &TheSstring(STACK_2)->data[z.index];
                      dotimesL(count,charcount, { *charptr2++ = *charptr++; } );
                      *charptr2 = '\0';
                    }
                    # Dessen Wert holen:
                    begin_system_call();
                   {var reg1 const char* envval = getenv(TheAsciz(envvar));
                    end_system_call();
                    if (envval==NULL)
                      { pushSTACK(envvar);
                        pushSTACK(S(parse_namestring));
                        fehler(error,
                               DEUTSCH ? "~: Es gibt keine Environment-Variable ~." :
                               ENGLISH ? "~: there is no environment variable ~" :
                               FRANCAIS ? "~ : Il n'y a pas de variable ~ dans l'environnement." :
                               ""
                              );
                      }
                    envval_dir = asciz_dir_to_pathname(envval); # Wert der Variablen als Pathname
                  }}
                  # Directory aus dem Pathname envval_dir kopieren:
                  # (copy-list dir) = (nreconc (reverse dir) nil),
                  # dabei dessen letztes Cons merken.
                  envval_dir = reverse(ThePathname(envval_dir)->pathname_directory);
                  STACK_0 = envval_dir; envval_dir = nreconc(envval_dir,NIL);
                  ThePathname(STACK_1)->pathname_directory = envval_dir;
                  # envvar-Characters übergehen:
                  z.index += charcount; z.FNindex = fixnum_inc(z.FNindex,charcount); z.count -= charcount;
                  # Falls der String zu Ende ist: fertig,
                  # sonst kommt sofort ein '/', es wird übergangen:
                  if (z.count==0)
                    { pushSTACK(NIL); pushSTACK(NIL); goto after_name_type; } # Name und Typ := NIL
                  # Character übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                }}
              else
              #endif
              #if defined(PATHNAME_UNIX) || defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
              # Falls sofort ein '\' bzw. '/' kommt, wird er übergangen, und es kommt
              # :ABSOLUTE (sonst :RELATIVE) als erstes subdir:
              if ((!(z.count == 0)) && slashp(TheSstring(STACK_2)->data[z.index]))
                # Es kommt sofort ein '\' bzw. '/'.
                { # Character übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                  Car(STACK_0) = S(Kabsolute); # Startpoint = :ABSOLUTE
                }
                else
                # Es kommt nicht sofort ein '\' bzw. '/'.
                { Car(STACK_0) = S(Krelative); } # Startpoint = :RELATIVE
              #endif
              #ifdef PATHNAME_AMIGAOS
              # Falls sofort ein ':' kommt, wird er übergangen, und es kommt
              # :ABSOLUTE (sonst :RELATIVE) als erstes subdir:
              if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == ':'))
                # Es kommt sofort ein ':'.
                { # Character übergehen:
                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                  Car(STACK_0) = S(Kabsolute); # directory = (:ABSOLUTE)
                }
                else
                # Es kommt nicht sofort ein ':'.
                { Car(STACK_0) = S(Krelative); } # directory = (:RELATIVE)
              #endif
              #ifdef PATHNAME_RISCOS
              # Präfix '$.' oder '&.' oder '@.' oder '%.' oder '\.' parsen.
              if ((z.count >= 2) && (TheSstring(STACK_2)->data[z.index+1] == '.'))
                { switch (TheSstring(STACK_2)->data[z.index])
                    { case '$': Car(STACK_0) = S(Kroot); break; # directory = (:ABSOLUTE :ROOT)
                      case '&': Car(STACK_0) = S(Khome); break; # directory = (:ABSOLUTE :HOME)
                      case '@': Car(STACK_0) = S(Kcurrent); break; # directory = (:ABSOLUTE :CURRENT)
                      case '%': Car(STACK_0) = S(Klibrary); break; # directory = (:ABSOLUTE :LIBRARY)
                      case '\\': Car(STACK_0) = S(Kprevious); break; # directory = (:ABSOLUTE :PREVIOUS)
                      default: goto prefix_relative;
                    }
                  # Präfix übergehen:
                  z.index+=2; z.FNindex = fixnum_inc(z.FNindex,2); z.count-=2;
                  # (pathname-directory pathname) um ein Cons (:ABSOLUTE) verlängern:
                 {var reg1 object new_cons = allocate_cons(); # neues Cons
                  Car(new_cons) = S(Kabsolute); Cdr(new_cons) = STACK_0;
                  ThePathname(STACK_1)->pathname_directory = new_cons;
                }}
                else
                prefix_relative:
                { Car(STACK_0) = S(Krelative); } # directory = (:RELATIVE)
              #endif
              #if !defined(PATHNAME_RISCOS)
              loop
                { # Versuche, ein weiteres Unterdirectory zu parsen.
                  #ifdef PATHNAME_EXT83
                    # Kommt '.\' oder '..\' oder '...\' ?
                    if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '.'))
                      { # nächstes Character ist ein '.'.
                        var zustand subdirz = z; # Zustand beim Start des Subdirectories
                        # Character übergehen:
                        z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                        if (z.count == 0) goto no_dots; # String schon zu Ende ?
                       {var reg1 uintB ch = TheSstring(STACK_2)->data[z.index]; # nächstes Character
                        if (slashp(ch))
                          # '.\' angetroffen -> (cons :CURRENT NIL) bauen
                          { pushSTACK(S(Kcurrent)); goto dots; }
                        if (!(ch == '.')) goto no_dots;
                        # zweites Character war auch ein '.'.
                        # Character übergehen:
                        z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                        if (z.count == 0) goto no_dots; # String schon zu Ende ?
                        ch = TheSstring(STACK_2)->data[z.index]; # nächstes Character
                        if (slashp(ch))
                          # '..\' angetroffen -> (cons :PARENT NIL) bauen
                          { pushSTACK(S(Kparent)); goto dots; }
                        if (!(ch == '.')) goto no_dots;
                        # drittes Character war auch ein '.'.
                        # Character übergehen:
                        z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                        if (z.count == 0) goto no_dots; # String schon zu Ende ?
                        ch = TheSstring(STACK_2)->data[z.index]; # nächstes Character
                        if (slashp(ch))
                          # '...\' angetroffen -> (cons :WILD-INFERIORS NIL) bauen
                          { pushSTACK(S(Kwild_inferiors)); goto dots; }
                        goto no_dots;
                       }
                        dots:
                        # '.\' oder '..\' oder '...\' angetroffen, Keyword im Stack.
                        # Character '\' übergehen:
                        z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                        goto subdir_ok;
                        no_dots:
                        z = subdirz; # Zustand wiederherstellen
                      }
                    # Versuche, normale 'name.typ'-Syntax zu parsen:
                    pushSTACK(NIL); # dummy
                    { # Name, hat max. 8 Buchstaben:
                      var reg1 object name = parse_name_or_type(&z,8,NIL);
                      STACK_0 = name;
                    }
                    # Versuche, '.typ'-Syntax zu parsen:
                    { var reg1 object type;
                      if ((!(z.count==0)) && (TheSstring(STACK_3)->data[z.index] == '.'))
                        { # Es kommt ein '.'. Character übergehen:
                          z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                          # Typ, hat max. 3 Buchstaben:
                          type = parse_name_or_type(&z,3,O(leer_string));
                        }
                        else
                        { type = NIL; }
                      pushSTACK(type);
                    }
                    # Stackaufbau: ...,
                    #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
                    #   name, type.
                    # Kommt sofort ein '\', so war es ein Unterdirectory,
                    # sonst ist der Pathname beendet:
                    if ((z.count==0) || !slashp(TheSstring(STACK_4)->data[z.index])) break;
                    # Es kommt ein '\'. Character übergehen:
                    z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                    # name=NIL -> durch "" ersetzen:
                    if (eq(STACK_1,NIL)) { STACK_1 = O(leer_string); }
                    # type=NIL -> durch "" ersetzen:
                    if (eq(STACK_0,NIL)) { STACK_0 = O(leer_string); }
                    { var reg1 object new_cons = allocate_cons(); # neues Cons
                      Cdr(new_cons) = popSTACK(); # type
                      Car(new_cons) = popSTACK(); # name
                      # new_cons = (cons name type)
                      pushSTACK(new_cons);
                    }
                    subdir_ok:
                  #endif
                  #ifdef PATHNAME_NOEXT
                    { var reg3 uintL z_start_index = z.index; # Index beim Start
                      loop
                        { var reg2 uintB ch;
                          if (z.count == 0) break;
                          ch = TheSstring(STACK_2)->data[z.index]; # nächstes Character
                          if (!legal_namechar(ch)) break; # gültiges Character ?
                          # ja -> Teil des Namens
                          # Character übergehen:
                          z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                        }
                      # Ende des Namens erreicht.
                      # Name := Teilstring von STACK_2 von z_start_index (einschließlich)
                      #                                bis z.index (ausschließlich).
                     {var reg3 uintL len = z.index - z_start_index;
                      var reg4 object string = allocate_string(len); # String der Länge len
                      # füllen:
                      var reg1 uintB* ptr1 = &TheSstring(STACK_2)->data[z_start_index];
                      var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
                      dotimesL(len,len, { *ptr2++ = *ptr1++; });
                      # Name fertig.
                      pushSTACK(string);
                    }}
                    # Kommt sofort ein '/' bzw. '\', so war es ein Unterdirectory,
                    # sonst ist der Pathname beendet:
                    if ((z.count==0) || !slashp(TheSstring(STACK_3)->data[z.index]))
                      # Nein -> war der Name und kein Subdir.
                      break;
                    # Es kommt ein '/' bzw. '\'. Character übergehen:
                    z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                    # Stackaufbau: ...,
                    #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
                    #   subdir.
                    #ifdef PATHNAME_AMIGAOS
                    # War es '' ?
                    if (equal(STACK_0,O(leer_string)))
                      { STACK_0 = S(Kparent); } # ja -> durch :PARENT ersetzen
                    else
                    #endif
                    # War es '**' oder '...' ?
                    if (equal(STACK_0,O(wildwild_string)) || equal(STACK_0,O(punktpunktpunkt_string)))
                      { STACK_0 = S(Kwild_inferiors); } # ja -> durch :WILD-INFERIORS ersetzen
                  #endif
                  # (pathname-directory pathname) um Subdir STACK_0 verlängern:
                  { var reg1 object new_cons = allocate_cons(); # neues Cons
                    Car(new_cons) = popSTACK(); # = (cons subdir NIL)
                    Cdr(STACK_0) = new_cons; # verlängert (pathname-directory Pathname)
                    STACK_0 = new_cons; # neues (last (pathname-directory Pathname))
                  }
                }
              #else # defined(PATHNAME_RISCOS)
              pushSTACK(unbound); # maybe-name
              # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
              #              maybe-name.
              loop
                { # Versuche, ein weiteres Unterdirectory zu parsen.
                  # Maybe-Name = die letzte gelesene Komponente in
                  # { { legal-wild char }+ | empty } '.'  Syntax.
                  # Ob ein weiteres subdir oder der Name, wird sich erst noch
                  # entscheiden.
                  # Kommt '^.' ?
                  if (!nullp(STACK_0)
                      && (z.count >= 2)
                      && (TheSstring(STACK_3)->data[z.index] == '^')
                      && slashp(TheSstring(STACK_3)->data[z.index+1])
                     )
                    { # beide Characters übergehen:
                      z.index+=2; z.FNindex = fixnum_inc(z.FNindex,2); z.count-=2;
                      pushSTACK(S(Kparent)); # :PARENT
                    }
                    else
                    # Versuche, normale  { legal-wild char }+  Syntax zu parsen:
                    { var reg3 uintL z_start_index = z.index; # Index beim Start des Namens
                      loop
                        { var reg2 uintB ch;
                          if (z.count == 0) break;
                          ch = TheSstring(STACK_3)->data[z.index]; # nächstes Character
                          if (!legal_namechar(ch)) break; # gültiges Character ?
                          # ja -> Teil des Namens
                          # Character übergehen:
                          z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                        }
                      # Ende des Namens erreicht.
                      # Name := Teilstring von STACK_3 von z_start_index (einschließlich)
                      #                                bis z.index (ausschließlich).
                     {var reg3 uintL len = z.index - z_start_index;
                      var reg4 object string;
                      if (len==0)
                        { string = NIL; } # "" wird zu NIL
                        else
                        { string = allocate_string(len); # String der Länge len
                          # füllen:
                         {var reg1 uintB* ptr1 = &TheSstring(STACK_3)->data[z_start_index];
                          var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
                          dotimespL(len,len, { *ptr2++ = *ptr1++; });
                        }}
                      # Name fertig.
                      if (nullp(STACK_0)
                          || (z.count==0)
                          || !slashp(TheSstring(STACK_3)->data[z.index])
                         )
                        { pushSTACK(string); break; }
                      # Character '.' übergehen:
                      z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
                      pushSTACK(string);
                    }}
                  if (!eq(STACK_1,unbound))
                    # (pathname-directory pathname) um Subdir STACK_1 verlängern:
                    { var reg1 object new_cons = allocate_cons(); # neues Cons
                      Car(new_cons) = STACK_1; # = (cons subdir NIL)
                      Cdr(STACK_2) = new_cons; # verlängert (pathname-directory Pathname)
                      STACK_2 = new_cons; # neues (last (pathname-directory Pathname))
                    }
                  STACK_1 = STACK_0; skipSTACK(1); # maybe-name := subdir
                }
              if (eq(STACK_1,unbound)) { STACK_1 = STACK_0; STACK_0 = NIL; }
              # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
              #              name, type.
              # In gewissen Fällen hört die Directory-Angabe nicht nach dem
              # vorletzten Punkt, sondern nach dem letzten Punkt auf:
              elif (eq(STACK_1,S(Kparent)) # z.B. "bar.^.foo"
                    || (nullp(STACK_0) && !nullp(STACK_1)) # z.B. "foo.bar."
                   )
                # (pathname-directory pathname) um Subdir STACK_1 verlängern:
                { var reg1 object new_cons = allocate_cons(); # neues Cons
                  Car(new_cons) = STACK_1; # = (cons subdir NIL)
                  Cdr(STACK_2) = new_cons; # verlängert (pathname-directory Pathname)
                  STACK_2 = new_cons; # neues (last (pathname-directory Pathname))
                  STACK_1 = STACK_0; # name := type
                  STACK_0 = NIL;     # type := NIL
                }
              #endif
              #if defined(PATHNAME_EXT83) || defined(PATHNAME_RISCOS)
              # Stackaufbau: ...,
              #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
              #   name, type.
              # Name und Typ in Pathname eintragen:
              { var reg3 object type = popSTACK();
                var reg2 object name = popSTACK();
                skipSTACK(1); # Directory ist schon eingetragen
               {var reg1 object pathname = STACK_0;
                ThePathname(pathname)->pathname_name = name;
                ThePathname(pathname)->pathname_type = type;
              }}
              #endif
              #ifdef PATHNAME_NOEXT
              # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
              #              string.
              split_name_type(0); # String STACK_0 in Name und Typ aufspalten
              after_name_type:
              # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
              #              name, type.
              # Name und Typ in Pathname eintragen:
              { var reg3 object type = popSTACK();
                var reg2 object name = popSTACK();
                skipSTACK(1); # Directory ist schon eingetragen
                # name="" durch Name=NIL ersetzen:
                if (equal(name,O(leer_string))) { name = NIL; }
               {var reg1 object pathname = STACK_0;
                ThePathname(pathname)->pathname_name = name;
                ThePathname(pathname)->pathname_type = type;
              }}
              #endif
            }
            #undef slashp
          }
        # Pathname fertig.
        # Stackaufbau: ..., Datenvektor, Pathname.
        if (!junk_allowed)
          # Überprüfen, ob keine Zeichen mehr übrig sind:
          if (!(z.count == 0))
            { pushSTACK(z.FNindex); # letzter Index
              pushSTACK(STACK_(4+2+1)); # thing
              pushSTACK(S(parse_namestring));
              fehler(error,
                     DEUTSCH ? "~: Syntax Error im Dateinamen ~ an Position ~." :
                     ENGLISH ? "~: syntax error in filename ~ at position ~" :
                     FRANCAIS ? "~ : Erreur de syntaxe dans le nom de fichier ~, à la position ~." :
                     ""
                    );
            }
        #ifdef LOGICAL_PATHNAMES
        if (parse_logical)
          { if (!nullp(STACK_(3+2)))
              # Hosts müssen übereinstimmen, vgl. CLtL2 S. 629
              if (!equal(STACK_(3+2),TheLogpathname(STACK_0)->pathname_host))
                { pushSTACK(STACK_0);
                  pushSTACK(TheLogpathname(STACK_(0+1))->pathname_host);
                  pushSTACK(STACK_(3+2+2));
                  pushSTACK(S(parse_namestring));
                  fehler(error,
                         DEUTSCH ? "~: Hosts ~ und ~ von ~ stimmen nicht überein." :
                         ENGLISH ? "~: hosts ~ and ~ of ~ should coincide" :
                         FRANCAIS ? "~ : Les «hosts» ~ et ~ de ~ ne sont pas les mêmes." :
                         ""
                        );
          }     }
        #endif
        value1 = STACK_0; # Pathname als 1. Wert
        #ifdef PATHNAME_RISCOS
        if (as_oint(z.FNindex) >= as_oint(FNindex_limit))
          # FNindex von new_thing nach thing umrechnen:
          { value2 = fixnum_inc(z.FNindex,FNindex_offset); }
          else
          # FNindex zeigt in den ersetzten (!) String envval. Was bleibt
          # uns als Index anderes übrig als der Start-Index?
          # (Nicht ganz korrekt freilich: Hätte das Parsen wirklich dort
          # aufgehört, würde value1 anders aussehen!)
          # Zum Beispiel ein Index in das Innere des <...>-Konstruktes.
          # (Auch das ist nicht ganz korrekt, kommt der Sache aber näher.)
          { value2 = FNindex_fallback; }
        #else
        value2 = z.FNindex; # Index als 2. Wert
        #endif
        mv_count=2; # 2 Werte
        skipSTACK(5+2); return;
  } } }

# UP: Wandelt ein Objekt in einen Pathname um.
# coerce_xpathname(object)
# > object: Objekt
# < ergebnis: (PATHNAME Objekt)
# kann GC auslösen
  local object coerce_xpathname (object obj);
  local object coerce_xpathname(obj)
    var reg1 object obj;
    { if (xpathnamep(obj))
        # Bei Pathnames ist nichts zu tun.
        { return obj; }
        else
        # sonst: PARSE-NAMESTRING aufrufen:
        { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
          pushSTACK(obj); funcall(L(parse_namestring),1);
          subr_self = popSTACK();
          return value1;
        }
    }

LISPFUNN(pathname,1)
# (PATHNAME pathname), CLTL S. 413
  { value1 = coerce_xpathname(popSTACK()); mv_count=1; }

LISPFUN(pathnamehost,1,0,norest,key,1, (kw(case)))
# (PATHNAME-HOST pathname), CLTL S. 417, CLtL2 S. 644
  { var reg1 object pathname = coerce_xpathname(STACK_1);
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(pathname))
      { value1 = TheLogpathname(pathname)->pathname_host; mv_count=1; }
      else
    #endif
      {
        #if HAS_HOST
        var reg2 object erg = ThePathname(pathname)->pathname_host;
        value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
        mv_count=1; # host als Wert
        #else
        value1 = NIL; mv_count=1; # NIL als Wert
        #endif
      }
    skipSTACK(2);
  }

LISPFUN(pathnamedevice,1,0,norest,key,1, (kw(case)))
# (PATHNAME-DEVICE pathname), CLTL S. 417, CLtL2 S. 644
  { var reg1 object pathname = coerce_xpathname(STACK_1);
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(pathname))
      { value1 = NIL; mv_count=1; }
      else
    #endif
      {
        #if HAS_DEVICE
        var reg2 object erg = ThePathname(pathname)->pathname_device;
        value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
        mv_count=1; # device als Wert
        #else
        value1 = NIL; mv_count=1; # NIL als Wert
        #endif
      }
    skipSTACK(2);
  }

LISPFUN(pathnamedirectory,1,0,norest,key,1, (kw(case)))
# (PATHNAME-DIRECTORY pathname), CLTL S. 417, CLtL2 S. 644
  { var reg1 object pathname = coerce_xpathname(STACK_1);
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(pathname))
      { value1 = TheLogpathname(pathname)->pathname_directory; }
      else
    #endif
      { var reg2 object erg = ThePathname(pathname)->pathname_directory;
        value1 = (eq(STACK_0,S(Kcommon)) ? subst_common_case(erg) : erg);
      }
    mv_count=1; # directory als Wert
    skipSTACK(2);
  }

LISPFUN(pathnamename,1,0,norest,key,1, (kw(case)))
# (PATHNAME-NAME pathname), CLTL S. 417, CLtL2 S. 644
  { var reg1 object pathname = coerce_xpathname(STACK_1);
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(pathname))
      { value1 = TheLogpathname(pathname)->pathname_name; }
      else
    #endif
      { var reg2 object erg = ThePathname(pathname)->pathname_name;
        value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
      }
    mv_count=1; # name als Wert
    skipSTACK(2);
  }

LISPFUN(pathnametype,1,0,norest,key,1, (kw(case)))
# (PATHNAME-TYPE pathname), CLTL S. 417, CLtL2 S. 644
  { var reg1 object pathname = coerce_xpathname(STACK_1);
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(pathname))
      { value1 = TheLogpathname(pathname)->pathname_type; }
      else
    #endif
      { var reg2 object erg = ThePathname(pathname)->pathname_type;
        value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
      }
    mv_count=1; # type als Wert
    skipSTACK(2);
  }

LISPFUNN(pathnameversion,1)
# (PATHNAME-VERSION pathname), CLTL S. 417, CLtL2 S. 644
  { var reg1 object pathname = coerce_xpathname(popSTACK());
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(pathname))
      { value1 = TheLogpathname(pathname)->pathname_version; }
      else
    #endif
      {
        #if HAS_VERSION
        value1 = ThePathname(pathname)->pathname_version; # version als Wert
        #else
        value1 = NIL; # NIL als Wert
        #endif
      }
    mv_count=1;
  }

# Zugriffsfunktionen ohne Groß-/Klein-Umwandlung:
# xpathname_host(logical,pathname)
# xpathname_device(logical,pathname)
# xpathname_directory(logical,pathname)
# xpathname_name(logical,pathname)
# xpathname_type(logical,pathname)
# xpathname_version(logical,pathname)
# > pathname: Pathname oder Logical Pathname
# > logical: Flag, ob es sich um einen Logical Pathname handelt
# < ergebnis: Wert der entsprechenden Komponente von pathname
  #ifdef LOGICAL_PATHNAMES
    #if HAS_HOST
      #define xpathname_host(logical,pathname)  \
        (logical ? TheLogpathname(pathname)->pathname_host : ThePathname(pathname)->pathname_host)
    #else
      #define xpathname_host(logical,pathname)  \
        (logical ? TheLogpathname(pathname)->pathname_host : NIL)
    #endif
    #if HAS_DEVICE
      #define xpathname_device(logical,pathname)  \
        (logical ? NIL : ThePathname(pathname)->pathname_device)
    #else
      #define xpathname_device(logical,pathname)  NIL
    #endif
    #define xpathname_directory(logical,pathname)  \
      (logical ? TheLogpathname(pathname)->pathname_directory : ThePathname(pathname)->pathname_directory)
    #define xpathname_name(logical,pathname)  \
      (logical ? TheLogpathname(pathname)->pathname_name : ThePathname(pathname)->pathname_name)
    #define xpathname_type(logical,pathname)  \
      (logical ? TheLogpathname(pathname)->pathname_type : ThePathname(pathname)->pathname_type)
    #if HAS_VERSION
      #define xpathname_version(logical,pathname)  \
        (logical ? TheLogpathname(pathname)->pathname_version : ThePathname(pathname)->pathname_version)
    #else
      #define xpathname_version(logical,pathname)  \
        (logical ? TheLogpathname(pathname)->pathname_version : NIL)
    #endif
  #else
    # logical immer =FALSE
    #if HAS_HOST
      #define xpathname_host(logical,pathname)  ThePathname(pathname)->pathname_host
    #else
      #define xpathname_host(logical,pathname)  NIL
    #endif
    #if HAS_DEVICE
      #define xpathname_device(logical,pathname)  ThePathname(pathname)->pathname_device
    #else
      #define xpathname_device(logical,pathname)  NIL
    #endif
    #define xpathname_directory(logical,pathname)  ThePathname(pathname)->pathname_directory
    #define xpathname_name(logical,pathname)  ThePathname(pathname)->pathname_name
    #define xpathname_type(logical,pathname)  ThePathname(pathname)->pathname_type
    #if HAS_VERSION
      #define xpathname_version(logical,pathname)  ThePathname(pathname)->pathname_version
    #else
      #define xpathname_version(logical,pathname)  NIL
    #endif
  #endif

#ifdef LOGICAL_PATHNAMES

LISPFUNN(logical_pathname,1)
# (LOGICAL-PATHNAME thing), CLtL2 S. 631
  { var reg1 object thing = popSTACK();
    if (logpathnamep(thing))
      # Bei Logical Pathnames ist nichts zu tun.
      { value1 = thing; mv_count=1; }
    elif (pathnamep(thing))
      # Normale Pathnames können nicht in Logical Pathnames umgewandelt werden.
      { pushSTACK(thing); # Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(O(type_logical_pathname)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(thing);
        pushSTACK(S(logical_pathname));
        fehler(type_error,
               DEUTSCH ? "~: Argument ~ ist kein Logical Pathname, String, Stream oder Symbol." :
               ENGLISH ? "~: argument ~ is not a logical pathname, string, stream or symbol" :
               FRANCAIS ? "~ : L'argument ~ n'est pas un «pathname logique», une chaîne, un «stream» ou un symbole." :
               ""
              );
      }
    else
      # sonst: PARSE-NAMESTRING aufrufen:
      { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
        # Das Ergebnis von (PARSE-NAMESTRING thing nil empty-logical-pathname)
        # ist garantiert ein logischer Pathname.
        pushSTACK(thing); pushSTACK(NIL); pushSTACK(O(empty_logical_pathname));
        funcall(L(parse_namestring),3);
        subr_self = popSTACK();
        mv_count=1;
      }
  }

LISPFUN(translate_logical_pathname,1,0,norest,key,0, )
# (TRANSLATE-LOGICAL-PATHNAME pathname &key), CLtL2 S. 631
  { var reg3 object pathname = coerce_xpathname(popSTACK());
    if (logpathnamep(pathname))
      { # Umwandeln eines logischen in einen normalen Pathname:
        # (let ((ht (make-hash-table :test #'equal)))
        #   (loop
        #     (when (gethash pathname ht) (error "Translation loop"))
        #     (setf (gethash pathname ht) t)
        #     (let ((host (or (pathname-host pathname) "SYS")))
        #       (unless (logical-host-p host) (error "No translation for host"))
        #       (let* ((translations (gethash host sys::*logical-pathname-translations*))
        #              (translation (assoc pathname translations :test #'pathname-match-p)))
        #         (unless (and translation (consp translation) (consp (cdr translation)))
        #           (error "No translation for pathname")
        #         )
        #         (setq pathname (translate-pathname pathname (first translation) (second translation)))
        #     ) )
        #     (unless (sys::logical-pathname-p pathname) (return))
        #   )
        #   pathname
        # )
        pushSTACK(pathname);
        pushSTACK(S(Ktest)); pushSTACK(L(equal)); funcall(L(make_hash_table),2);
        pushSTACK(value1);
        # Stackaufbau: pathname, ht.
        loop
          { if (!nullp(shifthash(STACK_0,STACK_1,T)))
              { # STACK_1 = pathname; # Wert für Slot PATHNAME von FILE-ERROR
                STACK_0 = STACK_1;
                pushSTACK(S(translate_logical_pathname));
                fehler(file_error,
                       DEUTSCH ? "~: Endlosschleife beim Auflösen von ~" :
                       ENGLISH ? "~: endless loop while resolving ~" :
                       FRANCAIS ? "~ : boucle infinie pour ~" :
                       ""
                      );
              }
            if (nullp(TheLogpathname(STACK_1)->pathname_host))
              # Host NIL durch Default-Host ersetzen:
              { var reg1 object new = allocate_logpathname();
                var reg2 object old = STACK_1;
                TheLogpathname(new)->pathname_host      = O(default_logical_pathname_host); # Default "SYS"
                TheLogpathname(new)->pathname_directory = TheLogpathname(old)->pathname_directory;
                TheLogpathname(new)->pathname_name      = TheLogpathname(old)->pathname_name;
                TheLogpathname(new)->pathname_type      = TheLogpathname(old)->pathname_type;
                TheLogpathname(new)->pathname_version   = TheLogpathname(old)->pathname_version;
                STACK_1 = new;
              }
           {var reg2 object host = TheLogpathname(STACK_1)->pathname_host;
            var reg1 object translations = gethash(host,Symbol_value(S(logpathname_translations)));
            if (eq(translations,nullobj))
              { # STACK_1 = pathname; # Wert für Slot PATHNAME von FILE-ERROR
                STACK_0 = STACK_1;
                pushSTACK(host);
                pushSTACK(S(translate_logical_pathname));
                fehler(file_error,
                       DEUTSCH ? "~: Logical Host ~ ist unbekannt: ~" :
                       ENGLISH ? "~: unknown logical host ~ in ~" :
                       FRANCAIS ? "~ : host ~ inconnu dans ~" :
                       ""
                      );
              }
            # (ASSOC pathname translations :test #'pathname-match-p):
            pushSTACK(STACK_1); pushSTACK(translations);
            pushSTACK(S(Ktest)); pushSTACK(L(pathname_match_p));
            funcall(L(assoc),4);
            if (atomp(value1) || matomp(Cdr(value1)))
              { # STACK_1 = pathname; # Wert für Slot PATHNAME von FILE-ERROR
                STACK_0 = STACK_1;
                pushSTACK(S(translate_logical_pathname));
                fehler(file_error,
                       DEUTSCH ? "~: Keine Ersetzungsregel für ~ ist bekannt." :
                       ENGLISH ? "~: No replacement rule for ~ is known." :
                       FRANCAIS ? "~ : Aucune règle de traduction est connue pour ~." :
                       ""
                      );
              }
            # (TRANSLATE-PATHNAME pathname (first rule) (second rule) :MERGE NIL):
            pushSTACK(STACK_1); pushSTACK(Car(value1)); pushSTACK(Car(Cdr(value1)));
            pushSTACK(S(Kmerge)); pushSTACK(NIL);
            funcall(L(translate_pathname),5);
            STACK_1 = pathname = value1;
            if (!logpathnamep(pathname)) break;
          }}
        skipSTACK(2);
      }
    value1 = pathname; mv_count=1;
  }

# UP: Wandelt ein Objekt in einen nicht-Logical Pathname um.
# coerce_pathname(object)
# > object: Objekt
# < ergebnis: (TRANSLATE-LOGICAL-PATHNAME (PATHNAME Objekt))
# kann GC auslösen
  local object coerce_pathname (object obj);
  local object coerce_pathname(obj)
    var reg1 object obj;
    { obj = coerce_xpathname(obj);
      if (pathnamep(obj))
        # Bei Pathnames ist nichts zu tun.
        { return obj; }
      elif (logpathnamep(obj))
        # TRANSLATE-LOGICAL-PATHNAME aufrufen:
        { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
          pushSTACK(obj); funcall(L(translate_logical_pathname),1);
          subr_self = popSTACK();
          return value1;
        }
      else
        { NOTREACHED }
    }

#endif

# UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
# String für ein Subdirectory (car path) ergeben.
# subdir_namestring_parts(path)
# > path: ein Cons
# < ergebnis: Anzahl der auf den Stack gelegten Strings
# verändert STACK
  local uintC subdir_namestring_parts (object path);
  local uintC subdir_namestring_parts(path)
    var reg4 object path;
    { var reg1 object subdir = Car(path);
      #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
      if (eq(subdir,S(Kcurrent))) # :CURRENT ?
        { pushSTACK(O(punkt_string)); return 1; }
      elif (eq(subdir,S(Kparent))) # :PARENT ?
        { pushSTACK(O(punktpunkt_string)); return 1; }
      elif (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
        { pushSTACK(O(punktpunktpunkt_string)); return 1; }
      else
        # normales subdir (name . type)
        { var reg3 object name = Car(subdir);
          var reg2 object type = Cdr(subdir);
          # name = :WILD -> String "*"
          if (eq(name,S(Kwild))) { name = O(wild_string); }
          pushSTACK(name);
          # type = :WILD -> String "*"
          if (eq(type,S(Kwild))) { type = O(wild_string); }
          if (TheSstring(type)->length == 0)
            # type = "" -> nicht auszugeben
            { return 1+0; }
            else
            { pushSTACK(O(punkt_string)); # "."
              pushSTACK(type);
              return 1+2;
            }
        }
      #endif
      #ifdef PATHNAME_AMIGAOS
      if (eq(subdir,S(Kparent))) # :PARENT ?
        { return 0; } # Leerstring
      elif (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
        { pushSTACK(O(wildwild_string)); return 1; }
      else
        # normales subdir
        { pushSTACK(subdir); return 1; }
      #endif
      #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2)
      if (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
        { pushSTACK(O(wildwild_string)); return 1; }
        else
        # normales subdir
        { pushSTACK(subdir); return 1; }
      #endif
      #ifdef PATHNAME_RISCOS
      if (eq(subdir,S(Kparent))) # :PARENT ?
        { pushSTACK(O(parent_string)); return 1; }
        else
        # normales subdir
        { pushSTACK(subdir); return 1; }
      #endif
    }

# UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
# String für den Host des Pathname pathname ergeben.
# host_namestring_parts(pathname)
# > pathname: nicht-Logical Pathname
# < ergebnis: Anzahl der auf den Stack gelegten Strings
# verändert STACK
#if HAS_HOST
  local uintC host_namestring_parts (object pathname);
  local uintC host_namestring_parts(pathname)
    var reg1 object pathname;
    { var reg2 object host = ThePathname(pathname)->pathname_host;
      if (nullp(host))
        { return 0; } # kein String
        else
        { pushSTACK(host);
          pushSTACK(O(doppelpunkt_string)); # ":"
          return 2;
    }   }
#else
  #define host_namestring_parts(pathname)  (pathname,0)  # keine Strings
#endif

# UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
# String fürs Device und Directory des Pathname pathname ergeben.
#if HAS_SERNR
# directory_namestring_parts(pathname,skipSN)
# > skipSN: Flag, ob Seriennummer unterdrückt werden soll
# > pathname: nicht-Logical Pathname
# < ergebnis: Anzahl der auf den Stack gelegten Strings
# falls skipSN: verändert STACK
# falls !skipSN: verändert STACK, kann GC auslösen
#else
# directory_namestring_parts(pathname)
# > pathname: nicht-Logical Pathname
# < ergebnis: Anzahl der auf den Stack gelegten Strings
# verändert STACK
#endif
  #if HAS_SERNR
  local uintC directory_namestring_parts (object pathname, boolean skipSN);
  #define directory_namestring_parts_(pathname)  \
    directory_namestring_parts(pathname,TRUE)
  local uintC directory_namestring_parts PARM2(pathname,skipSN,
    var reg4 object pathname,
    var reg5 boolean skipSN)
  #else
  local uintC directory_namestring_parts (object pathname);
  #define directory_namestring_parts_(pathname)  \
    directory_namestring_parts(pathname)
  local uintC directory_namestring_parts PARM1(pathname,
    var reg4 object pathname)
  #endif
    { var reg3 uintC stringcount = 0; # bisherige Stringzahl = 0
      #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
      # Device:
      { var reg1 object device = ThePathname(pathname)->pathname_device;
        if (!(nullp(device))) # NIL -> kein String
          { if (eq(device,S(Kwild))) { device = O(wild_string); } # :WILD -> String "*"
            pushSTACK(device); # Device auf den Stack
            stringcount++; # und mitzählen
      }   }
      #endif
      #ifdef PATHNAME_AMIGAOS
      # Device:
      { var reg1 object device = ThePathname(pathname)->pathname_device;
        if (!(nullp(device))) # NIL -> kein String
          { pushSTACK(device); # Device auf den Stack
            stringcount += 1; # und mitzählen
            # Wegen :ABSOLUTE kommt gleich danach ein ":" auf den Stack.
      }   }
      #endif
      #ifdef PATHNAME_RISCOS
      # Device:
      { var reg1 object device = ThePathname(pathname)->pathname_device;
        if (!(nullp(device))) # NIL -> kein String
          { pushSTACK(O(doppelpunkt_string)); # ":"
            pushSTACK(device); # Device auf den Stack
            pushSTACK(O(punkt_string)); # "."
            stringcount += 3; # und mitzählen
      }   }
      #endif
      # Directory:
      { var reg2 object directory = ThePathname(pathname)->pathname_directory;
        #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
        #if HAS_SERNR
        if (!skipSN)
          { var reg1 object seriennummer = Car(directory);
            if (!nullp(seriennummer))
              { # Seriennummer in dezimal umwandeln:
                pushSTACK(directory); # directory retten
                # (WRITE-TO-STRING Seriennummer :BASE 10 :RADIX NIL) ausführen:
                pushSTACK(seriennummer); # 1. Argument
                apply(L(write_to_string),1,O(base10_radixnil));
                directory = popSTACK();
                pushSTACK(value1); # Ergebnis-String in den Stack
                stringcount++; # und mitzählen
          }   }
        directory = Cdr(directory); # restliche subdirs
        #endif
        # evtl. Doppelpunkt:
        if (!(stringcount == 0)) # nur falls schon was auf dem Stack
          { pushSTACK(O(doppelpunkt_string)); stringcount++; } # ":" auf den Stack
        #endif
        # Ist das erste subdir = :ABSOLUTE oder = :RELATIVE ?
        if (eq(Car(directory),S(Kabsolute)))
          #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
          { pushSTACK(O(backslash_string)); stringcount++; } # "\\" auf den Stack
          #endif
          #ifdef PATHNAME_AMIGAOS
          { pushSTACK(O(doppelpunkt_string)); stringcount++; } # ":" auf den Stack
          #endif
          #ifdef PATHNAME_UNIX
          { pushSTACK(O(slash_string)); stringcount++; } # "/" auf den Stack
          #endif
          #ifdef PATHNAME_RISCOS
          { directory = Cdr(directory); # übergehen
           {var reg1 object firstdir = Car(directory);
            if (eq(firstdir,S(Kroot)))
              { pushSTACK(O(root_string)); stringcount++; } # "$." auf den Stack
            elif (eq(firstdir,S(Khome)))
              { pushSTACK(O(home_string)); stringcount++; } # "&." auf den Stack
            elif (eq(firstdir,S(Kcurrent)))
              { pushSTACK(O(current_string)); stringcount++; } # "@." auf den Stack
            elif (eq(firstdir,S(Klibrary)))
              { pushSTACK(O(library_string)); stringcount++; } # "%." auf den Stack
            elif (eq(firstdir,S(Kprevious)))
              { pushSTACK(O(previous_string)); stringcount++; } # "\\." auf den Stack
            else
              { NOTREACHED }
          }}
          #endif
        directory = Cdr(directory); # übergehen
        # weitere subdirs auf den Stack:
        while (consp(directory))
          { stringcount += subdir_namestring_parts(directory);
            #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
            pushSTACK(O(backslash_string)); stringcount++; # "\\" auf den Stack
            #endif
            #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)
            pushSTACK(O(slash_string)); stringcount++; # "/" auf den Stack
            #endif
            #ifdef PATHNAME_RISCOS
            pushSTACK(O(punkt_string)); stringcount++; # "." auf den Stack
            #endif
            directory = Cdr(directory);
          }
      }
      return stringcount;
    }

# UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
# String für Name und Typ des Pathname ergeben.
# nametype_namestring_parts(name,type,version)
# > name, type, evtl. version: Komponenten des Pathname
# < ergebnis: Anzahl der auf den Stack gelegten Strings
# kann GC auslösen
# verändert STACK
  #if HAS_VERSION
  local uintC nametype_namestring_parts (object name, object type, object version);
  local uintC nametype_namestring_parts PARM3(name,type,version,
    var reg2 object name,
    var reg1 object type,
    var reg4 object version)
  #else
  local uintC nametype_namestring_parts_ (object name, object type);
  local uintC nametype_namestring_parts_ PARM2(name,type,
    var reg2 object name,
    var reg1 object type)
  #define nametype_namestring_parts(n,t,v)  nametype_namestring_parts_(n,t)
  #endif
    { var reg3 uintC stringcount = 0;
      # Name:
      if (!nullp(name)) # name=NIL -> nicht ausgeben
        {
          #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
          if (eq(name,S(Kwild))) { name = O(wild_string); } # :WILD -> String "*"
          #endif
          pushSTACK(name); # Name auf den Stack
          stringcount++; # und mitzählen
        }
      # Typ:
      if (!nullp(type)) # type=NIL -> nicht ausgeben
        { pushSTACK(O(punkt_string)); # "." auf den Stack
          stringcount++; # und mitzählen
          #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
          if (eq(type,S(Kwild))) { type = O(wild_string); } # :WILD -> String "*"
          #endif
          pushSTACK(type); # Typ auf den Stack
          stringcount++; # und mitzählen
        }
      #if HAS_VERSION
      if (!nullp(version)) # version=NIL -> nicht ausgeben
        { pushSTACK(O(strichpunkt_string)); # ";" auf den Stack
          stringcount++; # und mitzählen
          if (eq(version,S(Knewest)))
            { pushSTACK(O(zero_string)); } # :NEWEST -> String "0"
            else
          # Version (Integer >0) in String umwandeln: (sys::decimal-string version)
          { pushSTACK(version);
            C_decimal_string(); # == funcall(L(decimal_string),1);
            pushSTACK(value1);
          }
          stringcount++; # und mitzählen
        }
      #endif
      return stringcount;
    }

# UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
# String für Name und Typ des Pathname ergeben.
# file_namestring_parts(pathname)
# > pathname: nicht-Logical Pathname
# < ergebnis: Anzahl der auf den Stack gelegten Strings
# kann GC auslösen
# verändert STACK
  local uintC file_namestring_parts (object pathname);
  local uintC file_namestring_parts(pathname)
    var reg1 object pathname;
    { return nametype_namestring_parts(ThePathname(pathname)->pathname_name,
                                       ThePathname(pathname)->pathname_type,
                                       ThePathname(pathname)->pathname_version);
    }

# UP: Wandelt Pathname in String um.
# whole_namestring(pathname)
# > pathname: nicht-Logical Pathname
# < ergebnis: Simple-String
# kann GC auslösen
  local object whole_namestring (object pathname);
  local object whole_namestring(pathname)
    var reg1 object pathname;
    { var reg2 uintC stringcount;
      #if HAS_SERNR
      pushSTACK(pathname); # pathname retten
      {var reg3 object* pathname_ = &STACK_0;
       stringcount = host_namestring_parts(pathname); # Strings für den Host
       stringcount += directory_namestring_parts(pathname,FALSE); # Strings fürs Directory
       pathname = *pathname_;
      }
      #else
      stringcount = host_namestring_parts(pathname); # Strings für den Host
      stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
      #endif
      stringcount += file_namestring_parts(pathname); # Strings für den Filename
      subr_self = L(namestring); # ("aktuelles" SUBR für Fehlermeldung)
     {var reg3 object ergebnis = string_concat(stringcount); # zusammenhängen
      #if HAS_SERNR
      skipSTACK(1); # pathname wieder vergessen
      #endif
      return ergebnis;
    }}

LISPFUNN(file_namestring,1)
# (FILE-NAMESTRING pathname), CLTL S. 417
  { var reg1 object pathname = coerce_pathname(popSTACK());
    var reg2 uintC stringcount = file_namestring_parts(pathname); # Strings für den Filename
    value1 = string_concat(stringcount); mv_count=1; # zusammenhängen
  }

# UP: Liefert den String zum Directory eines Pathname.
# directory_namestring(pathname)
# > pathname: nicht-Logical Pathname
# > subr_self: Aufrufer (ein SUBR)
# < ergebnis: Simple-String
# kann GC auslösen
  local object directory_namestring (object pathname);
  local object directory_namestring(pathname)
    var reg1 object pathname;
    { var reg2 uintC stringcount =
        #if HAS_SERNR
        directory_namestring_parts(pathname,FALSE); # Strings fürs Directory
        #else
        directory_namestring_parts(pathname); # Strings fürs Directory
        #endif
      return string_concat(stringcount); # zusammenhängen
    }

LISPFUNN(directory_namestring,1)
# (DIRECTORY-NAMESTRING pathname), CLTL S. 417
  { var reg1 object pathname = coerce_pathname(popSTACK());
    value1 = directory_namestring(pathname); mv_count=1;
  }

LISPFUNN(host_namestring,1)
# (HOST-NAMESTRING pathname), CLTL S. 417
  { var reg1 object pathname = coerce_pathname(popSTACK());
    #if HAS_HOST
    var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings für den Host
    value1 = string_concat(stringcount); # zusammenhängen
    #else
    value1 = O(leer_string); # "" als Wert
    #endif
    mv_count=1;
  }

#if HAS_VERSION || defined(LOGICAL_PATHNAMES)
# UP: Überprüft ein optionales VERSION-Argument.
# test_optional_version(def);
# > STACK_0: VERSION-Argument
# > def: Defaultwert dafür
# > subr_self: Aufrufer (ein SUBR)
# < ergebnis: gültige Version-Komponente
  local object test_optional_version (object def);
  local object test_optional_version(def)
    var reg2 object def;
    { var reg1 object version = STACK_0;
      if (eq(version,unbound)) { return def; } # nicht angegeben -> Default
      elif (nullp(version)) {} # NIL ist OK
      elif (eq(version,S(Kwild))) {} # :WILD ist OK
      elif (eq(version,S(Knewest))) {} # :NEWEST ist OK
      elif (posfixnump(version) && !eq(version,Fixnum_0)) {} # Fixnum >0 ist OK
      elif (pathnamep(version)) # Pathname -> dessen Version
        { STACK_0 = xpathname_version(FALSE,version); }
      #ifdef LOGICAL_PATHNAMES
      elif (logpathnamep(version)) # Logical Pathname -> dessen Version
        { STACK_0 = TheLogpathname(version)->pathname_version; }
      #endif
      else # Keiner der gewünschten Fälle -> Fehler:
        { pushSTACK(version); # Wert für Slot DATUM von TYPE-ERROR
          pushSTACK(O(type_version)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
          pushSTACK(version);
          pushSTACK(TheSubr(subr_self)->name);
          fehler(type_error,
                 DEUTSCH ? "~: :VERSION-Argument muß NIL oder ein Fixnum >0 oder :WILD oder :NEWEST sein, nicht ~" :
                 ENGLISH ? "~: :VERSION-argument should be NIL or a positive fixnum or :WILD or :NEWEST, not ~" :
                 FRANCAIS ? "~ : L'argument pour :VERSION doit être NIL, un petit nombre entier positif, :WILD ou :NEWEST mais non ~" :
                 ""
                );
        }
      return version;
    }
#else
# UP: Überprüft ein optionales VERSION-Argument.
# test_optional_version();
# > STACK_0: VERSION-Argument
# > subr_self: Aufrufer (ein SUBR)
  #define test_optional_version(def)  test_optional_version_()
  local void test_optional_version_ (void);
  local void test_optional_version_()
    { var reg1 object version = STACK_0;
      if (eq(version,unbound) # nicht angegeben?
          || nullp(version)         # oder NIL ?
          || eq(version,S(Kwild))   # oder :WILD ?
          || eq(version,S(Knewest)) # oder :NEWEST ?
         )
        { return; } # ja -> OK
        else
        { pushSTACK(version); # Wert für Slot DATUM von TYPE-ERROR
          pushSTACK(O(type_version)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
          pushSTACK(version);
          pushSTACK(TheSubr(subr_self)->name);
          fehler(type_error,
                 DEUTSCH ? "~: :VERSION-Argument muß NIL oder :WILD oder :NEWEST sein, nicht ~" :
                 ENGLISH ? "~: :VERSION-argument should be NIL or :WILD or :NEWEST, not ~" :
                 FRANCAIS ? "~ : L'argument pour :VERSION doit être NIL, :WILD ou :NEWEST mais non ~" :
                 ""
                );
    }   }
#endif

#ifdef PATHNAME_ATARI

# Suchbuffer für GEMDOS:
  local DTA DTA_buffer;

# Es wird ein Default-Drive geführt: DEFAULT_DRIVE = O(default_drive).

# Die Variable *DEFAULT-PATHNAME-DEFAULTS* enthält (als Pathname) den
# Defaultwert für jede MERGE-Operation. Dies ist derjenige, den das System
# in vom Benutzer eingegebene Pathnames "hineininterpretiert".
# Er wird auf dem neuesten Stand des DEFAULT_DRIVE gehalten: bei der
# Initialisierung das aktuelle Device (im Sinne von GEMDOS), bei der
# Änderung von DEFAULT_DRIVE mittels CD.

# Es wird eine Liste aller angeschlossenen Laufwerke und der Default-
# Directories bei allen bekannten Disketten geführt. Aufbau:
# ( { (device . ( { (Seriennummer . default-directory) } ) ) } )
# also eine Aliste, die abbildet:
# device (String der Länge 1) -> Aliste (Seriennummer -> default-directory),
# wobei die default-directories Pathnames sind, bei denen nur Device und
# Directory gefüllt sind, keine Wildcards vorkommen und das Directory
# nur subdirs der Form (name . type) enthält.
# Variable DRIVE_ALIST = O(drive_alist).

#endif # PATHNAME_ATARI

#if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)

# Das Betriebssystem verwaltet ein Default-Drive.
# Das Betriebssystem verwaltet auf jedem Drive ein Default-Directory. Dieses
# kann sich allerdings ändern, wenn eine andere Diskette eingelegt wird.

# Es wird ein Default-Drive geführt: DEFAULT_DRIVE = O(default_drive).

# Die Variable *DEFAULT-PATHNAME-DEFAULTS* enthält (als Pathname) den
# Defaultwert für jede MERGE-Operation. Dies ist derjenige, den das System
# in vom Benutzer eingegebene Pathnames "hineininterpretiert".
# Er wird auf dem neuesten Stand des DEFAULT_DRIVE gehalten: bei der
# Initialisierung das aktuelle Device (im Sinne von DOS), bei der
# Änderung von DEFAULT_DRIVE mittels CD.

#endif # PATHNAME_MSDOS || PATHNAME_OS2

#if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)

# Die Variable *DEFAULT-PATHNAME-DEFAULTS* enthält (als Pathname) den
# Defaultwert für jede MERGE-Operation. Dies ist derjenige, den das System
# in vom Benutzer eingegebene Pathnames "hineininterpretiert".

#endif

#ifdef UNIX

# Das Betriebssystem verwaltet ein Default-Directory ("working directory")
# für diesen Prozeß. Es kann mit chdir verändert und mit getwd abgefragt
# werden. Siehe CHDIR(2) und GETWD(3).

#endif

#ifdef AMIGAOS

# Das Betriebssystem verwaltet ein Default-Directory ("current directory")
# für diesen Prozeß. Es kann mit CurrentDir verändert und mit einer
# Kombination aus Examine und ParentDir abgefragt werden.

#endif

# UP: Neuberechnung von *DEFAULT-PATHNAME-DEFAULTS*
#if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
# aus DEFAULT_DRIVE
#endif
# recalc_defaults_pathname();
# < ergebnis: Wert von *DEFAULT-PATHNAME-DEFAULTS*, ein Pathname
# kann GC auslösen
  local object recalc_defaults_pathname (void);
  local object recalc_defaults_pathname()
    {
      #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
      # (MAKE-PATHNAME :DEVICE default-drive) ausführen:
      pushSTACK(S(Kdevice)); pushSTACK(O(default_drive));
      funcall(L(make_pathname),2);
      #endif
      #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
      # (MAKE-PATHNAME) ausführen:
      funcall(L(make_pathname),0);
      #endif
      # und *DEFAULT-PATHNAME-DEFAULTS* zuweisen:
      return Symbol_value(S(default_pathname_defaults)) = value1;
    }

# UP: Liefert den Default-Pathname.
# defaults_pathname()
# < ergebnis: Wert von *DEFAULT-PATHNAME-DEFAULTS*, ein Pathname
# kann GC auslösen
  local object defaults_pathname (void);
  local object defaults_pathname()
    { var reg1 object pathname = Symbol_value(S(default_pathname_defaults)); # Wert von *DEFAULT-PATHNAME-DEFAULTS*
      if (pathnamep(pathname))
        # ist Pathname -> OK
        { return pathname; }
        else
        # sonst Warnung:
        { # (WARN "Der Wert von ~S war kein Pathname. ~:*~S wird zurückgesetzt." ...)
          pushSTACK(OL(defaults_warn_string));
          pushSTACK(S(default_pathname_defaults));
          funcall(S(warn),2);
          # und neuberechnen:
          return recalc_defaults_pathname();
    }   }

LISPFUN(merge_pathnames,1,2,norest,key,1, (kw(wild)))
# (MERGE-PATHNAMES pathname [defaults [default-version]] [:wild]), CLTL S. 415
# (defun merge-pathnames (pathname &optional (defaults *default-pathname-defaults*) default-version)
#   (setq pathname (pathname pathname))
#   (setq defaults (pathname defaults))
#   (multiple-value-call #'make-pathname
#if HAS_HOST
#     (if (or (equal (pathname-host pathname) (pathname-host defaults))
#             (null (pathname-host pathname))
#         )
#       (values
#         :host (or (pathname-host pathname) (pathname-host defaults))
#endif
#if HAS_DEVICE
#     (if (or (equal (pathname-device pathname) (pathname-device defaults))
#             (null (pathname-device pathname))
#         )
#       (values
#         :device (or (pathname-device pathname) (pathname-device defaults))
#endif
#         :directory
#           (let ((pathname-dir (pathname-directory pathname))
#                 (defaults-dir (pathname-directory defaults)))
#if HAS_SERNR
#             (if (or (eql (car pathname-dir) (car defaults-dir))
#                     (null (car pathname-dir))
#                 )
#               (cons (or (car pathname-dir) (car defaults-dir))
#                 (progn (pop pathname-dir) (pop defaults-dir)
#endif
#                   (if (eq (car pathname-dir) ':RELATIVE)
#                     (cond ((null (cdr pathname-dir)) defaults-dir)
#                           ((not (eq (car defaults-dir) ':RELATIVE))
#                            (append defaults-dir (cdr pathname-dir))
#                           )
#                           (t pathname-dir)
#                     )
#                     pathname-dir
#                   )
#if HAS_SERNR
#               ) )
#               pathname-dir
#             )
#endif
#           )
#       )
#       (values
#if HAS_HOST
#         :host (pathname-host pathname)
#endif
#if HAS_DEVICE
#         :device (pathname-device pathname)
#endif
#         :directory (pathname-directory pathname)
#     ) )
#     :name (or (pathname-name pathname) (pathname-name defaults))
#     :type (or (pathname-type pathname) (pathname-type defaults))
# ) )
# Ist das :WILD-Argument angegeben, werden statt fehlenden Komponenten
# :WILD-Komponenten ersetzt.
  { var reg10 boolean wildp = !(eq(STACK_0,unbound) || nullp(STACK_0));
    skipSTACK(1);
    # default-version überprüfen:
    #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
    {var reg9 object v = test_optional_version(S(Knewest)); # Default ist :NEWEST
     STACK_0 = STACK_1; STACK_1 = STACK_2; STACK_2 = v;
    }# Stackaufbau: default-version, pathname, defaults.
    #else
     test_optional_version(S(Knewest)); skipSTACK(1);
     # Stackaufbau: pathname, defaults.
    #endif
    # pathname und defaults überprüfen:
    # defaults zu einem Pathname machen:
    STACK_0 = test_default_pathname(STACK_0);
    # pathname zu einem Pathname machen:
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(STACK_0))
      { if (!xpathnamep(STACK_1))
          { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
            # Das Ergebnis von (PARSE-NAMESTRING obj nil empty-logical-pathname)
            # ist garantiert ein logischer Pathname.
            pushSTACK(STACK_(1+1)); pushSTACK(NIL); pushSTACK(O(empty_logical_pathname));
            funcall(L(parse_namestring),3);
            subr_self = popSTACK();
            STACK_1 = value1;
      }   }
      else
    #endif
      { STACK_1 = coerce_xpathname(STACK_1); }
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(STACK_1) && logpathnamep(STACK_0))
      # MERGE-PATHNAMES für Logical Pathnames
      { var reg6 object new = allocate_logpathname(); # neuen Pathname holen
        var reg8 object d = popSTACK(); # defaults
        var reg7 object p = popSTACK(); # pathname
        # Hosts matchen:
        { var reg1 object p_host = TheLogpathname(p)->pathname_host;
          var reg2 object d_host = TheLogpathname(d)->pathname_host;
          TheLogpathname(new)->pathname_host = p_host; # erstmal new-host := pathname-host
          if (equal(p_host,d_host)) goto lmatch_directories;
          if (wildp ? FALSE : nullp(p_host))
            { # pathname-host nicht angegeben, aber defaults-host angegeben:
              TheLogpathname(new)->pathname_host = d_host; # new-host := defaults-host
              goto lmatch_directories;
        }   }
        # Directories nicht matchen:
        { # new-directory := pathname-directory :
          TheLogpathname(new)->pathname_directory = TheLogpathname(p)->pathname_directory;
        }
        goto ldirectories_OK;
        lmatch_directories:
        # Directories matchen:
        { var reg2 object p_directory = TheLogpathname(p)->pathname_directory; # pathname-directory
          var reg3 object d_directory = TheLogpathname(d)->pathname_directory; # defaults-directory
         {var reg4 object new_subdirs = p_directory;
      # Fängt pathname-subdirs mit :RELATIVE an?
          if (!wildp && eq(Car(p_directory),S(Krelative)))
            # ja.
            { # Endet pathname-subdirs danach?
              if (matomp(Cdr(p_directory)))
                # ja -> verwende defaults-subdirs:
                { new_subdirs = d_directory; }
                else
                # nein.
                { # Fängt defaults-subdirs mit :RELATIVE an?
                  if (eq(Car(d_directory),S(Krelative)))
                    # ja -> Ersetzen von :RELATIVE in pathname-subdirs
                    # durch das gesamte defaults-subdirs ist nicht sinnvoll
                    # (da nicht klar ist, auf was das dabei entstehende
                    # Default-Directory sich beziehen soll). Daher nichts tun:
                    {}
                    else
                    # nein -> Um :RELATIVE aufzulösen: ersetze :RELATIVE
                    # in pathname-subdirs durch defaults-subdirs, d.h.
                    # bilde (append defaults-subdirs (cdr pathname-subdirs)) =
                    # (nreconc (reverse defaults-subdirs) (cdr pathname-subdirs)) :
                    { pushSTACK(p); pushSTACK(d); pushSTACK(new);
                      pushSTACK(Cdr(p_directory));
                      {var reg1 object temp = reverse(d_directory);
                       new_subdirs = nreconc(temp,popSTACK());
                      }
                      new = popSTACK(); d = popSTACK(); p = popSTACK();
                    }
            }   }
          TheLogpathname(new)->pathname_directory = new_subdirs; # new-directory := new-subdirs
        }}
        ldirectories_OK:
        # Nun sind die Directories OK.
        # Name matchen:
        # Verwende pathname-name, falls angegeben, und defaults-name sonst.
        { var reg1 object p_name = TheLogpathname(p)->pathname_name;
          TheLogpathname(new)->pathname_name =
            (!(wildp ? eq(p_name,S(Kwild)) : nullp(p_name))
             ? p_name
             : TheLogpathname(d)->pathname_name
            );
        }
        # Typ matchen:
        # Verwende pathname-type, falls angegeben, und defaults-type sonst.
        { var reg1 object p_type = TheLogpathname(p)->pathname_type;
          TheLogpathname(new)->pathname_type =
            (!(wildp ? eq(p_type,S(Kwild)) : nullp(p_type))
             ? p_type
             : TheLogpathname(d)->pathname_type
            );
        }
        # Version matchen:
        # Verwende pathname-version, falls angegeben, und default-version sonst.
        { var reg1 object p_version = TheLogpathname(p)->pathname_version;
          TheLogpathname(new)->pathname_version =
            (!(wildp ? eq(p_version,S(Kwild)) : nullp(p_version))
             ? p_version
             : STACK_0
            );
          skipSTACK(1);
        }
        # new als Wert:
        value1 = new; mv_count=1;
        return;
      }
    # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
    STACK_1 = coerce_pathname(STACK_1);
    STACK_0 = coerce_pathname(STACK_0);
    #endif
   {var reg6 object new = allocate_pathname(); # neuen Pathname holen
    var reg8 object d = popSTACK(); # defaults
    var reg7 object p = popSTACK(); # pathname
    #if HAS_HOST
    # Hosts matchen:
    { var reg1 object p_host = ThePathname(p)->pathname_host;
      var reg2 object d_host = ThePathname(d)->pathname_host;
      ThePathname(new)->pathname_host = p_host; # erstmal new-host := pathname-host
      # beide Hosts gleich -> Devices matchen:
      if (equal(p_host,d_host)) goto match_devices;
      if (wildp ? FALSE : nullp(p_host))
        { # pathname-host nicht angegeben, aber defaults-host angegeben:
          ThePathname(new)->pathname_host = d_host; # new-host := defaults-host
          goto match_devices;
        }
      goto notmatch_devices;
    }
    #endif
    match_devices:
    #if HAS_DEVICE
    # Devices matchen:
    { var reg1 object p_device = ThePathname(p)->pathname_device;
      var reg2 object d_device = ThePathname(d)->pathname_device;
      ThePathname(new)->pathname_device = p_device; # erstmal new-device := pathname-device
      # beide Devices gleich -> Directories matchen:
      if (equal(p_device,d_device)) goto match_directories;
      if (wildp ? eq(p_device,S(Kwild)) : nullp(p_device))
        { # pathname-device nicht angegeben, aber defaults-device angegeben:
          ThePathname(new)->pathname_device = d_device; # new-device := defaults-device
          goto match_directories;
        }
      goto notmatch_directories;
    }
    #endif
    # Directories matchen:
    match_directories:
    { var reg2 object p_directory = ThePathname(p)->pathname_directory; # pathname-directory
      var reg3 object d_directory = ThePathname(d)->pathname_directory; # defaults-directory
      #if HAS_SERNR
      var reg5 object new_seriennummer = Car(p_directory); # pathname-Seriennummer
      # beide Seriennummern gleich -> Subdirectories matchen:
      if (eq(Car(p_directory),Car(d_directory))) goto match_subdirs;
      if (nullp(Car(p_directory)))
        { # pathname-Seriennummer nicht angegeben, aber defaults-Seriennummer angegeben:
          new_seriennummer = Car(d_directory); # new-Seriennummer := defaults-Seriennummer
          goto match_subdirs;
        }
      goto notmatch_directories;
      # Subdirectories matchen:
      match_subdirs:
      p_directory = Cdr(p_directory); # pathname-subdirs = (cdr pathname-directory)
      d_directory = Cdr(d_directory); # defaults-subdirs = (cdr defaults-directory)
      #endif
     {var reg4 object new_subdirs = p_directory;
      # Fängt pathname-subdirs mit :RELATIVE an?
      if (!wildp && eq(Car(p_directory),S(Krelative)))
        # ja.
        { # Endet pathname-subdirs danach?
          if (matomp(Cdr(p_directory)))
            # ja -> verwende defaults-subdirs:
            { new_subdirs = d_directory; }
            else
            # nein.
            { # Fängt defaults-subdirs mit :RELATIVE an?
              if (eq(Car(d_directory),S(Krelative)))
                # ja -> Ersetzen von :RELATIVE in pathname-subdirs
                # durch das gesamte defaults-subdirs ist nicht sinnvoll
                # (da nicht klar ist, auf was das dabei entstehende
                # Default-Directory sich beziehen soll). Daher nichts tun:
                {}
                else
                # nein -> Um :RELATIVE aufzulösen: ersetze :RELATIVE
                # in pathname-subdirs durch defaults-subdirs, d.h.
                # bilde (append defaults-subdirs (cdr pathname-subdirs)) =
                # (nreconc (reverse defaults-subdirs) (cdr pathname-subdirs)) :
                { pushSTACK(p); pushSTACK(d); pushSTACK(new);
                  #if HAS_SERNR
                  pushSTACK(new_seriennummer);
                  #endif
                  pushSTACK(Cdr(p_directory));
                  {var reg1 object temp = reverse(d_directory);
                   new_subdirs = nreconc(temp,popSTACK());
                  }
                  #if HAS_SERNR
                  new_seriennummer = popSTACK();
                  #endif
                  new = popSTACK(); d = popSTACK(); p = popSTACK();
                }
        }   }
      #if HAS_SERNR
      # new-directory aus new-Seriennummer und new-subdirs zusammensetzen:
      { pushSTACK(p); pushSTACK(d); pushSTACK(new);
        pushSTACK(new_seriennummer); pushSTACK(new_subdirs);
       {var reg1 object new_cons = allocate_cons(); # neues Cons
        Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
        # new_cons = (cons new-Seriennummer new-subdirs)
        new = popSTACK(); d = popSTACK(); p = popSTACK();
        new_subdirs = new_cons;
      }}
      #endif
      ThePathname(new)->pathname_directory = new_subdirs; # new-directory := new-subdirs
    }}
    goto directories_OK;
    # Devices nicht matchen:
    notmatch_devices:
    #if HAS_DEVICE
    { # new-device := pathname-device :
      ThePathname(new)->pathname_device = ThePathname(p)->pathname_device;
    }
    #endif
    # Directories nicht matchen:
    notmatch_directories:
    { # new-directory := pathname-directory :
      ThePathname(new)->pathname_directory = ThePathname(p)->pathname_directory;
    }
    directories_OK:
    # Nun sind die Directories OK.
    # Name matchen:
    # Verwende pathname-name, falls angegeben, und defaults-name sonst.
    { var reg1 object p_name = ThePathname(p)->pathname_name;
      ThePathname(new)->pathname_name =
        (!(wildp ?
           #ifdef PATHNAME_EXT83
           eq(p_name,S(Kwild))
           #else # PATHNAME_NOEXT || PATHNAME_RISCOS
           equal(p_name,O(wild_string))
           #endif
           : nullp(p_name)
          )
         ? p_name
         : ThePathname(d)->pathname_name
        );
    }
    # Typ matchen:
    # Verwende pathname-type, falls angegeben, und defaults-type sonst.
    { var reg1 object p_type = ThePathname(p)->pathname_type;
      ThePathname(new)->pathname_type =
        (!(wildp ?
           #ifdef PATHNAME_EXT83
           eq(p_type,S(Kwild))
           #else # PATHNAME_NOEXT || PATHNAME_RISCOS
           equal(p_type,O(wild_string))
           #endif
           : nullp(p_type)
          )
         ? p_type
         : ThePathname(d)->pathname_type
        );
    }
    #if HAS_VERSION
    # Version matchen:
    # Verwende pathname-version, falls angegeben, und default-version sonst.
    { var reg1 object p_version = ThePathname(p)->pathname_version;
      ThePathname(new)->pathname_version =
        (!(wildp ? eq(p_version,S(Kwild)) : nullp(p_version))
         ? p_version
         : STACK_0
        );
    }
    #endif
    #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
    skipSTACK(1);
    #endif
    # new als Wert:
    value1 = new; mv_count=1;
  }}

LISPFUN(enough_namestring,1,1,norest,nokey,0,NIL)
# (ENOUGH-NAMESTRING pathname [defaults]), CLTL S. 417
# (defun enough-namestring (pathname &optional (defaults *default-pathname-defaults*))
#   (setq pathname (pathname pathname))
#   (setq defaults (pathname defaults))
#   (namestring
#     (multiple-value-call #'make-pathname
#if HAS_HOST
#       (if (equal (pathname-host pathname) (pathname-host defaults))
#         (values
#           :host nil
#endif
#if HAS_DEVICE
#       (if (equal (pathname-device pathname) (pathname-device defaults))
#         (values
#           :device nil
#endif
#           :directory
#             (let ((pathname-dir (pathname-directory pathname))
#                   (defaults-dir (pathname-directory defaults)))
#if HAS_SERNR
#               (if (equal (car pathname-dir) (car defaults-dir))
#                 (cons nil
#                   (progn (pop pathname-dir) (pop defaults-dir)
#endif
#                     (if (equal pathname-dir defaults-dir)
#                       (list ':RELATIVE)
#                       (if (and (not (eq (car pathname-dir) ':RELATIVE))
#                                (not (eq (car defaults-dir) ':RELATIVE))
#                                (equal (subseq pathname-dir 0 (min (length pathname-dir) (length defaults-dir)))
#                                       defaults-dir
#                           )    )
#                         (cons ':RELATIVE (nthcdr (length defaults-dir) pathname-dir))
#                         pathname-dir
#                     ) )
#if HAS_SERNR
#                 ) )
#                 pathname-dir
#               )
#endif
#             )
#         )
#         (values
#if HAS_HOST
#           :host (pathname-host pathname)
#endif
#if HAS_DEVICE
#           :device (pathname-device pathname)
#endif
#           :directory (pathname-directory pathname)
#       ) )
#       :name (if (equal (pathname-name pathname) (pathname-name defaults))
#               nil
#               (pathname-name pathname)
#             )
#       :type (if (equal (pathname-type pathname) (pathname-type defaults))
#               nil
#               (pathname-type pathname)
#             )
# ) ) )
  { # pathname und defaults überprüfen:
    # pathname zu einem Pathname machen:
    STACK_1 = coerce_pathname(STACK_1);
    # defaults zu einem Pathname machen:
    STACK_0 = coerce_pathname(test_default_pathname(STACK_0));
    # neuen Pathname holen:
   {var reg6 object new = allocate_pathname();
    pushSTACK(new);
    # Stackaufbau: pathname, defaults, new.
    #if HAS_HOST
    # Hosts vergleichen:
    { var reg7 object p_host = ThePathname(STACK_2)->pathname_host; # pathname-host
      var reg8 object d_host = ThePathname(STACK_1)->pathname_host; # defaults-host
      if (equal(p_host,d_host)) # beide Hosts gleich ?
        # ja.
        { ThePathname(new)->pathname_host = NIL; # new-host := NIL
    #endif
    #if HAS_DEVICE
    # Devices vergleichen:
    { var reg7 object p_device = ThePathname(STACK_2)->pathname_device; # pathname-device
      var reg8 object d_device = ThePathname(STACK_1)->pathname_device; # defaults-device
      if (equal(p_device,d_device)) # beide Devices gleich ?
        # ja.
        { ThePathname(new)->pathname_device = NIL; # new-device := NIL
    #endif
         {var reg3 object p_directory = ThePathname(STACK_2)->pathname_directory; # pathname-directory
          var reg4 object d_directory = ThePathname(STACK_1)->pathname_directory; # defaults-directory
          #if HAS_SERNR
          if (eq(Car(p_directory),Car(d_directory))) # gleiche Seriennummern ?
            # ja -> verwende NIL als Seriennummer
            { p_directory = Cdr(p_directory); # pathname-subdirs
              d_directory = Cdr(d_directory); # defaults-subdirs
          #endif
             {var reg5 object new_subdirs;
              # vergleiche pathname-subdirs und defaults-subdirs:
              if (equal(p_directory,d_directory))
                # gleich -> verwende (cons :RELATIVE nil) :
                { new_subdirs = NIL; goto insert_RELATIVE; }
                else
                { # Fängt weder pathname-subdirs noch defaults-subdirs
                  # mit :RELATIVE an?
                  if (   (!eq(Car(p_directory),S(Krelative)))
                      && (!eq(Car(d_directory),S(Krelative)))
                     )
                    # ja -> testen, ob defaults-subdirs ein Anfangsstück
                    # der Liste pathname-subdirs ist:
                    { var reg1 object Lp = p_directory;
                      var reg2 object Ld = d_directory;
                      # Ist Ld ein Anfangsstück von Lp ?
                      loop
                        { if (atomp(Ld)) # Ld zu Ende -> ja
                            { new_subdirs = Lp; goto insert_RELATIVE; }
                          if (atomp(Lp)) break; # Lp zu Ende -> nein
                          if (!equal(Car(Ld),Car(Lp))) # verschiedene Listenelemente?
                            break; # -> nein
                          Ld = Cdr(Ld); Lp = Cdr(Lp); # Listen weiterrücken
                        }
                    }
                  new_subdirs = p_directory; # new-subdirs := pathname-subdirs
                  goto subdirs_ok;
                }
              insert_RELATIVE:
              # new-subdirs := (cons :RELATIVE new-subdirs) :
              { pushSTACK(new_subdirs);
                new_subdirs = allocate_cons();
                Cdr(new_subdirs) = popSTACK(); Car(new_subdirs) = S(Krelative);
              }
              subdirs_ok: # new-subdirs ist die neue Subdir-Liste.
              #if HAS_SERNR
              # new-subdirs := (cons NIL new-subdirs) :
              { pushSTACK(new_subdirs);
               {var reg1 object new_cons = allocate_cons();
                Cdr(new_cons) = popSTACK();
                new_subdirs = new_cons;
              }}
              #endif
              # new-directory := new-subdirs :
              ThePathname(new=STACK_0)->pathname_directory = new_subdirs;
             }
            #if HAS_SERNR
            }
            else
            # verschiedene Seriennummern -> new-directory := pathname-directory :
            { ThePathname(new)->pathname_directory = p_directory; }
            #endif
         }
    #if HAS_DEVICE
        }
        else
        # verschiedene Devices
        { # new-device := pathname-device :
          ThePathname(new)->pathname_device = p_device;
          # new-directory := pathname-directory :
          ThePathname(new)->pathname_directory = ThePathname(STACK_2)->pathname_directory;
        }
    }
    #endif
    #if HAS_HOST
        }
        else
        # verschiedene Hosts
        { # new-host := pathname-host :
          ThePathname(new)->pathname_host = p_host;
          #if HAS_DEVICE
          # new-device := pathname-device :
          ThePathname(new)->pathname_device = ThePathname(STACK_2)->pathname_device;
          #endif
          # new-directory := pathname-directory :
          ThePathname(new)->pathname_directory = ThePathname(STACK_2)->pathname_directory;
        }
    }
    #endif
    # name einfüllen:
    { var reg1 object p_name = ThePathname(STACK_2)->pathname_name; # pathname-name
      var reg2 object d_name = ThePathname(STACK_1)->pathname_name; # defaults-name
      ThePathname(new)->pathname_name = (equal(p_name,d_name) ? NIL : p_name);
    }
    # type einfüllen:
    { var reg1 object p_type = ThePathname(STACK_2)->pathname_type; # pathname-type
      var reg2 object d_type = ThePathname(STACK_1)->pathname_type; # defaults-type
      ThePathname(new)->pathname_type = (equal(p_type,d_type) ? NIL : p_type);
    }
    skipSTACK(3);
    # (namestring new) bilden:
    value1 = whole_namestring(new); mv_count=1;
  }}

#ifdef LOGICAL_PATHNAMES

# UP: Überprüft, ob object ein zulässiger Name ist:
# :WILD oder ein Simple-String aus gültigen Zeichen, keine adjazenten '*'.
# legal_logical_word(object)
  local boolean legal_logical_word (object obj);
  local boolean legal_logical_word(obj)
    var reg5 object obj;
    { if (eq(obj,S(Kwild))) { return TRUE; }
      if (!simple_string_p(obj)) { return FALSE; }
     {var reg3 uintL len = TheSstring(obj)->length;
      if (len==0) { return FALSE; } # leeres Word ist verboten
      {var reg2 uintB* charptr = &TheSstring(obj)->data[0];
       var reg4 boolean last_was_star = FALSE;
       dotimespL(len,len,
         { var reg1 uintB ch = *charptr++;
           if (!(legal_logical_word_char(ch) || (ch=='*'))) { return FALSE; }
           if (ch=='*')
             { if (last_was_star) return FALSE; # adjazente '*' sind verboten
               last_was_star = TRUE;
             }
             else
             { last_was_star = FALSE; }
         });
       return TRUE;
    }}}

#endif

#ifdef PATHNAME_EXT83

# UP: Überprüft, ob object ein zulässiger Name oder Typ ist: :WILD oder
# ein Simple-String mit max. stdlen Zeichen, alle alphabetisch und Up-case.
# legal_name_or_type(object,stdlen)
  local boolean legal_name_or_type (object obj, uintL stdlen);
  local boolean legal_name_or_type(obj,stdlen)
    var reg3 object obj;
    var reg4 uintL stdlen;
    { if (eq(obj,S(Kwild))) { return TRUE; } # :WILD ist OK
      if (!simple_string_p(obj)) { return FALSE; } # sonst: Simple-String ?
     {var reg2 uintL len = TheSstring(obj)->length;
      #ifndef EMUNIX_PORTABEL
      if (!(len <= stdlen)) { return FALSE; } # und Länge <=stdlen ?
      #endif
      # Jedes einzelne Zeichen überprüfen:
      {var reg1 uintB* ptr = &TheSstring(obj)->data[0];
       dotimesL(len,len,
         { var reg1 uintB ch = *ptr++;
           if (!(legal_namechar(ch) # zulässiges Zeichen ?
                 && (up_case(ch)==ch) # und Großbuchstabe ?
              ) )
             { return FALSE; }
         });
      }
      return TRUE;
    }}

# UP: Überprüft, ob object ein zulässiger Name ist: :WILD oder
# ein Simple-String mit max. 8 Zeichen, alle alphabetisch und Up-case.
# legal_name(object)
  #define legal_name(obj)  legal_name_or_type(obj,8)

# UP: Überprüft, ob object ein zulässiger Typ ist: :WILD oder
# ein Simple-String mit max. 3 Zeichen, alle alphabetisch und Up-case.
# legal_type(object)
  #define legal_type(obj)  legal_name_or_type(obj,3)

#endif # PATHNAME_EXT83

#if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)

# UP: Überprüft, ob object ein zulässiger Name ist:
# ein Simple-String aus gültigen Zeichen
# legal_name(object)
  local boolean legal_name (object obj);
  local boolean legal_name(obj)
    var reg3 object obj;
    { if (!simple_string_p(obj)) { return FALSE; }
     {var reg2 uintL len = TheSstring(obj)->length;
      var reg1 uintB* charptr = &TheSstring(obj)->data[0];
      dotimesL(len,len, { if (!legal_namechar(*charptr++)) { return FALSE; } } );
      return TRUE;
    }}

# UP: Überprüft, ob object ein zulässiger Name ist:
# ein Simple-String aus gültigen Zeichen, ohne '.'
# legal_type(object)
  local boolean legal_type (object obj);
#ifdef PATHNAME_NOEXT
  local boolean legal_type(obj)
    var reg4 object obj;
    { if (!simple_string_p(obj)) { return FALSE; }
     {var reg3 uintL len = TheSstring(obj)->length;
      var reg2 uintB* charptr = &TheSstring(obj)->data[0];
      dotimesL(len,len,
        { var reg1 uintB ch = *charptr++;
          if ((ch=='.') || (!legal_namechar(ch))) { return FALSE; }
        });
      return TRUE;
    }}
#endif
#ifdef PATHNAME_RISCOS
  #define legal_type(obj)  legal_name(obj)
#endif

#endif # PATHNAME_NOEXT || PATHNAME_RISCOS

LISPFUN(make_pathname,0,0,norest,key,8,\
        (kw(defaults),kw(case),kw(host),kw(device),kw(directory),kw(name),kw(type),kw(version)) )
# (MAKE-PATHNAME [:host] [:device] [:directory] [:name] [:type] [:version]
#                [:defaults] [:case]),
# CLTL S. 416, CLtL2 S. 643
  # Stackaufbau: defaults, case, host, device, directory, name, type, version.
  { var reg5 boolean logical = FALSE;
    var reg4 boolean convert = eq(STACK_6,S(Kcommon));
    # 1. host überprüfen:
    #ifdef LOGICAL_PATHNAMES
    # Damit TRANSLATE-PATHNAMES logische Pathnames erzeugen kann:
    if (logpathnamep(STACK_5))
      { STACK_5 = TheLogpathname(STACK_5)->pathname_host;
        logical = TRUE; convert = FALSE;
      }
    #endif
    #if HAS_HOST
    STACK_5 = test_optional_host(STACK_5,convert);
    #else
    STACK_5 = test_optional_host(STACK_5);
    #endif
    #ifdef LOGICAL_PATHNAMES
    if (!nullp(STACK_5) && logical_host_p(STACK_5))
      { logical = TRUE; convert = FALSE; STACK_5 = string_upcase(STACK_5); }
    #endif
    # 2. device überprüfen:
    #if HAS_DEVICE
    { var reg1 object device = STACK_4;
      if (eq(device,unbound)) # angegeben ?
        { STACK_4 = NIL; } # nein -> verwende NIL
        else
        { if (convert) { STACK_4 = device = common_case(device); }
          if (nullp(device)) goto device_ok; # = NIL ?
          #ifdef LOGICAL_PATHNAMES
          elif (logical)
            { if (logpathnamep(device)) # Pathname -> dessen Device
                { STACK_4 = NIL; goto device_ok; }
            }
          #endif
          #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
          elif (eq(device,S(Kwild))) goto device_ok; # = :WILD ?
          elif (simple_string_p(device)) # Simple-String ?
            { if (TheSstring(device)->length == 1) # der Länge 1 ?
                { var reg2 uintB ch = TheSstring(device)->data[0];
                  if ((ch >= 'A') && (ch <= 'Z')) # mit Buchstaben >='A' und <='Z' ?
                    goto device_ok;
            }   }
          #endif
          #ifdef PATHNAME_AMIGAOS
          elif (simple_string_p(device)) # Simple-String ?
            { var reg1 uintB* ptr = &TheSstring(device)->data[0];
              var reg2 uintL count;
              dotimesL(count,TheSstring(device)->length,
                { if (!legal_namechar(*ptr++)) goto device_not_ok; }
                );
              goto device_ok;
              device_not_ok: ;
            }
          #endif
          #ifdef PATHNAME_RISCOS
          elif (simple_string_p(device)) # Simple-String ?
            { var reg2 uintB* ptr = &TheSstring(device)->data[0];
              var reg3 uintL count;
              dotimesL(count,TheSstring(device)->length,
                { var reg2 uintB ch = *ptr++;
                  if (!(legal_namechar(ch) && !(ch=='*') && !singlewild_char_p(ch)))
                    goto device_not_ok;
                });
              goto device_ok;
              device_not_ok: ;
            }
          #endif
          elif (xpathnamep(device)) # Pathname -> dessen Device
            {
              #ifdef LOGICAL_PATHNAMES
              device = coerce_pathname(device);
              #endif
              STACK_4 = ThePathname(device)->pathname_device; goto device_ok;
            }
          # Keiner der gewünschten Fälle -> Fehler:
          pushSTACK(STACK_4); pushSTACK(S(Kdevice)); goto fehler_arg;
          device_ok: ;
    }   }
    #else
    { var reg1 object device = STACK_4;
      if (!eq(device,unbound)) # angegeben ?
        if (!(nullp(device) || xpathnamep(device))) # NIL oder Pathname -> OK
          # Keiner der gewünschten Fälle -> Fehler:
          { pushSTACK(STACK_4); pushSTACK(S(Kdevice)); goto fehler_arg; }
    }
    #endif
    # 3. directory überprüfen:
    { var reg1 object directory = STACK_3;
      if (eq(directory,unbound) || nullp(directory)) # nicht angegeben oder =NIL ?
        { STACK_3 = O(directory_default); # Default ist ([NIL] :RELATIVE)
          goto directory_ok;
        }
      elif (consp(directory)) # ein Cons?
        { if (convert) { STACK_3 = directory = subst_common_case(directory); }
          #ifdef LOGICAL_PATHNAMES
          if (!logical)
          #endif
            {
              #if HAS_SERNR
              # Der CAR entweder NIL oder ein Fixnum >=0 ?
              if (!(nullp(Car(directory)) || mposfixnump(Car(directory))))
                goto directory_bad;
              directory = Cdr(directory); # subdir-Liste
              #endif
            }
          # Der CAR entweder :RELATIVE oder :ABSOLUTE ?
          if (!consp(directory)) goto directory_bad;
          { var reg1 object startpoint = Car(directory);
            if (!(eq(startpoint,S(Krelative)) || eq(startpoint,S(Kabsolute))))
              goto directory_bad;
            #ifdef PATHNAME_RISCOS
            if (!logical && eq(startpoint,S(Kabsolute)))
              { directory = Cdr(directory);
                startpoint = Car(directory);
                if (!(eq(startpoint,S(Kroot))
                      || eq(startpoint,S(Khome))
                      || eq(startpoint,S(Kcurrent))
                      || eq(startpoint,S(Klibrary))
                      || eq(startpoint,S(Kprevious))
                   ) )
                  goto directory_bad;
              }
            #endif
          }
          directory = Cdr(directory);
          # Subdir-Liste überprüfen:
          while (consp(directory))
            { # nächstes subdir überprüfen:
              var reg1 object subdir = Car(directory);
              #ifdef LOGICAL_PATHNAMES
              if (logical)
                { if (!(eq(subdir,S(Kwild_inferiors)) || legal_logical_word(subdir)))
                    goto directory_bad;
                }
                else
              #endif
                {
                  #ifdef PATHNAME_EXT83
                  if (consp(subdir))
                    { # subdir ist ein Cons
                      if (!(legal_name(Car(subdir)) && legal_type(Cdr(subdir))))
                        goto directory_bad;
                    }
                    else
                    { # subdir ist ein Atom
                      if (!(eq(subdir,S(Kcurrent)) # = :CURRENT ?
                            || eq(subdir,S(Kparent)) # = :PARENT ?
                            || eq(subdir,S(Kwild_inferiors)) # = :WILD-INFERIORS ?
                         ) )
                        goto directory_bad;
                    }
                  #endif
                  #ifdef PATHNAME_NOEXT
                  #ifdef PATHNAME_AMIGAOS
                  if (!(eq(subdir,S(Kwild_inferiors)) || eq(subdir,S(Kparent))
                        || legal_name(subdir)
                     ) )
                    goto directory_bad;
                  #endif
                  #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2)
                  if (!(eq(subdir,S(Kwild_inferiors)) || legal_name(subdir)))
                    goto directory_bad;
                  #endif
                  #endif
                  #ifdef PATHNAME_RISCOS
                  if (!(eq(subdir,S(Kparent)) || legal_name(subdir)))
                    goto directory_bad;
                  #endif
                }
              directory = Cdr(directory);
            }
          goto directory_ok;
        }
      #ifdef LOGICAL_PATHNAMES
      elif (logical)
        { if (logpathnamep(directory)) # Pathname -> dessen Directory
            { STACK_3 = TheLogpathname(directory)->pathname_directory; goto directory_ok; }
        }
      #endif
      elif (xpathnamep(directory)) # Pathname -> dessen Directory
        {
          #ifdef LOGICAL_PATHNAMES
          directory = coerce_pathname(directory);
          #endif
          STACK_3 = ThePathname(directory)->pathname_directory; goto directory_ok;
        }
      # Keiner der gewünschten Fälle -> Fehler:
      directory_bad:
      pushSTACK(STACK_3); pushSTACK(S(Kdirectory)); goto fehler_arg;
      directory_ok: ;
      #ifdef PATHNAME_AMIGAOS
      # Bei device /= NIL muß directory mit :ABSOLUTE anfangen:
      if (!nullp(STACK_4) && !eq(Car(STACK_3),S(Kabsolute))) goto directory_bad;
      #endif
    }
    # 4. name überprüfen:
    { var reg1 object name = STACK_2;
      if (convert) { STACK_2 = name = common_case(name); }
      if (eq(name,unbound))
        { STACK_2 = NIL; } # nicht angegeben -> verwende NIL
      elif (nullp(name)) {} # NIL ist OK
      #ifdef LOGICAL_PATHNAMES
      elif (logical)
        { if (legal_logical_word(name)) {} # OK
          elif (logpathnamep(name)) # Pathname -> dessen Name
            { STACK_2 = TheLogpathname(name)->pathname_name; }
          else # Keiner der gewünschten Fälle -> Fehler:
            { pushSTACK(STACK_2); pushSTACK(S(Kname)); goto fehler_arg; }
        }
      #endif
      #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
      elif (eq(name,S(Kwild))) { STACK_2 = O(wild_string); } # aus :WILD mache "*"
      #endif
      elif (equal(name,O(leer_string))) # name = "" ?
        { STACK_2 = NIL; } # ja -> verwende NIL
      elif (legal_name(name)) {} # zulässiger Name ist OK
      elif (xpathnamep(name)) # Pathname -> dessen Name
        {
          #ifdef LOGICAL_PATHNAMES
          name = coerce_pathname(name);
          #endif
          STACK_2 = ThePathname(name)->pathname_name;
        }
      else # Keiner der gewünschten Fälle -> Fehler:
        { pushSTACK(STACK_2); pushSTACK(S(Kname)); goto fehler_arg; }
    }
    # 5. type überprüfen:
    { var reg1 object type = STACK_1;
      if (convert) { STACK_1 = type = common_case(type); }
      if (eq(type,unbound))
        { STACK_1 = NIL; } # nicht angegeben -> verwende NIL
      elif (nullp(type)) {} # NIL ist OK
      #ifdef LOGICAL_PATHNAMES
      elif (logical)
        { if (legal_logical_word(type)) {} # OK
          elif (logpathnamep(type)) # Pathname -> dessen Typ
            { STACK_1 = TheLogpathname(type)->pathname_type; }
          else # Keiner der gewünschten Fälle -> Fehler:
            { pushSTACK(STACK_1); pushSTACK(S(Ktype)); goto fehler_arg; }
        }
      #endif
      #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
      elif (eq(type,S(Kwild))) { STACK_1 = O(wild_string); } # aus :WILD mache "*"
      #endif
      elif (legal_type(type)) {} # zulässiger Typ ist OK
      elif (xpathnamep(type)) # Pathname -> dessen Typ
        {
          #ifdef LOGICAL_PATHNAMES
          type = coerce_pathname(type);
          #endif
          STACK_1 = ThePathname(type)->pathname_type;
        }
      else # Keiner der gewünschten Fälle -> Fehler:
        { pushSTACK(STACK_1); pushSTACK(S(Ktype)); goto fehler_arg; }
    }
    # 6. version überprüfen:
    #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
    STACK_0 = test_optional_version(NIL); # Default ist NIL
    #else
    test_optional_version(NIL);
    #endif
    # 7. Pathname bauen:
    {var reg1 object pathname;
     #ifdef LOGICAL_PATHNAMES
     if (logical)
       { pathname = allocate_logpathname(); # neuer Logical Pathname
         TheLogpathname(pathname)->pathname_version   = popSTACK();
         TheLogpathname(pathname)->pathname_type      = popSTACK();
         TheLogpathname(pathname)->pathname_name      = popSTACK();
         TheLogpathname(pathname)->pathname_directory = popSTACK();
         skipSTACK(1);
         TheLogpathname(pathname)->pathname_host      = popSTACK();
       }
       else
     #endif
       { pathname = allocate_pathname(); # neuer Pathname
         #if HAS_VERSION
         ThePathname(pathname)->pathname_version   = popSTACK();
         #else
         skipSTACK(1);
         #endif
         ThePathname(pathname)->pathname_type      = popSTACK();
         ThePathname(pathname)->pathname_name      = popSTACK();
         ThePathname(pathname)->pathname_directory = popSTACK();
         #if HAS_DEVICE
         ThePathname(pathname)->pathname_device    = popSTACK();
         #else
         skipSTACK(1);
         #endif
         #if HAS_HOST
         ThePathname(pathname)->pathname_host      = popSTACK();
         #else
         skipSTACK(1);
         #endif
       }
    skipSTACK(1); # case vergessen
    # 8. evtl. Defaults hineinmergen:
     {var reg2 object defaults = popSTACK();
      if (eq(defaults,unbound))
        # keine Defaults angegeben -> pathname als Wert
        { value1 = pathname; }
        else
        # (MERGE-PATHNAMES pathname defaults [nil]) aufrufen:
        { pushSTACK(pathname); pushSTACK(defaults); pushSTACK(NIL);
          funcall(L(merge_pathnames),3);
        }
      mv_count=1;
      return;
    }}
    # Fehlermeldung:
    fehler_arg:
    pushSTACK(TheSubr(subr_self)->name);
    fehler(error,
           DEUTSCH ? "~: Unzulässiges ~-Argument ~" :
           ENGLISH ? "~: illegal ~ argument ~" :
           FRANCAIS ? "~ : Argument incorrect pour ~ : ~" :
           ""
          );
  }

#ifdef LOGICAL_PATHNAMES

LISPFUN(make_logical_pathname,0,0,norest,key,8,\
        (kw(defaults),kw(case),kw(host),kw(device),kw(directory),kw(name),kw(type),kw(version)) )
# (MAKE-LOGICAL-PATHNAME [:host] [:device] [:directory] [:name] [:type] [:version]
#                        [:defaults] [:case]),
# wie MAKE-PATHNAME, nur daß ein Logical Pathname gebildet wird.
  { # Ein logischer Pathname als :HOST-Argument zu MAKE-PATHNAME
    # erzwingt einen logischen Pathname als Ergebnis.
    var reg1 object obj = allocate_logpathname();
    TheLogpathname(obj)->pathname_host = (!eq(STACK_5,unbound) ? STACK_5 : NIL);
    STACK_5 = obj;
    # weiter bei MAKE-PATHNAME.
    C_make_pathname();
  }

#endif

#ifdef USER_HOMEDIR
LISPFUN(user_homedir_pathname,0,1,norest,nokey,0,NIL)
# (USER-HOMEDIR-PATHNAME [host]), CLTL S. 418
  {
    #if HAS_HOST
    STACK_0 = test_optional_host(STACK_0,FALSE); # Host überprüfen
    #ifdef PATHNAME_RISCOS
    {var reg1 object pathname = allocate_pathname(); # neuer Pathname
     ThePathname(pathname)->pathname_host      = popSTACK();
     #if HAS_DEVICE
     ThePathname(pathname)->pathname_device    = NIL;
     #endif
     ThePathname(pathname)->pathname_directory = O(directory_homedir);
     ThePathname(pathname)->pathname_name      = NIL;
     ThePathname(pathname)->pathname_type      = NIL;
     #if HAS_VERSION
     ThePathname(pathname)->pathname_version   = NIL;
     #endif
     value1 = pathname;
    }
    #else
    ??
    #endif
    #else
    test_optional_host(popSTACK()); # Host überprüfen und ignorieren
    value1 = O(user_homedir); # User-Homedir-Pathname
    #endif
    mv_count=1; # als Wert
  }
#endif

# UP: Kopiert einen Pathname.
# copy_pathname(pathname)
# > pathname: nicht-Logical Pathname
# < ergebnis: Kopie des Pathname, mit denselben Komponenten
# kann GC auslösen
  local object copy_pathname (object pathname);
  local object copy_pathname(pathname)
    var reg2 object pathname;
    { pushSTACK(pathname);
     {var reg1 object new = allocate_pathname();
      pathname = popSTACK();
      #if HAS_HOST
      ThePathname(new)->pathname_host      = ThePathname(pathname)->pathname_host     ;
      #endif
      #if HAS_DEVICE
      ThePathname(new)->pathname_device    = ThePathname(pathname)->pathname_device   ;
      #endif
      ThePathname(new)->pathname_directory = ThePathname(pathname)->pathname_directory;
      ThePathname(new)->pathname_name      = ThePathname(pathname)->pathname_name     ;
      ThePathname(new)->pathname_type      = ThePathname(pathname)->pathname_type     ;
      #if HAS_VERSION
      ThePathname(new)->pathname_version   = ThePathname(pathname)->pathname_version  ;
      #endif
      return new;
    }}

# Wildcards
# =========

#if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
# UP: Testet, ob ein Simple-String Wildcards enthält.
# has_wildcards(string)
# > string: Simple-String
# < ergebnis: TRUE wenn string Wildcard-Zeichen enthält
  local boolean has_wildcards (object string);
  local boolean has_wildcards(string)
    var reg4 object string;
    { var reg3 uintL len = TheSstring(string)->length;
      var reg2 uintB* charptr = &TheSstring(string)->data[0];
      dotimesL(len,len,
        { var reg1 uintB ch = *charptr++;
          if ((ch=='*') # Wildcard für beliebig viele Zeichen
              || singlewild_char_p(ch) # Wildcard für genau ein Zeichen
             )
            { return TRUE; }
        });
      return FALSE;
    }
#endif

#ifdef LOGICAL_PATHNAMES
# UP: Testet, ob ein Simple-String Wildcards enthält.
# has_word_wildcards(string)
# > string: Simple-String
# < ergebnis: TRUE wenn string Wildcard-Zeichen enthält
  local boolean has_word_wildcards (object string);
  local boolean has_word_wildcards(string)
    var reg3 object string;
    { var reg2 uintL len = TheSstring(string)->length;
      var reg1 uintB* charptr = &TheSstring(string)->data[0];
      dotimesL(len,len, { if (*charptr++ == '*') { return TRUE; } } );
      return FALSE;
    }
#endif

# UP: Testet, ob die Host-Komponente eines Pathname Wildcards enthält.
# has_host_wildcards(pathname)
# > pathname: Pathname
# < ergebnis: TRUE wenn (PATHNAME-HOST pathname) Wildcards enthält.
  local boolean has_host_wildcards (object pathname);
  # Host kann keine Wildcards enthalten.
  #define has_host_wildcards(pathname)  (pathname, FALSE)

# UP: Testet, ob die Device-Komponente eines Pathname Wildcards enthält.
# has_device_wildcards(pathname)
# > pathname: Pathname
# < ergebnis: TRUE wenn (PATHNAME-DEVICE pathname) Wildcards enthält.
  local boolean has_device_wildcards (object pathname);
  local boolean has_device_wildcards(pathname)
    var reg1 object pathname;
    {
      #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
      #ifdef LOGICAL_PATHNAMES
      if (logpathnamep(pathname))
        return FALSE;
      #endif
      # Device überprüfen: = :WILD ?
      return eq(ThePathname(pathname)->pathname_device,S(Kwild));
      #else
      return FALSE;
      #endif
    }

# UP: Testet, ob die Directory-Komponente eines Pathname Wildcards enthält.
# has_directory_wildcards(pathname)
# > pathname: Pathname
# < ergebnis: TRUE wenn (PATHNAME-DIRECTORY pathname) Wildcards enthält.
  local boolean has_directory_wildcards (object pathname);
  local boolean has_directory_wildcards(pathname)
    var reg3 object pathname;
    { # Directory überprüfen:
      #ifdef LOGICAL_PATHNAMES
      if (logpathnamep(pathname))
        { var reg1 object directory = TheLogpathname(pathname)->pathname_directory;
          while (consp(directory = Cdr(directory)))
            { var reg2 object subdir = Car(directory);
              if (simple_string_p(subdir))
                { if (has_word_wildcards(subdir)) return TRUE; }
                else
                { if (eq(subdir,S(Kwild)) || eq(subdir,S(Kwild_inferiors)))
                    return TRUE;
            }   }
          return FALSE;
        }
      #endif
     {var reg1 object directory = ThePathname(pathname)->pathname_directory;
      #if HAS_SERNR
      directory = Cdr(directory); # Seriennummer übergehen
      #endif
      while (consp(directory = Cdr(directory)))
        { var reg2 object subdir = Car(directory);
          #ifdef PATHNAME_EXT83
          if (consp(subdir))
            { # subdir ist ein Cons. name oder type = :WILD ?
              if (eq(Car(subdir),S(Kwild)) || eq(Cdr(subdir),S(Kwild)))
                return TRUE;
            }
            else
            { # subdir ist ein Atom. = :WILD-INFERIORS ?
              if (eq(subdir,S(Kwild_inferiors)))
                return TRUE;
            }
          #endif
          #ifdef PATHNAME_NOEXT
          if (simple_string_p(subdir))
            { if (has_wildcards(subdir)) return TRUE; }
            else
            { if (eq(subdir,S(Kwild_inferiors))) return TRUE; }
          #endif
          #ifdef PATHNAME_RISCOS
          if (simple_string_p(subdir))
            { if (has_wildcards(subdir)) return TRUE; }
          #endif
        }
      return FALSE;
    }}

# UP: Testet, ob die Name-Komponente eines Pathname Wildcards enthält.
# has_name_wildcards(pathname)
# > pathname: Pathname
# < ergebnis: TRUE wenn (PATHNAME-NAME pathname) Wildcards enthält.
  local boolean has_name_wildcards (object pathname);
  local boolean has_name_wildcards(pathname)
    var reg2 object pathname;
    { # Name überprüfen:
      #ifdef LOGICAL_PATHNAMES
      if (logpathnamep(pathname))
        { var reg1 object name = TheLogpathname(pathname)->pathname_name;
          if (simple_string_p(name))
            { if (has_word_wildcards(name)) return TRUE; }
            else
            { if (eq(name,S(Kwild))) return TRUE; }
          return FALSE;
        }
      #endif
      #ifdef PATHNAME_EXT83
      if (eq(ThePathname(pathname)->pathname_name,S(Kwild))) # Name = :WILD ?
        return TRUE;
      #endif
      #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
      { var reg1 object name = ThePathname(pathname)->pathname_name;
        if (simple_string_p(name))
          { if (has_wildcards(name)) return TRUE; }
      }
      #endif
      return FALSE;
    }

# UP: Testet, ob die Type-Komponente eines Pathname Wildcards enthält.
# has_type_wildcards(pathname)
# > pathname: Pathname
# < ergebnis: TRUE wenn (PATHNAME-TYPE pathname) Wildcards enthält.
  local boolean has_type_wildcards (object pathname);
  local boolean has_type_wildcards(pathname)
    var reg2 object pathname;
    { # Typ überprüfen:
      #ifdef LOGICAL_PATHNAMES
      if (logpathnamep(pathname))
        { var reg1 object type = TheLogpathname(pathname)->pathname_type;
          if (simple_string_p(type))
            { if (has_word_wildcards(type)) return TRUE; }
            else
            { if (eq(type,S(Kwild))) return TRUE; }
          return FALSE;
        }
      #endif
      #ifdef PATHNAME_EXT83
      if (eq(ThePathname(pathname)->pathname_type,S(Kwild))) # Typ = :WILD ?
        return TRUE;
      #endif
      #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
      { var reg1 object type = ThePathname(pathname)->pathname_type;
        if (simple_string_p(type))
          { if (has_wildcards(type)) return TRUE; }
      }
      #endif
      return FALSE;
    }

# UP: Testet, ob die Version-Komponente eines Pathname Wildcards enthält.
# has_version_wildcards(pathname)
# > pathname: Pathname
# < ergebnis: TRUE wenn (PATHNAME-VERSION pathname) Wildcards enthält.
  local boolean has_version_wildcards (object pathname);
  local boolean has_version_wildcards(pathname)
    var reg2 object pathname;
    { # Version überprüfen:
      #ifdef LOGICAL_PATHNAMES
      if (logpathnamep(pathname))
        { if (eq(TheLogpathname(pathname)->pathname_version,S(Kwild)))
            return TRUE;
          return FALSE;
        }
      #endif
      return FALSE;
    }

# UP: Testet, ob irgendeine Komponente eines Pathname Wildcards enthält.
# has_some_wildcards(pathname)
# > pathname: Pathname
# < ergebnis: TRUE wenn pathname Wildcards enthält.
  local boolean has_some_wildcards (object pathname);
  local boolean has_some_wildcards(pathname)
    var reg1 object pathname;
    { if (has_host_wildcards(pathname)) return TRUE;
      if (has_device_wildcards(pathname)) return TRUE;
      if (has_directory_wildcards(pathname)) return TRUE;
      if (has_name_wildcards(pathname)) return TRUE;
      if (has_type_wildcards(pathname)) return TRUE;
      if (has_version_wildcards(pathname)) return TRUE;
      return FALSE;
    }

# UP: Überprüft, ob ein Pathname keine Wildcards enthält.
# check_no_wildcards(pathname);
# > pathname: Pathname
  local void check_no_wildcards (object pathname);
  local void check_no_wildcards(pathname)
    var reg2 object pathname;
    { if (!has_some_wildcards(pathname))
        # Keine Wildcards gefunden.
        return;
      # Fehlermeldung, wenn der Pathname Wildcards enthält:
      pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
      pushSTACK(pathname);
      fehler(file_error,
             DEUTSCH ? "Hier sind keine Wildcards (Dateiquantoren) erlaubt: ~" :
             ENGLISH ? "wildcards are not allowed here: ~" :
             FRANCAIS ? "Les caractères joker ne sont pas permis ici : ~" :
             ""
            );
    }

LISPFUN(wild_pathname_p,1,1,norest,nokey,0,NIL)
# (WILD-PATHNAME-P pathname [field-key]), CLtL2 S. 623
  { var reg3 object pathname = coerce_xpathname(STACK_1);
    var reg1 object key = STACK_0;
    var reg2 boolean erg;
    if (eq(key,unbound) || nullp(key)) { erg = has_some_wildcards(pathname); }
    elif (eq(key,S(Khost))) { erg = has_host_wildcards(pathname); }
    elif (eq(key,S(Kdevice))) { erg = has_device_wildcards(pathname); }
    elif (eq(key,S(Kdirectory))) { erg = has_directory_wildcards(pathname); }
    elif (eq(key,S(Kname))) { erg = has_name_wildcards(pathname); }
    elif (eq(key,S(Ktype))) { erg = has_type_wildcards(pathname); }
    elif (eq(key,S(Kversion))) { erg = has_version_wildcards(pathname); }
    else
      { pushSTACK(key); # Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(O(type_pathname_field_key)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(NIL);
        pushSTACK(S(Kversion));
        pushSTACK(S(Ktype));
        pushSTACK(S(Kname));
        pushSTACK(S(Kdirectory));
        pushSTACK(S(Kdevice));
        pushSTACK(S(Khost));
        pushSTACK(key);
        pushSTACK(TheSubr(subr_self)->name);
        fehler(type_error,
               DEUTSCH ? "~: Argument ~ sollte ~, ~, ~, ~, ~, ~ oder ~ sein." :
               ENGLISH ? "~: argument ~ should be ~, ~, ~, ~, ~, ~ or ~" :
               FRANCAIS ? "~ : L'argument ~ devrait être ~, ~, ~, ~, ~, ~ ou ~ ." :
               ""
              );
      }
    value1 = (erg ? T : NIL); mv_count=1; # boolescher Wert
    skipSTACK(2);
  }

#if defined(PATHNAME_NOEXT) || defined(LOGICAL_PATHNAMES)

  # UP: Matcht einen Wildcard-String ("Muster") mit einem "Beispiel".
  # > muster: Simple-String, mit Platzhaltern
  #           '?' für genau 1 Zeichen
  #           '*' für beliebig viele Zeichen
  # > beispiel: Simple-String, der damit zu matchen ist
  local boolean wildcard_match (object muster, object beispiel);
  # rekursive Implementation wegen Backtracking:
  local boolean wildcard_match_ab (uintL m_count, uintB* m_ptr, uintL b_count, uintB* b_ptr);
  local boolean wildcard_match(muster,beispiel)
    var reg2 object muster;
    var reg1 object beispiel;
    { return wildcard_match_ab(
                               /* m_count = */ TheSstring(muster)->length,
                               /* m_ptr   = */ &TheSstring(muster)->data[0],
                               /* b_count = */ TheSstring(beispiel)->length,
                               /* b_ptr   = */ &TheSstring(beispiel)->data[0]
                              );
    }
  local boolean wildcard_match_ab(m_count,m_ptr,b_count,b_ptr)
    var reg5 uintL m_count;
    var reg2 uintB* m_ptr;
    var reg4 uintL b_count;
    var reg1 uintB* b_ptr;
    { var reg3 uintB c;
      loop
        { if (m_count==0)
            { return (b_count==0 ? TRUE : FALSE); } # "" matcht nur ""
          m_count--;
          c = *m_ptr++; # nächstes Match-Zeichen
          if (c=='?') # Wildcard '?'
            { if (b_count==0) return FALSE; # mindestens ein Zeichen muß noch kommen
              b_count--; b_ptr++; # es wird ignoriert
            }
          elif (c=='*') break; # Wildcard '*' später
          else # alles andere muß genau matchen:
            { if (b_count==0) return FALSE;
              b_count--; if (!equal_pathchar(*b_ptr++,c)) return FALSE;
            }
        }
      # Wildcard '*': Suche nächstes non-Wildcard-Zeichen und zähle die '?'
      # mit (denn eine Folge '*??*???***?' matcht alles, was mindestens so
      # lang ist, wie die Folge Fragezeichen enthält). Man kann die '?' auch
      # gleich verwerten, denn '*??*???***?' ist zu '??????*' äquivalent.
      loop
        { if (m_count==0) return TRUE; # Wildcard am Ende matcht den Rest.
          m_count--;
          c = *m_ptr++; # nächstes Match-Zeichen
          if (c=='?') # Fragezeichen: nach vorne ziehen, sofort abarbeiten
            { if (b_count==0) return FALSE;
              b_count--; b_ptr++;
            }
          elif (!(c=='*')) break;
        }
      # c = nächstes non-Wildcard-Zeichen. Suche es.
      loop
        { if (b_count==0) return FALSE; # c nicht gefunden
          b_count--;
          if (equal_pathchar(*b_ptr++,c))
            { if (wildcard_match_ab(m_count,m_ptr,b_count,b_ptr))
                return TRUE;
        }   }
    }

#endif

# UPs: Matcht jeweils eine Pathname-Komponente ("Beispiel") und
# eine Pathname-Komponente ("Muster").
  local boolean host_match (object muster, object beispiel, boolean logical);
  local boolean device_match (object muster, object beispiel, boolean logical);
  local boolean directory_match (object muster, object beispiel, boolean logical);
  local boolean nametype_match (object muster, object beispiel, boolean logical);
  local boolean version_match (object muster, object beispiel, boolean logical);
  local boolean host_match(muster,beispiel,logical)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg3 boolean logical;
    {
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { return equal(muster,beispiel); }
      #endif
      #if HAS_HOST
      return equal(muster,beispiel);
      #else
      return TRUE;
      #endif
    }
  local boolean device_match(muster,beispiel,logical)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg3 boolean logical;
    {
      #if HAS_DEVICE
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { return TRUE; }
      #endif
      #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
      if (eq(muster,S(Kwild))) return TRUE;
      if (eq(beispiel,S(Kwild))) return FALSE;
      #endif
      #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
      return equalp(muster,beispiel);
      #else
      return equal(muster,beispiel);
      #endif
      #else
      return TRUE;
      #endif
    }
  local boolean nametype_match(muster,beispiel,logical)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg3 boolean logical;
    {
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { if (eq(muster,S(Kwild))) return TRUE;
          if (eq(beispiel,S(Kwild))) return FALSE;
          if (nullp(muster))
            { if (nullp(beispiel)) return TRUE; else return FALSE; }
          if (nullp(beispiel))
            { return FALSE; }
          return wildcard_match(muster,beispiel);
        }
      #endif
      #ifdef PATHNAME_EXT83
      if (eq(muster,S(Kwild))) return TRUE;
      if (eq(beispiel,S(Kwild))) return FALSE;
      return equal(muster,beispiel);
      #endif
      #ifdef PATHNAME_NOEXT
      if (nullp(muster))
        { if (nullp(beispiel)) return TRUE; else return FALSE; }
      if (nullp(beispiel))
        { return FALSE; }
      return wildcard_match(muster,beispiel);
      #endif
    }
  local boolean subdir_match(muster,beispiel,logical)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg3 boolean logical;
    { if (eq(muster,beispiel)) return TRUE;
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { if (eq(muster,S(Kwild))) return TRUE;
          if (!simple_string_p(muster) || !simple_string_p(beispiel)) return FALSE;
          return wildcard_match(muster,beispiel);
        }
      #endif
      #ifdef PATHNAME_EXT83
      if (atomp(muster) || atomp(beispiel)) return FALSE;
      return (nametype_match(Car(muster),Car(beispiel),FALSE)
              && nametype_match(Cdr(muster),Cdr(beispiel),FALSE)
             );
      #endif
      #ifdef PATHNAME_NOEXT
      if (!simple_string_p(muster) || !simple_string_p(beispiel)) return FALSE;
      return wildcard_match(muster,beispiel);
      #endif
    }
  # rekursive Implementation wegen Backtracking:
  local boolean directory_match_ab (object m_list, object b_list, boolean logical);
  local boolean directory_match_ab(m_list,b_list,logical)
    var reg2 object m_list;
    var reg1 object b_list;
    var reg4 boolean logical;
    { # Algorithmus analog zu wildcard_match_ab.
      var reg3 object item;
      loop
        { if (atomp(m_list)) { return atomp(b_list); }
          item = Car(m_list); m_list = Cdr(m_list);
          if (eq(item,S(Kwild_inferiors))) break;
          if (atomp(b_list)) return FALSE;
          if (!subdir_match(item,Car(b_list),logical)) return FALSE;
          b_list = Cdr(b_list);
        }
      loop
        { if (atomp(m_list)) return TRUE;
          item = Car(m_list); m_list = Cdr(m_list);
          if (!eq(item,S(Kwild_inferiors))) break;
        }
      loop
        { if (atomp(b_list)) return FALSE;
          if (subdir_match(item,Car(b_list),logical))
            { b_list = Cdr(b_list);
              if (directory_match_ab(m_list,b_list,logical)) return TRUE;
            }
            else
            { b_list = Cdr(b_list); }
        }
    }
  local boolean directory_match(muster,beispiel,logical)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg3 boolean logical;
    {
      #ifdef LOGICAL_PATHNAMES
      if (!logical)
      #endif
        {
          #if HAS_SERNR
          # Seriennummer matchen:
          if (!(nullp(Car(muster)) || eql(Car(muster),Car(beispiel))))
            return FALSE;
          muster = Cdr(muster); beispiel = Cdr(beispiel);
          #endif
        }
      # Startpoint matchen:
      if (!eq(Car(muster),Car(beispiel)))
        return FALSE;
      muster = Cdr(muster); beispiel = Cdr(beispiel);
      # subdirs matchen:
      return directory_match_ab(muster,beispiel,logical);
    }
  local boolean version_match(muster,beispiel,logical)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg3 boolean logical;
    {
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { if (eq(muster,S(Kwild))) return TRUE;
          return eql(muster,beispiel);
        }
      #endif
      #if HAS_VERSION
      if (eq(muster,S(Kwild))) return TRUE;
      if (eq(beispiel,S(Kwild))) return FALSE;
      if (eql(muster,beispiel)) return TRUE;
      return FALSE;
      #else
      return TRUE;
      #endif
    }

LISPFUNN(pathname_match_p,2)
# (PATHNAME-MATCH-P pathname wildname), CLtL2 S. 623
  { # Stackaufbau: pathname, wildname.
    var reg3 boolean logical = FALSE;
    STACK_1 = coerce_xpathname(STACK_1);
    STACK_0 = coerce_xpathname(STACK_0);
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(STACK_1) && logpathnamep(STACK_0))
      { logical = TRUE; }
      else
      # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
      { STACK_1 = coerce_pathname(STACK_1);
        STACK_0 = coerce_pathname(STACK_0);
      }
    #endif
   {var reg2 object wildname = popSTACK();
    var reg1 object pathname = popSTACK();
    if (!host_match(xpathname_host(logical,wildname),
                    xpathname_host(logical,pathname),
                    logical
       )           )
      goto no;
    if (!device_match(xpathname_device(logical,wildname),
                      xpathname_device(logical,pathname),
                      logical
       )             )
      goto no;
    if (!directory_match(xpathname_directory(logical,wildname),
                         xpathname_directory(logical,pathname),
                         logical
       )                )
      goto no;
    if (!nametype_match(xpathname_name(logical,wildname),
                        xpathname_name(logical,pathname),
                        logical
       )               )
      goto no;
    if (!nametype_match(xpathname_type(logical,wildname),
                        xpathname_type(logical,pathname),
                        logical
       )               )
      goto no;
    if (!version_match(xpathname_version(logical,wildname),
                       xpathname_version(logical,pathname),
                       logical
       )              )
      goto no;
    yes: value1 = T; mv_count=1; return;
    no: value1 = NIL; mv_count=1; return;
  }}

# (TRANSLATE-PATHNAME beispiel muster1 muster2) machen wir folgendermaßen:
# 1. (PATHNAME-MATCH-P beispiel muster1) nachrechnen, dabei aber die
#    Substitution aufheben, in Form von Textstücken (:WILD -> "*").
# 2. In muster2 die Textstücke einsetzen, bis muster2 voll ist oder die
#    Textstücke aufgebraucht sind.
# 3. Zum Schluß (MERGE-PATHNAMES modifiziertes_muster2 beispiel).

  # UP: Vergleicht einen Wildcard-String ("Muster") mit einem "Beispiel".
  # wildcard_diff(muster,beispiel,previous,solutions);
  # > muster: Simple-String, mit Platzhaltern
  #           '?' für genau 1 Zeichen
  #           '*' für beliebig viele Zeichen
  # > beispiel: Simple-String, der damit zu vergleichen ist
  # > previous: bisher bekanntes Vergleichsergebnis
  #             (umgedrehte Liste von Simple-Strings und Listen)
  # > solutions: Pointer auf eine Liste im STACK, auf die die
  #              Vergleichsergebnisse (umgedrehte Liste von Simple-Strings und
  #              Listen) zu consen sind
  # kann GC auslösen

  # Hier wünscht man sich nicht Lisp oder C, sondern PROLOG als Sprache!

  #define push_solution()  \
    { var reg1 object new_cons = allocate_cons(); \
      Car(new_cons) = *previous;                  \
      Cdr(new_cons) = *solutions;                 \
      *solutions = new_cons;                      \
    }
  #define push_solution_with(new_piece)  \
    { pushSTACK(new_piece);                                   \
     {var reg1 object new_cons = allocate_cons();             \
      Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;     \
      STACK_0 = new_cons;                                     \
      new_cons = allocate_cons();                             \
      Car(new_cons) = popSTACK(); Cdr(new_cons) = *solutions; \
      *solutions = new_cons;                                  \
    }}

#if defined(PATHNAME_NOEXT) || defined(LOGICAL_PATHNAMES)

  local void wildcard_diff (object muster, object beispiel, object* previous, object* solutions);

  # rekursive Implementation wegen Backtracking:
  local void wildcard_diff_ab (object muster, object beispiel, uintL m_index, uintL b_index, object* previous, object* solutions);

  local void wildcard_diff(muster,beispiel,previous,solutions)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg4 object* previous;
    var reg3 object* solutions;
    { wildcard_diff_ab(muster,beispiel,0,0,previous,solutions); }

  local void wildcard_diff_ab(muster,beispiel,m_index,b_index,previous,solutions)
    var reg3 object muster;
    var reg2 object beispiel;
    var reg6 uintL m_index;
    var reg5 uintL b_index;
    var reg8 object* previous;
    var reg7 object* solutions;
    { var reg4 uintB c;
      loop
        { if (m_index == TheSstring(muster)->length)
            { if (b_index == TheSstring(beispiel)->length)
                { push_solution(); }
              return;
            }
          c = TheSstring(muster)->data[m_index++];
          if (c=='*') break;
          if (b_index == TheSstring(beispiel)->length) return;
          if (c=='?')
            { # wildcard_diff_ab() rekursiv aufrufen, mit erweitertem previous:
              c = TheSstring(beispiel)->data[b_index++];
              pushSTACK(muster); pushSTACK(beispiel);
              { var reg1 object new_string = allocate_string(1);
                TheSstring(new_string)->data[0] = c;
                pushSTACK(new_string);
              }
              { var reg1 object new_cons = allocate_cons();
                Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
                STACK_0 = new_cons; # (CONS ... previous)
              }
              wildcard_diff_ab(STACK_2,STACK_1,m_index,b_index,&STACK_0,solutions);
              skipSTACK(3);
              return;
            }
            else
            { if (!equal_pathchar(TheSstring(beispiel)->data[b_index++],c))
                return;
            }
        }
     {var reg9 uintL b_start_index = b_index;
      loop
        { # Um weniger zu consen, die Fälle abfangen, wo wildcard_diff_ab()
          # gar nichts tut:
          if (m_index == TheSstring(muster)->length
              ? b_index == TheSstring(beispiel)->length
              : (c = TheSstring(muster)->data[m_index],
                 (c=='*') || (c=='?')
                 || (b_index < TheSstring(beispiel)->length
                     && equal_pathchar(TheSstring(beispiel)->data[b_index],c)
             )  )   )
            # wildcard_diff_ab() rekursiv aufrufen, mit erweitertem previous:
            { pushSTACK(muster); pushSTACK(beispiel);
              pushSTACK(beispiel); pushSTACK(fixnum(b_start_index)); pushSTACK(fixnum(b_index));
              funcall(L(substring),3); # (SUBSTRING beispiel b_start_index b_index)
              pushSTACK(value1);
             {var reg1 object new_cons = allocate_cons();
              Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
              STACK_0 = new_cons; # (CONS ... previous)
              wildcard_diff_ab(STACK_2,STACK_1,m_index,b_index,&STACK_0,solutions);
              skipSTACK(1);
              beispiel = popSTACK(); muster = popSTACK();
            }}
          if (b_index == TheSstring(beispiel)->length)
            break;
          b_index++;
        }
    }}

#endif

# UPs: Vergleicht jeweils eine Pathname-Komponente ("Beispiel") und
# eine Pathname-Komponente ("Muster").
# kann GC auslösen
  local void host_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  local void device_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  local void directory_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  local void nametype_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  local void version_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  local void host_diff(muster,beispiel,logical,previous,solutions)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg5 boolean logical;
    var reg4 object* previous;
    var reg3 object* solutions;
    {
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { if (!equal(muster,beispiel)) return; }
        else
      #endif
        {
          #if HAS_HOST
          if (!equal(muster,beispiel)) return;
          #endif
        }
      push_solution();
    }
  local void device_diff(muster,beispiel,logical,previous,solutions)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg5 boolean logical;
    var reg4 object* previous;
    var reg3 object* solutions;
    {
      #if HAS_DEVICE
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { push_solution(); return; }
      #endif
      #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
      if (eq(muster,S(Kwild)))
        { var reg1 object string =
            (eq(beispiel,S(Kwild)) ? O(wild_string) :
             simple_string_p(beispiel) ? beispiel : O(leer_string)
            );
          push_solution_with(string);
          return;
        }
      if (eq(beispiel,S(Kwild))) return;
      #endif
      #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
      if (!equalp(muster,beispiel)) return;
      #else
      if (!equal(muster,beispiel)) return;
      #endif
      #endif
      push_solution();
    }
  local void nametype_diff(muster,beispiel,logical,previous,solutions)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg5 boolean logical;
    var reg4 object* previous;
    var reg3 object* solutions;
    {
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { if (eq(muster,S(Kwild)))
            { var reg1 object string =
                (eq(beispiel,S(Kwild)) ? O(wild_string) :
                 simple_string_p(beispiel) ? beispiel : O(leer_string)
                );
              push_solution_with(string);
              return;
            }
          if (eq(beispiel,S(Kwild))) return;
          if (nullp(muster))
            { if (nullp(beispiel))
                { push_solution(); }
              return;
            }
          if (nullp(beispiel))
            return;
          wildcard_diff(muster,beispiel,previous,solutions);
          return;
        }
      #endif
      #ifdef PATHNAME_EXT83
      if (eq(muster,S(Kwild)))
        { var reg1 object string =
            (eq(beispiel,S(Kwild)) ? O(wild_string) :
             simple_string_p(beispiel) ? beispiel : O(leer_string)
            );
          push_solution_with(string);
          return;
        }
      if (eq(beispiel,S(Kwild))) return;
      if (!equal(muster,beispiel)) return;
      push_solution();
      #endif
      #ifdef PATHNAME_NOEXT
      if (nullp(muster))
        { if (nullp(beispiel))
            { push_solution(); }
          return;
        }
      if (nullp(beispiel))
        return;
      wildcard_diff(muster,beispiel,previous,solutions);
      #endif
    }
  local void subdir_diff(muster,beispiel,logical,previous,solutions)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg5 boolean logical;
    var reg4 object* previous;
    var reg3 object* solutions;
    { if (eq(muster,beispiel))
        { if (eq(beispiel,S(Kwild)))
            { push_solution_with(O(wild_string)); }
            else
            { push_solution(); }
          return;
        }
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { if (eq(muster,S(Kwild)))
            { var reg1 object string =
                (eq(beispiel,S(Kwild)) ? O(wild_string) :
                 simple_string_p(beispiel) ? beispiel : O(leer_string)
                );
              push_solution_with(string);
              return;
            }
          if (eq(beispiel,S(Kwild))) return;
          if (!simple_string_p(muster) || !simple_string_p(beispiel)) return;
          wildcard_diff(muster,beispiel,previous,solutions);
          return;
        }
      #endif
      #ifdef PATHNAME_EXT83
      if (atomp(muster) || atomp(beispiel)) return;
      pushSTACK(NIL); pushSTACK(Cdr(muster)); pushSTACK(Cdr(beispiel));
      nametype_diff(Car(muster),Car(beispiel),FALSE,previous,&STACK_2);
      while (mconsp(STACK_2))
        { pushSTACK(Car(STACK_2));
          nametype_diff(STACK_(1+1),STACK_(0+1),FALSE,&STACK_0,solutions);
          skipSTACK(1);
          STACK_2 = Cdr(STACK_2);
        }
      skipSTACK(3);
      #endif
      #ifdef PATHNAME_NOEXT
      if (!simple_string_p(muster) || !simple_string_p(beispiel)) return;
      wildcard_diff(muster,beispiel,previous,solutions);
      #endif
    }
  # rekursive Implementation wegen Backtracking:
  local void directory_diff_ab (object m_list, object b_list, boolean logical, object* previous, object* solutions);
  local void directory_diff_ab(m_list,b_list,logical,previous,solutions)
    var reg3 object m_list;
    var reg2 object b_list;
    var reg8 boolean logical;
    var reg6 object* previous;
    var reg7 object* solutions;
    { # Algorithmus analog zu wildcard_diff_ab.
      var reg4 object item;
      if (atomp(m_list))
        { if (atomp(b_list))
            { push_solution(); }
          return;
        }
      item = Car(m_list); m_list = Cdr(m_list);
      if (!eq(item,S(Kwild_inferiors)))
        { if (atomp(b_list)) return;
          pushSTACK(NIL); pushSTACK(m_list); pushSTACK(Cdr(b_list));
          subdir_diff(item,Car(b_list),logical,previous,&STACK_2);
          # directory_diff_ab() rekursiv aufrufen, mit erweitertem previous:
          while (mconsp(STACK_2))
            { pushSTACK(Car(STACK_2));
              directory_diff_ab(STACK_(1+1),STACK_(0+1),logical,&STACK_0,solutions);
              skipSTACK(1);
              STACK_2 = Cdr(STACK_2);
            }
          skipSTACK(3);
        }
        else
        { pushSTACK(b_list); # b_start_list := b_list
          loop
            { # Um weniger zu consen, die Fälle abfangen, wo directory_diff_ab()
              # gar nichts tut:
              if (atomp(m_list)
                  ? atomp(b_list)
                  : (eq(Car(m_list),S(Kwild_inferiors)) || !atomp(b_list))
                 )
                # directory_diff_ab() rekursiv aufrufen, mit erweitertem previous:
                { pushSTACK(m_list); pushSTACK(b_list);
                  pushSTACK(STACK_2); pushSTACK(b_list);
                  funcall(L(ldiff),2); # (LDIFF b_start_list b_list)
                  pushSTACK(value1);
                 {var reg1 object new_cons = allocate_cons();
                  Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
                  STACK_0 = new_cons; # (CONS ... previous)
                  directory_diff_ab(STACK_2,STACK_1,logical,&STACK_0,solutions);
                  skipSTACK(1);
                  b_list = popSTACK(); m_list = popSTACK();
                }}
              if (atomp(b_list)) break;
              b_list = Cdr(b_list);
            }
          skipSTACK(1);
        }
    }
  local void directory_diff(muster,beispiel,logical,previous,solutions)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg5 boolean logical;
    var reg4 object* previous;
    var reg3 object* solutions;
    {
      #ifdef LOGICAL_PATHNAMES
      if (!logical)
      #endif
        {
          #if HAS_SERNR
          # Seriennummer vergleichen:
          if (!(nullp(Car(muster)) || eql(Car(muster),Car(beispiel))))
            return;
          muster = Cdr(muster); beispiel = Cdr(beispiel);
          #endif
        }
      # Startpoint vergleichen:
      if (!eq(Car(muster),Car(beispiel)))
        return;
      muster = Cdr(muster); beispiel = Cdr(beispiel);
      # subdirs vergleichen:
      directory_diff_ab(muster,beispiel,logical,previous,solutions);
    }
  local void version_diff(muster,beispiel,logical,previous,solutions)
    var reg2 object muster;
    var reg1 object beispiel;
    var reg5 boolean logical;
    var reg4 object* previous;
    var reg3 object* solutions;
    {
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { if (eq(muster,S(Kwild)))
            { var reg1 object string =
                (eq(beispiel,S(Kwild)) ? O(wild_string) :
                 integerp(beispiel) ? (pushSTACK(beispiel), C_decimal_string(), value1) : # (SYS::DECIMAL-STRING beispiel)
                 O(leer_string)
                );
              push_solution_with(string);
              return;
            }
          if (eq(beispiel,S(Kwild))) return;
          if (!eql(muster,beispiel)) return;
          push_solution();
          return;
        }
      #endif
      #if HAS_VERSION
      if (eq(muster,S(Kwild)))
        { var reg1 object string =
            (eq(beispiel,S(Kwild)) ? O(wild_string) :
             integerp(beispiel) ? (pushSTACK(beispiel), C_decimal_string(), value1) : # (SYS::DECIMAL-STRING beispiel)
             O(leer_string)
            );
          push_solution_with(string);
          return;
        }
      if (eq(beispiel,S(Kwild))) return;
      if (!eql(muster,beispiel)) return;
      #endif
      push_solution();
    }

  #undef push_solution_with
  #undef push_solution

# Jede Substitution ist eine Liste von Simple-Strings oder Listen.
# (Die Listen entstehen bei :WILD-INFERIORS in directory_diff().)
# Ein Simple-String paßt nur auf '?' oder '*' oder :WILD,
# eine Liste paßt nur auf :WILD-INFERIORS.

#ifdef LOGICAL_PATHNAMES

# Beim Einsetzen von Stücken normaler Pathnames in logische Pathnames:
# Umwandlung in Großbuchstaben.
# logical_case(string)
# > string: Simple-String oder Symbol/Zahl
# < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
# kann GC auslösen
  local object logical_case (object string);
# Dasselbe, rekursiv wie mit SUBST:
  local object subst_logical_case (object obj);
#if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  # sowieso schon alles Großbuchstaben
  #define logical_case(string)  string
  #define subst_logical_case(obj)  obj
#else
  local object logical_case(string)
    var reg1 object string;
    { if (!simple_string_p(string))
        return string;
      return string_upcase(string);
    }
  local object subst_logical_case(obj)
    var reg1 object obj;
    { if (atomp(obj))
        { return logical_case(obj); }
      check_STACK(); check_SP();
      pushSTACK(obj);
      # rekursiv für den CAR aufrufen:
      { var reg2 object new_car = subst_logical_case(Car(obj));
        pushSTACK(new_car);
      }
      # rekursiv für den CDR aufrufen:
      { var reg2 object new_cdr = subst_logical_case(Cdr(STACK_1));
        if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
          { obj = STACK_1; skipSTACK(2); return obj; }
          else
          # (CONS new_car new_cdr)
          { STACK_1 = new_cdr;
           {var reg1 object new_cons = allocate_cons();
            Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
            return new_cons;
    } }   }}
#endif

# Beim Einsetzen von Stücken logischer Pathnames in normale Pathnames:
# Umwandlung in Großbuchstaben.
# logical_case(string)
# > string: Simple-String oder Symbol/Zahl
# < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
# kann GC auslösen
  local object customary_case (object string);
# Dasselbe, rekursiv wie mit SUBST:
  local object subst_customary_case (object obj);
#if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  # Betriebssystem mit Vorzug für Großbuchstaben
  #define customary_case(string)  string
  #define subst_customary_case(obj)  obj
#else
  local object customary_case(string)
    var reg1 object string;
    { if (!simple_string_p(string))
        return string;
      #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS)
      # Betriebssystem mit Vorzug für Kleinbuchstaben
      return string_downcase(string);
      #endif
      #ifdef PATHNAME_AMIGAOS
      # Betriebssystem mit Vorzug für Capitalize
      string = copy_string(string);
      nstring_capitalize(&TheSstring(string)->data[0],TheSstring(string)->length);
      return string;
      #endif
    }
  local object subst_customary_case(obj)
    var reg1 object obj;
    { if (atomp(obj))
        { return customary_case(obj); }
      check_STACK(); check_SP();
      pushSTACK(obj);
      # rekursiv für den CAR aufrufen:
      { var reg2 object new_car = subst_customary_case(Car(obj));
        pushSTACK(new_car);
      }
      # rekursiv für den CDR aufrufen:
      { var reg2 object new_cdr = subst_customary_case(Cdr(STACK_1));
        if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
          { obj = STACK_1; skipSTACK(2); return obj; }
          else
          # (CONS new_car new_cdr)
          { STACK_1 = new_cdr;
           {var reg1 object new_cons = allocate_cons();
            Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
            return new_cons;
    } }   }}
#endif

#endif

# UP: Eine Substitution auf ein Muster anwenden.
# translate_pathname(&subst,muster)
  local object translate_pathname (object* subst, object muster);
# translate_host(&subst,muster,logical) etc. liefert den host etc. mit Ersetzungen
# und verkürzen subst passend. Falls nicht passend, liefert es nullobj.
  local object translate_host (object* subst, object muster, boolean logical);
  local object translate_device (object* subst, object muster, boolean logical);
  local object translate_subdir (object* subst, object muster, boolean logical);
  local object translate_directory (object* subst, object muster, boolean logical);
  local object translate_nametype (object* subst, object muster, boolean logical);
  local object translate_version (object* subst, object muster, boolean logical);
  #define translate_host(subst,muster,logical)  (muster)
  local object translate_device(subst,muster,logical)
    var reg1 object* subst;
    var reg2 object muster;
    var reg4 boolean logical;
    {
      #if HAS_DEVICE
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { return muster; }
      #endif
      if (eq(muster,S(Kwild)) && mconsp(*subst))
        { if (m_simple_string_p(Car(*subst)))
            { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
              return erg;
            }
            else
            return nullobj;
        }
      #endif
      return muster;
    }
  local object translate_nametype(subst,muster,logical)
    var reg6 object* subst;
    var reg3 object muster;
    var reg7 boolean logical;
    { if (eq(muster,S(Kwild)) && mconsp(*subst))
        { if (m_simple_string_p(Car(*subst)))
            { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
              return erg;
            }
            else
            return nullobj;
        }
      if (simple_string_p(muster))
        { pushSTACK(muster); # muster retten
         {var reg5 object* muster_ = &STACK_0;
          var reg4 uintL len = TheSstring(muster)->length;
          var reg1 uintL index = 0;
          var reg7 uintL stringcount = 0; # Anzahl der Strings auf dem Stack
          loop
            { var reg9 uintL last_index = index;
              var reg2 uintB c;
              # Suche nächstes Wildcard-Zeichen:
              muster = *muster_;
              loop
                { if (index == len) break;
                  c = TheSstring(muster)->data[index];
                  if (((c=='*') # Wildcard für beliebig viele Zeichen
                       || (!logical && singlewild_char_p(c)) # Wildcard für genau ein Zeichen
                      )
                      && mconsp(*subst)
                     )
                    break;
                  index++;
                }
              # Nächsten Teilstring auf den Stack:
              pushSTACK(muster); pushSTACK(fixnum(last_index)); pushSTACK(fixnum(index));
              funcall(L(substring),3); # (SUBSTRING muster last_index index)
              pushSTACK(value1); stringcount++;
              # Fertig?
              if (index == len) break;
              # Wildcard ersetzen:
              if (m_simple_string_p(Car(*subst)))
                { pushSTACK(Car(*subst)); *subst = Cdr(*subst); stringcount++; }
                else
                { skipSTACK(stringcount+1); return nullobj; }
              index++;
            }
          funcall(L(string_concat),stringcount); # (STRING-CONCAT alle Strings)
          skipSTACK(1);
          return value1;
        }}
      return muster;
    }
  local object translate_subdir(subst,muster,logical)
    var reg3 object* subst;
    var reg2 object muster;
    var reg4 boolean logical;
    {
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { return translate_nametype(subst,muster,logical); }
      #endif
      #ifdef PATHNAME_EXT83
      if (atomp(muster)) return muster;
      pushSTACK(Car(muster)); pushSTACK(Cdr(muster));
      if (eq(STACK_1 = translate_nametype(subst,STACK_1,FALSE),nullobj)
          || eq(STACK_0 = translate_nametype(subst,STACK_0,FALSE),nullobj)
         )
        { skipSTACK(2); return nullobj; }
      {var reg1 object new_cons = allocate_cons();
       Car(new_cons) = STACK_1; Cdr(new_cons) = STACK_0; skipSTACK(2);
       return new_cons;
      }
      #endif
      #ifdef PATHNAME_NOEXT
      return translate_nametype(subst,muster,FALSE);
      #endif
    }
  local object translate_directory(subst,muster,logical)
    var reg2 object* subst;
    var reg4 object muster;
    var reg6 boolean logical;
    { var reg5 uintL itemcount = 0; # Anzahl der Elemente auf dem Stack
      #ifdef LOGICAL_PATHNAMES
      if (!logical)
      #endif
        {
          #if HAS_SERNR
          # Seriennummer:
          pushSTACK(Car(muster)); muster = Cdr(muster); itemcount++;
          #endif
        }
      # Startpoint:
      pushSTACK(Car(muster)); muster = Cdr(muster); itemcount++;
      # subdirs:
      while (consp(muster))
        { var reg3 object item = Car(muster);
          muster = Cdr(muster);
          if (eq(item,S(Kwild_inferiors)))
            { if (mconsp(*subst))
                { if (listp(Car(*subst)))
                    { var reg1 object list = Car(*subst); *subst = Cdr(*subst);
                      while (consp(list))
                        { pushSTACK(Car(list)); list = Cdr(list); itemcount++; }
                    }
                    else
                    { skipSTACK(itemcount); return nullobj; }
                }
                else
                { pushSTACK(item); itemcount++; }
            }
            else
            { pushSTACK(muster); # muster retten
              item = translate_subdir(subst,item,logical);
              if (eq(item,nullobj)) { skipSTACK(itemcount+1); return nullobj; }
              muster = STACK_0; STACK_0 = item; itemcount++;
            }
        }
      return listof(itemcount);
    }
  local object translate_version(subst,muster,logical)
    var reg1 object* subst;
    var reg2 object muster;
    var reg4 boolean logical;
    {
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        { if (eq(muster,S(Kwild)) && mconsp(*subst))
            { if (m_simple_string_p(Car(*subst)))
                { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
                  pushSTACK(erg); funcall(L(parse_integer),1);
                  return value1;
                }
                else
                return nullobj;
            }
          return muster;
        }
      #endif
      #if HAS_VERSION
      if (eq(muster,S(Kwild)) && mconsp(*subst))
        { if (m_simple_string_p(Car(*subst)))
            { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
              pushSTACK(erg); funcall(L(parse_integer),1);
              return value1;
            }
            else
            return nullobj;
        }
      #endif
      return muster;
    }
  local object translate_pathname(subst,muster)
    var reg2 object* subst;
    var reg3 object muster;
    { var reg4 boolean logical = FALSE;
      var reg1 object item;
      pushSTACK(*subst); # subst retten für Fehlermeldung
      pushSTACK(muster);
      #ifdef LOGICAL_PATHNAMES
      if (logpathnamep(muster)) { logical = TRUE; }
      #endif
      # Argumente für MAKE-PATHNAME zusammenbauen:
      #if 1 # HAS_HOST || defined(LOGICAL_PATHNAMES)
      item = translate_host(subst,xpathname_host(logical,muster),logical);
      if (eq(item,nullobj)) { goto error; }
      pushSTACK(S(Khost)); pushSTACK(item);
      #endif
      #if HAS_DEVICE
      item = translate_device(subst,xpathname_device(logical,STACK_2),logical);
      if (eq(item,nullobj)) { skipSTACK(2); goto error; }
      pushSTACK(S(Kdevice)); pushSTACK(item);
      #endif
      item = translate_directory(subst,xpathname_directory(logical,STACK_(2+2*HAS_DEVICE)),logical);
      if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE); goto error; }
      pushSTACK(S(Kdirectory)); pushSTACK(item);
      item = translate_nametype(subst,xpathname_name(logical,STACK_(2+2*HAS_DEVICE+2)),logical);
      if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+2); goto error; }
      pushSTACK(S(Kname)); pushSTACK(item);
      item = translate_nametype(subst,xpathname_type(logical,STACK_(2+2*HAS_DEVICE+4)),logical);
      if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+4); goto error; }
      pushSTACK(S(Ktype)); pushSTACK(item);
      #if 1 # HAS_VERSION || defined(LOGICAL_PATHNAMES)
      item = translate_version(subst,xpathname_version(logical,STACK_(2+2*HAS_DEVICE+6)),logical);
      if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+6); goto error; }
      pushSTACK(S(Kversion)); pushSTACK(item);
      #endif
      # Alle Ersetzungsstücke müssen verbraucht werden!
      if (mconsp(*subst)) { skipSTACK(2+2*HAS_DEVICE+8); goto error; }
      # (MAKE-PATHNAME ...) bzw. (SYS::MAKE-LOGICAL-PATHNAME ...) aufrufen:
      #ifdef LOGICAL_PATHNAMES
      if (logical)
        funcall(L(make_logical_pathname),2+2*HAS_DEVICE+8);
        else
      #endif
        funcall(L(make_pathname),2+2*HAS_DEVICE+8);
      skipSTACK(2);
      return value1;
     error: # Error wegen nullobj.
      # Stackaufbau: subst, muster.
      pushSTACK(STACK_1);
      pushSTACK(S(translate_pathname));
      fehler(error,
             DEUTSCH ? "~: Ersetzungsstücke ~ passen nicht in ~." :
             ENGLISH ? "~: replacement pieces ~ do not fit into ~" :
             FRANCAIS ? "~ : Les pièces ~ ne vont pas dans ~." :
             ""
            );
    }

LISPFUN(translate_pathname,3,0,norest,key,2, (kw(all),kw(merge)))
# (TRANSLATE-PATHNAME beispiel muster1 muster2 [:all] [:merge]), CLtL2 S. 624
# :all = T --> liefere eine Liste aller passenden Pathnames
# :all = NIL --> Error, falls mehr als ein Pathname paßt
# :merge = NIL --> letzten MERGE-PATHNAMES Schritt überspringen
  { # Stackaufbau: beispiel, muster1, muster2, all, merge.
    var reg3 boolean logical = FALSE; # Flag, ob beispiel und muster logische Pathnames sind
    var reg4 boolean logical2 = FALSE; # Flag, ob muster2 ein logischer Pathname ist
    STACK_4 = coerce_xpathname(STACK_4);
    STACK_3 = coerce_xpathname(STACK_3);
    STACK_2 = coerce_xpathname(STACK_2);
    #ifdef LOGICAL_PATHNAMES
    if (logpathnamep(STACK_4) && logpathnamep(STACK_3))
      { logical = TRUE; }
      else
      # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
      { STACK_4 = coerce_pathname(STACK_4);
        STACK_3 = coerce_pathname(STACK_3);
      }
    if (logpathnamep(STACK_2))
      { logical2 = TRUE; }
    #endif
    # 1. Schritt: Liste aller passenden Substitutionen bilden.
    pushSTACK(NIL); pushSTACK(NIL);
    host_diff(xpathname_host(logical,STACK_(3+2)),xpathname_host(logical,STACK_(4+2)),logical,&STACK_1,&STACK_0);
    while (mconsp(STACK_0))
      { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
        device_diff(xpathname_device(logical,STACK_(3+4)),xpathname_device(logical,STACK_(4+4)),logical,&STACK_1,&STACK_0);
        while (mconsp(STACK_0))
          { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
            directory_diff(xpathname_directory(logical,STACK_(3+6)),xpathname_directory(logical,STACK_(4+6)),logical,&STACK_1,&STACK_0);
            while (mconsp(STACK_0))
              { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
                nametype_diff(xpathname_name(logical,STACK_(3+8)),xpathname_name(logical,STACK_(4+8)),logical,&STACK_1,&STACK_0);
                while (mconsp(STACK_0))
                  { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
                    nametype_diff(xpathname_type(logical,STACK_(3+10)),xpathname_type(logical,STACK_(4+10)),logical,&STACK_1,&STACK_0);
                    while (mconsp(STACK_0))
                      { pushSTACK(Car(STACK_0));
                        version_diff(xpathname_version(logical,STACK_(3+11)),xpathname_version(logical,STACK_(4+11)),logical,&STACK_0,&STACK_10);
                        skipSTACK(1);
                        STACK_0 = Cdr(STACK_0);
                      }
                    skipSTACK(2);
                    STACK_0 = Cdr(STACK_0);
                  }
                skipSTACK(2);
                STACK_0 = Cdr(STACK_0);
              }
            skipSTACK(2);
            STACK_0 = Cdr(STACK_0);
          }
        skipSTACK(2);
        STACK_0 = Cdr(STACK_0);
      }
    skipSTACK(1);
    # Stackaufbau: ..., solutions.
    if (matomp(STACK_0))
      { pushSTACK(STACK_(3+1));
        pushSTACK(STACK_(4+1+1));
        pushSTACK(S(translate_pathname));
        fehler(error,
               DEUTSCH ? "~: ~ ist keine Spezialisierung von ~." :
               ENGLISH ? "~: ~ is not a specialization of ~" :
               FRANCAIS ? "~ : ~ ne spécialise pas ~." :
               ""
              );
      }
    # 2.,3. Schritt:
    pushSTACK(NIL); # pathnames := '()
    while (mconsp(STACK_1)) # solutions durchgehen
      { var reg1 object solutions = STACK_1;
        STACK_1 = Cdr(solutions);
       {var reg2 object solution = reverse(Car(solutions)); # Liste solution umdrehen
        # 2. Schritt: Substitution in muster2 einfügen.
        #ifdef LOGICAL_PATHNAMES
        # Groß-/Kleinschreibung passend konvertieren:
        if (!logical)
          { if (logical2)
              { solution = subst_logical_case(solution); }
          }
          else
          { if (!logical2)
              { solution = subst_customary_case(solution); }
          }
        #endif
        pushSTACK(solution);
        STACK_0 = translate_pathname(&STACK_0,STACK_(2+1+2));
       }
        # 3. Schritt: (MERGE-PATHNAMES modifiziertes_muster2 beispiel :WILD T)
        if (!nullp(STACK_(0+1+2))) # :MERGE-Argument abfragen
          if (has_some_wildcards(STACK_0)) # evtl. ist MERGE-PATHNAMES unnötig
            { pushSTACK(STACK_(4+1+2)); pushSTACK(unbound);
              pushSTACK(S(Kwild)); pushSTACK(T);
              funcall(L(merge_pathnames),5);
              pushSTACK(value1);
            }
        # (PUSH pathname pathnames)
       {var reg1 object new_cons = allocate_cons();
        Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
        STACK_0 = new_cons;
      }}
    # 4. Schritt: (DELETE-DUPLICATES pathnames :TEST #'EQUAL)
    pushSTACK(S(Ktest)); pushSTACK(L(equal));
    funcall(L(delete_duplicates),3);
    # Stackaufbau: ..., nil.
    if (eq(STACK_(1+1),unbound) || nullp(STACK_(1+1))) # :ALL-Argument abfragen
      { if (mconsp(Cdr(value1)))
          { pushSTACK(value1);
            pushSTACK(STACK_(2+2));
            pushSTACK(STACK_(3+3));
            pushSTACK(STACK_(4+4));
            pushSTACK(S(translate_pathname));
            fehler(error,
                   DEUTSCH ? "(~ ~ ~ ~) ist nicht eindeutig: ~" :
                   ENGLISH ? "(~ ~ ~ ~) is ambiguous: ~" :
                   FRANCAIS ? "(~ ~ ~ ~) est ambigu: ~" :
                   ""
                  );
          }
        value1 = Car(value1);
      }
    mv_count=1;
    skipSTACK(5+1);
  }

# UP: Stellt fest, ob der Name eines Pathname =NIL ist.
# namenullp(pathname)
# > pathname: nicht-Logical Pathname
  # local boolean namenullp (object pathname);
  # local boolean namenullp(pathname)
  #   { return nullp(ThePathname(pathname)->pathname_name); }
  #define namenullp(path)  (nullp(ThePathname(path)->pathname_name))

# Fehler, wenn ein Directory nicht existiert
# > obj: Pathname oder (besser) fehlerhafte Komponente
  nonreturning_function(local, fehler_dir_not_exists, (object obj));
  local void fehler_dir_not_exists(obj)
    var reg1 object obj;
    { pushSTACK(obj); # Wert für Slot PATHNAME von FILE-ERROR
      pushSTACK(obj);
      fehler(file_error,
             DEUTSCH ? "Directory existiert nicht: ~" :
             ENGLISH ? "nonexistent directory: ~" :
             FRANCAIS ? "Le répertoire ~ n'existe pas." :
             ""
            );
    }

# Fehler, wenn eine Datei bereits existiert
# > caller: Aufrufer (ein Symbol)
# > pathname: Pathname
  nonreturning_function(local, fehler_file_exists, (object caller, object pathname));
  local void fehler_file_exists(caller,pathname)
    var reg2 object caller;
    var reg1 object pathname;
    { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
      pushSTACK(pathname);
      pushSTACK(caller);
      fehler(file_error,
             DEUTSCH ? "~: Eine Datei ~ existiert bereits." :
             ENGLISH ? "~: File ~ already exists" :
             FRANCAIS ? "~ : Le fichier ~ existe déjà." :
             ""
            );
    }

#ifdef LOGICAL_PATHNAMES
# Ein "absoluter Pathname" ist stets ein nicht-Logical Pathname, evtl.
# mit weiteren Einschränkungen.
#endif

#if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)

#ifdef PATHNAME_ATARI
# Ein "absoluter Pathname" ist ein Pathname, bei dem Device ein überprüfter
# String ist und Directory die Seriennummer, aber kein :RELATIVE, :CURRENT,
# :PARENT enthält.
#endif
#if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
# Ein "absoluter Pathname" ist ein Pathname, bei dem Device ein überprüfter
# String ist und Directory kein :RELATIVE, :CURRENT, :PARENT enthält.
#endif

# UP: Liefert den Namestring eines Pathname als ASCIZ-String.
# namestring_asciz(dir_namestring)
# > STACK_0: nicht-Logical Pathname
# > dir_namestring: Directory-Namestring (für DOS bzw. GEMDOS, ohne Seriennummer)
# < ergebnis: Namestring (für DOS bzw. GEMDOS, ohne Seriennummer, mit Nullbyte am Schluß)
# kann GC auslösen
  local object namestring_asciz (object dir_namestring);
  local object namestring_asciz(dir_namestring)
    var reg2 object dir_namestring;
    { var reg1 uintC stringcount;
      pushSTACK(dir_namestring); # Directory-Namestring als 1. String
      stringcount = file_namestring_parts(STACK_(0+1)); # Strings zum Filenamen
      pushSTACK(O(null_string)); # String mit Nullbyte
      return string_concat(1+stringcount+1); # zusammenhängen
    }

#ifdef PATHNAME_ATARI

#if HAS_SERNR && defined(ATARI)
# UP: Holt die Seriennummer einer Diskette.
# get_disk_number(drive)
# > uintW drive : Laufwerksbuchstabe ('A', 'B', ...)
# < object ergebnis : Seriennummer als Fixnum >=0
# kann GC auslösen
  local object get_disk_number (uintW drive);
  local uintB volume_path[] = "?:\\*.*";
  local DTA dta_buf;
  local object get_disk_number(drive)
    var reg2 uintW drive;
    # Methode:
    # Damit GEMDOS einen eventuellen Diskettenwechsel erkennt (und dann seine
    # internen Buffer leert, so daß korrekter Zugriff auf die Unterdirectories
    # möglich wird), darf GEMDOS vor dem BIOS die Diskette ansehen. Dazu darf
    # es erst einmal das Volume-Label suchen.
    # Danach holen wir uns mit einem BIOS-Zugriff die Seriennummer.
    { var reg3 uintL sectorlength;
      volume_path[0] = (uintB)drive; # Pfad für Volume-Label-Suche 'X:\*.*'
                              # mit korrektem Laufwerksbuchstaben versehen
      GEMDOS_SetDTA(&dta_buf); # DTA-Buffer setzen
      { var reg1 WORD erg = GEMDOS_Sfirst(&volume_path,8); # Suche des Volume-Label beginnen
                               # (8 = Attributmaske für "nur Volume-Label suchen")
        if (!(erg == GEMDOS_Sfirst_notfound) && (erg<0))
          OS_error(erg); # wesentlicher Fehler aufgetreten -> melden
      }
      # Volume-Label ist OK.
      drive = drive - 'A'; # drive = Laufwerksnummer
      { var reg1 BPB* erg = BIOS_GetBPB(drive); # Disk-Parameter holen
        if (erg==(BPB*)0) # Fehler?
          OS_error(-1); # ja -> erzeuge Fehler 'Allgemeiner Fehler'
        sectorlength = (uintL)(erg->recsiz);
      }
      # sectorlength = Länge (in Bytes) der Sectoren auf dieser Diskette
      { var DYNAMIC_ARRAY(reg4,bootsector,BYTE,sectorlength);
        # Bootsector lesen:
        { var reg1 WORD erg = BIOS_ReadAbs(bootsector,1,0,drive); # 1 Sector ab Sector 0 lesen
          if (erg<0) # Fehler aufgetreten -> melden
            { FREE_DYNAMIC_ARRAY(bootsector); OS_error(erg); }
        }
        # Bytes 8,9,10 ist die Disknummer:
        { var reg1 uintL seriennummer = *(ULONG*)(bootsector+8) >> 8;
          FREE_DYNAMIC_ARRAY(bootsector);
          return(fixnum(seriennummer)); # als Fixnum
    } } }
#endif

# UP: Bestimmt den Alisteneintrag in DRIVE_ALIST zu einem gegebenen Drive.
# get_drive_alist(pathname)
# > pathname: Pathname mit String als Device
# < ergebnis: Alisteneintrag
  local object get_drive_alist (object pathname);
  local object get_drive_alist(pathname)
    var reg5 object pathname;
    { var reg4 object device = ThePathname(pathname)->pathname_device;
      var reg3 uintB drive = TheSstring(device)->data[0]; # Laufwerksbuchstabe
      # Drive-Aliste durchlaufen:
      var reg2 object alistr = O(drive_alist);
      while (consp(alistr))
        { var reg1 object entry = Car(alistr); # Alisteneintrag
          # (car entry) ist ein Simple-String der Länge 1. Mit drive vergleichen:
          if (TheSstring(Car(entry))->data[0] == drive) { return entry; }
          alistr = Cdr(alistr);
        }
      # Liste zu Ende -> nicht existentes Laufwerk
      pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
      pushSTACK(device);
      fehler(file_error,
             DEUTSCH ? "Ein Laufwerk ~ gibt es nicht." :
             ENGLISH ? "drive ~ does not exist" :
             FRANCAIS ? "Le disque ~ n'existe pas." :
             ""
            );
    }

#endif

#if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)

#if !(defined(WATCOM) && defined(WINDOWS))

# Working Directory auf einem gegebenen Drive abfragen:
# getwdof(&buf,drive)
# > uintB* &buf: Adresse eines Path-Buffers
# > uintB drive: Laufwerk (0=A, 1=B, ...)
# < ergebnis: <0 falls Fehler
  #ifdef DJUNIX
    #define getwdof(buf,drive)  \
      ({__asm__ (# DOS Function 47H                                                         \
                 " movb $0x47,%%ah ; int $0x21 "                                            \
                 :                                                                # OUT     \
                 : "S" /* %esi */ ((uintB*)(buf)), "d" /* %dl */ ((uintB)(drive)) # IN      \
                 : "ax","bx","cx","di" /* %eax, %ebx, %ecx, %edi */               # CLOBBER \
                );                                                                          \
        0;                                                                                  \
       })
  #endif
  #ifdef EMUNIX
    #define getwdof(buf,drive)  _getcwd(buf,drive)
  #endif
  #ifdef WATCOM
    local int getwdof (uintB* buf, uintB drive);
    local int getwdof(buf,drive)
      var uintB* buf;
      var uintB drive;
      { var union REGS in;
        var union REGS out;
        in.regB.ah = 0x47; in.regB.dl = drive; in.regL.esi = (unsigned long) buf;
        intdos(&in,&out);
        return 0;
      }
  #endif

# Liefert das aktuelle Directory auf einem Laufwerk.
# getwd_of(path,drive)
# > uintB drive: Laufwerks-(groß-)buchstabe
# > uintB* path: Platz fürs aktuelle Directory
# < path: Pfad des aktuellen Directories, mit '/' als Trennzeichen und als Anfang
# < ergebnis: <0 falls Fehler
  #if defined(DJUNIX) || defined(WATCOM)
    #define getwd_of(path,drive)  ((path)[0] = '/', getwdof(&(path)[1],(drive)-'A'+1))
  #endif
  #ifdef EMUNIX
    #define getwd_of(path,drive)  _getcwd1(path,drive)
  #endif

#endif # !(WATCOM && WINDOWS)

# UP: Stellt fest, ob ein Laufwerk existiert.
# > uintB drive: Laufwerks-(groß-)buchstabe
# < boolean ergebnis: ob dieses Laufwerk existiert und ansprechbar ist
  local boolean good_drive (uintB drive);
  #ifdef EMUNIX
  local boolean good_drive(drive)
    var reg1 uintB drive;
    { # Methode (siehe HELPPC/misc.txt):
      # 1. save current drive  (INT 0x21,0x19)
      # 2. set current drive  (INT 0x21,0xE)
      # 3. get current drive  (INT 0x21,0x19)
      # 4. if current drive == drive requested
      #       then drive exists
      #       else drive doesn't exist
      # 5. reset original drive  (INT 0x21,0xE)
      var reg3 boolean result;
      begin_system_call();
     {var reg2 uintB orig_drive = _getdrive();
      _chdrive(drive);
      result = (_getdrive() == drive);
      _chdrive(orig_drive);
     }
      end_system_call();
      return result;
      # Alternative:
      # { var uintB drv[3];
      #   var uintB fsys[16];
      #   drv[0] = drive; drv[1] = ':'; drv[2] = '\0';
      #   begin_system_call();
      #  {var int result = _filesys(drv,&fsys,sizeof(fsys));
      #   end_system_call();
      #   return (result==0);
      # }}
    }
  #endif
  #if defined(DJUNIX) || defined(WATCOM)
  local boolean good_drive(drive)
    var reg1 uintB drive;
    { # Methode (siehe HELPPC/misc.txt):
      # 1. save current drive  (INT 0x21,0x19)
      # 2. set current drive  (INT 0x21,0xE)
      # 3. get current drive  (INT 0x21,0x19)
      # 4. if current drive == drive requested
      #       then drive exists
      #       else drive doesn't exist
      # 5. reset original drive  (INT 0x21,0xE)
      var union REGS in;
      var union REGS out;
      var reg2 uintB orig_drive;
      var reg3 boolean result;
      begin_system_call();
      in.regB.ah = 0x19; intdos(&in,&out); orig_drive = out.regB.al; # 1.
      in.regB.ah = 0x0E; in.regB.dl = drive; intdos(&in,&out);       # 2.
      in.regB.ah = 0x19; intdos(&in,&out);                           # 3.
      result = (out.regB.al == drive);                               # 4.
      in.regB.ah = 0x0E; in.regB.dl = orig_drive; intdos(&in,&out);  # 5.
      end_system_call();
      return result;
    }
  #endif

# UP: Liefert das aktuelle Drive.
# < uintB drive: Laufwerks-(groß-)buchstabe
  local uintB default_drive (void);
 #ifdef EMUNIX
  local uintB default_drive()
    { var reg1 uintB result;
      begin_system_call();
      result = _getdrive();
      end_system_call();
      return result;
    }
 #endif
 #if defined(DJUNIX) || defined(WATCOM)
  #if 1
    local uintB default_drive()
      { var union REGS in;
        var union REGS out;
        begin_system_call();
        in.regB.ah = 0x19;
        intdos(&in,&out);
        end_system_call();
        return 'A'+out.regB.al;
      }
  #else # nur defined(WATCOM)
    local uintB default_drive()
      { var unsigned int drive;
        begin_system_call();
        _dos_getdrive(&drive);
        end_system_call();
        return 'A'+drive-1;
      }
  #endif
 #endif

# UP: Liefert das aktuelle Directory auf einem gegebenen Drive.
# > uintB drive: Laufwerks-(groß-)buchstabe
# < ergebnis: aktuelles Directory (als Pathname)
# kann GC auslösen
  local object default_directory_of (uintB drive);
  local object default_directory_of(drive)
    var reg1 uintB drive;
    # Working Directory (von DOS) ist das aktuelle Directory:
    { var char path_buffer[3+MAXPATHLEN]; # vgl. GETWD(3)
      #if !(defined(WATCOM) && defined(WINDOWS))
        path_buffer[0] = drive; path_buffer[1] = ':';
        # Working Directory in path_buffer ablegen:
        begin_system_call();
        getwd_of(&path_buffer[2],drive);
        end_system_call();
      #else # defined(WATCOM) && defined(WINDOWS)
        # Methode:
        # 1. save current drive  (INT 0x21,0x19)
        # 2. set current drive  (INT 0x21,0xE)
        # 3. get current directory on current drive  (getcwd)
        # 4. reset original drive  (INT 0x21,0xE)
        { var union REGS in;
          var union REGS out;
          var reg2 uintB orig_drive;
          begin_system_call();
          in.regB.ah = 0x19; intdos(&in,&out); orig_drive = out.regB.al; # 1.
          in.regB.ah = 0x0E; in.regB.dl = drive-'A'+1; intdos(&in,&out); # 2.
          getcwd(&path_buffer[0],sizeof(path_buffer));                   # 3.
          in.regB.ah = 0x0E; in.regB.dl = orig_drive; intdos(&in,&out);  # 4.
          end_system_call();
        }
        ASSERT(path_buffer[0]==drive);
        ASSERT(path_buffer[1]==':');
        ASSERT(path_buffer[2]=='\\');
        # evtl. noch ein '\' am Schluß anfügen:
        { var reg2 char* path_end = &path_buffer[asciz_length(path_buffer)];
          if (!(path_end[-1]=='\\')) { path_end[0] = '\\'; path_end[1] = '\0'; }
        }
      #endif
      # Hack von DJ (siehe GO32/EXPHDLR.C) und EM (siehe LIB/MISC/_GETCWD1.C):
      # wandelt alle '\' in '/' und alle Groß- in Kleinbuchstaben (nur Kosmetik,
      # da DOS und unser PARSE-NAMESTRING auch Filenamen mit '/' statt '\'
      # verstehen).
      # in Pathname umwandeln:
      return asciz_dir_to_pathname(&path_buffer[0]);
    }

#endif

# UP: Füllt Default-Drive und Default-Directory in einen Pathname ein.
# use_default_dir(pathname)
# > pathname: nicht-Logical Pathname mit Device /= :WILD
# < ergebnis: neuer absoluter Pathname
# kann GC auslösen
  local object use_default_dir (object pathname);
  local object use_default_dir(pathname)
    var reg4 object pathname;
    { # erst den Pathname kopieren:
      pathname = copy_pathname(pathname);
      pushSTACK(pathname);
      # Stackaufbau: pathname.
     #ifdef PATHNAME_ATARI
      # Bestimme das betreffende Laufwerk und die Seriennummer der
      # darin eingelegten Diskette, und prüfe, ob sie mit der Seriennummer
      # im Pathname zusammenpaßt:
     {var reg5 object disk_seriennummer; # Seriennummer der im Laufwerk drive
                                         # gerade eingelegten Diskette.
      retry_disk:
      pathname = STACK_0;
      # evtl. das Default-Drive nehmen:
      if (nullp(ThePathname(pathname)->pathname_device))
        { ThePathname(pathname)->pathname_device = O(default_drive); }
      { # Laufwerksbuchstaben holen:
        var reg7 uintB drive = TheSstring(ThePathname(pathname)->pathname_device)->data[0];
        # Alisteneintrag zum Drive holen:
        pushSTACK(get_drive_alist(pathname));
        # Stackaufbau: pathname, Alisteneintrag.
        # Dann die Seriennummer der eingelegten Diskette holen:
        disk_seriennummer = get_disk_number(drive);
        # Dann die Seriennummern vergleichen:
       {var reg1 object path_seriennummer = Car(ThePathname(pathname=STACK_1)->pathname_directory);
        # path_seriennummer = in Pathname verlangte Seriennummer
        if (!(nullp(path_seriennummer) # keine verlangt ?
              || (eq(path_seriennummer,disk_seriennummer)) # oder beide gleich ?
           ) )
          { # Nein: Die verlangte Diskette ist nicht die eingelegte Diskette.
            # -> Continuable Error liefern:
            skipSTACK(1); # Alisteneintrag vergessen
            # (CERROR "Es geht weiter." "Legen Sie bitte die Diskette mit der Nummer ~D in Laufwerk ~A." Seriennummer Laufwerk)
            pushSTACK(OL(otherdisk_string1)); # "Es geht weiter."
            pushSTACK(OL(otherdisk_string2)); # "Legen Sie bitte die Diskette mit der Nummer ~D in Laufwerk ~A."
            pushSTACK(path_seriennummer); # Seriennummer
            pushSTACK(ThePathname(pathname)->pathname_device); # Laufwerk als String
            funcall(S(cerror),4);
            # und erneut versuchen:
            goto retry_disk;
      }}  }
      # Stackaufbau: pathname, Alisteneintrag.
      # Dann das Default-Directory zu dieser Seriennummer bestimmen:
      { var reg6 object default_dir; # Default-Directory (ein Pathname)
        {var reg1 object alistr = STACK_0; # Alisteneintrag durchlaufen
         while (consp(alistr=Cdr(alistr)))
           { var reg1 object entry = Car(alistr);
             if (eq(Car(entry),disk_seriennummer))
               { default_dir = Cdr(entry); goto default_dir_ok; }
        }  }
        # Bisher (auf diesem Drive) unbekannte Diskette.
        # Default-Directory := '\' :
        {var reg1 object new_cons = allocate_cons(); # Neues Cons
         Car(new_cons) = disk_seriennummer; # (cons seriennummer nil)
         pushSTACK(new_cons); # retten
         default_dir = allocate_pathname(); # neuer Pathname mit Name=NIL und Typ=NIL
         ThePathname(default_dir)->pathname_directory = popSTACK(); # mit Directory (cons seriennummer nil)
         ThePathname(default_dir)->pathname_device = ThePathname(STACK_1)->pathname_device;
         pushSTACK(default_dir); # retten
         new_cons = allocate_cons(); # neues Cons
         Car(new_cons) = disk_seriennummer; Cdr(new_cons) = STACK_0;
         pushSTACK(new_cons); # (cons seriennummer default_dir) retten
         new_cons = allocate_cons(); # neues Cons
         Car(new_cons) = popSTACK();
         # new_cons = (list (cons seriennummer default_dir))
         default_dir = popSTACK();
         # Alisteneintrag um die 1-elementige Liste new_cons erweitern:
         Cdr(new_cons) = Cdr(STACK_0); Cdr(STACK_0) = new_cons;
        }
        default_dir_ok:
        skipSTACK(1); # Alisteneintrag vergessen
        # Stackaufbau: pathname.
        # default_dir (ein Pathname) und disk_seriennummer (ein Fixnum) sind fertig.
        # Dann das Default-Directory in den Pathname einbauen:
        { var reg3 object subdirs = Cdr(ThePathname(STACK_0)->pathname_directory);
          # Fängt (CDR pathname-directory) mit :RELATIVE an?
          if (eq(Car(subdirs),S(Krelative)))
            { # ja -> Ersetze :RELATIVE durch default-subdirs, d.h.
              # bilde  (append default-subdirs (cdr subdirs))
              #      = (nreconc (reverse default-subdirs) (cdr subdirs))
              pushSTACK(Cdr(subdirs));
             {var reg1 object temp = Cdr(ThePathname(default_dir)->pathname_directory);
              temp = reverse(temp);
              subdirs = nreconc(temp,popSTACK());
            }}
     #endif
     #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
      # Default fürs Device:
      if (nullp(ThePathname(pathname)->pathname_device)) # kein Device angegeben?
        # Nimm das Default-Drive stattdessen:
        { ThePathname(pathname)->pathname_device = O(default_drive); }
      # Default fürs Directory:
        { var reg3 object subdirs = ThePathname(pathname)->pathname_directory;
          # Fängt pathname-directory mit :RELATIVE an?
          if (eq(Car(subdirs),S(Krelative)))
            # ja -> Ersetze :RELATIVE durch das Default-Directory:
            { var reg5 uintB drive = TheSstring(ThePathname(pathname)->pathname_device)->data[0];
              var reg2 object default_dir = default_directory_of(drive);
              # default_dir (ein Pathname) ist fertig.
              # Ersetze :RELATIVE durch default-subdirs, d.h.
              # bilde  (append default-subdirs (cdr subdirs))
              #      = (nreconc (reverse default-subdirs) (cdr subdirs))
              pushSTACK(Cdr(subdirs));
             {var reg1 object temp = ThePathname(default_dir)->pathname_directory;
              temp = reverse(temp);
              subdirs = nreconc(temp,popSTACK());
            }}
     #endif
          # Liste durchgehen und dabei neu aufconsen, dabei '.\' und '..\'
          # und '...\' verarbeiten (nicht dem DOS bzw. GEMDOS überlassen):
          pushSTACK(subdirs);
          pushSTACK(NIL);
          # Stackaufbau: Pathname, subdir-oldlist, subdir-newlist.
          while (mconsp(STACK_1)) # Bis oldlist am Ende ist:
            { var reg2 object subdir = Car(STACK_1); # nächstes subdir
              if
                 #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
                 (eq(subdir,S(Kcurrent)))
                 #else
                 (equal(subdir,O(punkt_string)))
                 #endif
                # = :CURRENT -> newlist unverändert lassen
                {}
              elif
                   #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
                   (eq(subdir,S(Kparent)))
                   #else
                   (equal(subdir,O(punktpunkt_string)))
                   #endif
                # = :PARENT -> newlist um eins verkürzen:
                { if (matomp(Cdr(STACK_0))) # newlist (bis auf :ABSOLUTE) leer ?
                    { # :PARENT von "\" aus liefert Error
                      pushSTACK(STACK_2); # Wert für Slot PATHNAME von FILE-ERROR
                      pushSTACK(O(backslash_string)); # "\\"
                      pushSTACK(directory_namestring(STACK_(2+2))); # Directory von pathname
                      fehler(file_error,
                             DEUTSCH ? "Directory ~ oberhalb ~ existiert nicht." :
                             ENGLISH ? "no directory ~ above ~" :
                             FRANCAIS ? "Il n'y a pas de répertoire ~ au delà de ~." :
                             ""
                            );
                    }
                  if (eq(Car(STACK_0),S(Kwild_inferiors))) # newlist fängt mit '...\' an ?
                    { # :PARENT von "...\" aus liefert Error
                      pushSTACK(STACK_2); # Wert für Slot PATHNAME von FILE-ERROR
                      pushSTACK(directory_namestring(STACK_(2+1))); # Directory von pathname
                      fehler(file_error, # '"..\\" nach "...\\" ist unzulässig: ~'
                             DEUTSCH ? "\"..\\\\\" nach \"...\\\\\" ist unzulässig: ~" :
                             ENGLISH ? "\"..\\\\\" after \"...\\\\\" is invalid: ~" :
                             FRANCAIS ? "\"..\\\\\" après \"...\\\\\" n'est pas permis : ~" :
                             ""
                            );
                    }
                  STACK_0 = Cdr(STACK_0);
                }
              else # (auch wenn :ABSOLUTE !)
                { # newlist um eins verlängern:
                  pushSTACK(subdir);
                 {var reg1 object new_cons = allocate_cons();
                  Car(new_cons) = popSTACK();
                  Cdr(new_cons) = STACK_0;
                  STACK_0 = new_cons;
                }}
              STACK_1 = Cdr(STACK_1);
            }
          subdirs = nreverse(popSTACK()); # newlist, wieder umdrehen
     #ifdef PATHNAME_ATARI
          STACK_0 = subdirs; # und retten
      } }
      # Stackaufbau: pathname, subdirs.
      {var reg1 object new_cons = allocate_cons(); # neues Cons
       Car(new_cons) = disk_seriennummer; Cdr(new_cons) = popSTACK();
       # new_cons = (cons disk_seriennummer subdirs)
       # in den Pathname eintragen:
       pathname = popSTACK();
       ThePathname(pathname)->pathname_directory = new_cons;
     }}
     #endif
     #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
          skipSTACK(1);
          # Stackaufbau: pathname.
          pathname = popSTACK();
          ThePathname(pathname)->pathname_directory = subdirs; # in den Pathname eintragen
        }
     #endif
      return pathname;
    }

#ifdef PATHNAME_ATARI

# UP: Stellt sicher, daß das Directory eines Pathname existiert.
# Sonst Fehlermeldung.
# Grund:
#   GEMDOS ist dazu nach Diskettenwechsel nicht in der Lage und interpretiert
#   manchmal (nach Diskettenwechsel) beliegige Dateiinhalte als Directories.
#   Daher müssen wir GEMDOS auf die Sprünge helfen und bei jedem Unter-
#   Directory selber testen, ob es existiert.
# assure_dir_exists(tolerantp)
# > STACK_0: absoluter Pathname ohne Wildcards im Directory
# > tolerantp: Flag, ob ein Fehler vermieden werden soll
# < ergebnis:
#     falls Name=NIL: Directory-Namestring (für GEMDOS, ohne Seriennummer)
#     falls Name/=NIL: Namestring (für GEMDOS, ohne Seriennummer, mit Nullbyte am Schluß)
#     falls tolerantp evtl.: nullobj
# kann GC auslösen
  local object assure_dir_exists (boolean tolerantp);
  local object assure_dir_exists(tolerantp)
    var reg3 boolean tolerantp;
    { {var reg1 object pathname = STACK_0;
       pushSTACK(Cdr(ThePathname(pathname)->pathname_directory)); # subdir-list (ohne Seriennummer)
       {pushSTACK(ThePathname(pathname)->pathname_device); # Device
        pushSTACK(O(doppelpunkt_string)); # ":"
        pushSTACK(O(backslash_string)); # "\\"
        pushSTACK(string_concat(3)); # zusammenhängen
      }}
      # Stackaufbau: Pathname, verlängerte subdir-list, Directory-Namestring.
      while (consp(STACK_1=Cdr(STACK_1)))
        { # Unterdirectory-Namestring aufbauen:
          {# (Erster String bereits in STACK_0, weitere zum subdir folgen:)
           var reg1 uintC stringcount = 1 + subdir_namestring_parts(STACK_1);
           pushSTACK(string_concat(stringcount));
          }
          {# in ASCIZ-String umwandeln:
           var reg2 uintB* asciz = TheAsciz(string_to_asciz(STACK_0));
           # Dateisuche gemäß GEMDOS-Konvention:
           var reg1 sintW errorcode;
           set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
           GEMDOS_SetDTA(&DTA_buffer); # DTA-Buffer setzen
           errorcode =
             GEMDOS_Sfirst(asciz,0x10); # Suchanfang, die Maske 0x10 sucht
                                        # nach Ordnern und normalen Dateien.
           if (errorcode == GEMDOS_Sfirst_notfound) # 'Keine Datei gefunden' ?
             goto not_exists;
           if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
           if (!(DTA_buffer.d_attrib & 0x10)) # gefundene Datei kein Unterdirectory ?
             { not_exists:
               clr_break_sem_4();
               if (tolerantp) { skipSTACK(2); return nullobj; }
               fehler_dir_not_exists(STACK_2);
             }
           clr_break_sem_4();
          }
          # Directory-Namestring zu Ende aufbauen:
          pushSTACK(O(backslash_string)); # "\\" an STACK_0 anhängen
          pushSTACK(string_concat(2));
        }
      {var reg1 object dir_namestring = popSTACK(); # Directory-Namestring
       skipSTACK(1);
       if (namenullp(STACK_0))
         { return dir_namestring; }
         else
         { return namestring_asciz(dir_namestring); }
    } }

#endif

#if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)

# UP: Stellt sicher, daß das Directory eines Pathname existiert.
# Sonst Fehlermeldung.
# assure_dir_exists(tolerantp)
# > STACK_0: absoluter Pathname ohne Wildcards im Directory
# > tolerantp: Flag, ob ein Fehler vermieden werden soll
# < ergebnis:
#     falls Name=NIL: Directory-Namestring (für DOS)
#     falls Name/=NIL: Namestring (für DOS, mit Nullbyte am Schluß)
#     falls tolerantp evtl.: nullobj
# kann GC auslösen
  local object assure_dir_exists (boolean tolerantp);
  local object assure_dir_exists(tolerantp)
    var reg4 boolean tolerantp;
    { var reg2 uintC stringcount = directory_namestring_parts(STACK_0); # Strings fürs Directory
      var reg1 object dir_namestring = string_concat(stringcount); # zusammenhängen
      # Existenztest:
      if (!nullp(Cdr(ThePathname(STACK_0)->pathname_directory))) # Subdir-List leer -> OK
        # (Muß abgefangen werden, denn stat() auf Rootdir liefert Fehler.)
        {var struct stat statbuf;
         var reg3 uintB* endptr = &TheSstring(dir_namestring)->data[TheSstring(dir_namestring)->length-1];
         *endptr = '\0'; # '\' am Schluß durch Nullbyte ersetzen
         begin_system_call();
         if (stat(TheAsciz(dir_namestring),&statbuf) < 0)
           { end_system_call();
             if (tolerantp && (errno==ENOENT)) { return nullobj; }
             OS_error();
           }
         end_system_call();
         *endptr = '\\'; # wieder mit '\' abschließen
         if (!S_ISDIR(statbuf.st_mode)) # gefundene Datei kein Unterdirectory ?
           { if (tolerantp) { return nullobj; }
             fehler_dir_not_exists(dir_namestring);
        }  }
      if (namenullp(STACK_0))
        { return dir_namestring; }
        else
        { return namestring_asciz(dir_namestring); }
    }

#endif

# UP: Liefert den Directory-Namestring eines Pathname unter der Annahme,
#     daß das Directory dieses Pathname existiert.
# assume_dir_exists()
# > STACK_0: absoluter Pathname ohne Wildcards im Directory
# < ergebnis:
#     falls Name=NIL: Directory-Namestring (für DOS bzw. GEMDOS, ohne Seriennummer)
#     falls Name/=NIL: Namestring (für DOS bzw. GEMDOS, ohne Seriennummer, mit Nullbyte am Schluß)
# kann GC auslösen
  global object assume_dir_exists (void);
  global object assume_dir_exists()
    { var reg2 uintC stringcount =
        #if HAS_SERNR
        directory_namestring_parts(STACK_0,TRUE); # Strings fürs Directory
        #else
        directory_namestring_parts(STACK_0); # Strings fürs Directory
        #endif
      var reg1 object dir_namestring = string_concat(stringcount); # zusammenhängen
      if (namenullp(STACK_0))
        { return dir_namestring; }
        else
        { return namestring_asciz(dir_namestring); }
    }

#endif

#ifdef PATHNAME_AMIGAOS

# UP: Liefert den Truename eines Directory-Locks.
# > set_break_sem_4(): schon ausgeführt
# > lock: Directory-Lock, wird freigegeben
# < ergebnis: Directory (als Pathname)
# kann GC auslösen
  local object directory_truename (BPTR lock);
  local object directory_truename(lock)
    var reg6 BPTR lock;
    { # Von hier aus hochhangeln:
      pushSTACK(NIL); # Subdir-Liste := NIL
      { var LONGALIGNTYPE(struct FileInfoBlock) fib;
        var reg5 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
        loop
          { # Directory selbst ansehen:
            begin_system_call();
           {var reg1 LONG ergebnis = Examine(lock,fibptr);
            end_system_call();
            if (!ergebnis) { OS_error(); }
           }
            # seinen Namen verwenden:
           {var reg4 object name = asciz_to_string(&fibptr->fib_FileName[0]);
            # zum Parent-Directory hochsteigen:
            var reg3 BPTR parentlock;
            begin_system_call();
            parentlock = ParentDir(lock);
            UnLock(lock);
            end_system_call();
            if (!(parentlock==BPTR_NULL))
              # name ist der Name eines Subdirectories
              { # vor die Subdir-Liste pushen:
                pushSTACK(name);
               {var reg1 object new_cons = allocate_cons();
                Car(new_cons) = popSTACK();
                Cdr(new_cons) = STACK_0;
                STACK_0 = new_cons;
               }
                lock = parentlock; # und vom Parent Directory aus weitermachen
              }
              else
              { begin_system_call();
                if (IoErr()) { OS_error(); } # Fehler aufgetreten?
                end_system_call();
                # name ist der Name eines DOS-Volumes.
                pushSTACK(name);
                break;
              }
      }   }}
      clr_break_sem_4(); # Unterbrechungen wieder zulassen
      # Stackaufbau: subdirs, devicename.
     {# subdirs mit :ABSOLUTE anfangen lassen:
      var reg1 object new_cons = allocate_cons();
      Car(new_cons) = S(Kabsolute); Cdr(new_cons) = STACK_1;
      STACK_1 = new_cons;
     }
     {var reg1 object default_dir = allocate_pathname(); # neuer Pathname mit Name=NIL und Typ=NIL
      ThePathname(default_dir)->pathname_device = popSTACK();
      ThePathname(default_dir)->pathname_directory = popSTACK();
      return default_dir;
    }}

# UP: Liefert das aktuelle Directory.
# < ergebnis: aktuelles Directory (als Pathname)
# kann GC auslösen
  local object default_directory (void);
  local object default_directory()
    { # Lock fürs aktuelle Directory holen:
      set_break_sem_4(); # Unterbrechungen währenddessen verhindern
      begin_system_call();
     {var reg1 BPTR lock = Lock("",ACCESS_READ);
      if (lock==BPTR_NULL)
        { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
          pushSTACK(unbound); # "Wert" für Slot PATHNAME von FILE-ERROR
          fehler(file_error,
                 DEUTSCH ? "Zugriff auf aktuelles Verzeichnis nicht möglich." :
                 ENGLISH ? "Couldn't access current directory" :
                 FRANCAIS ? "Le répertoire courant n'est pas accessible." :
                 ""
                );
        }
      end_system_call();
      return directory_truename(lock); # macht clr_break_sem_4(); und UnLock(lock);
    }}

# UP: Füllt Default-Directory in einen Pathname ein.
# use_default_dir(pathname)
# > pathname: nicht-Logical Pathname
# < ergebnis: neuer absoluter Pathname
# kann GC auslösen
  local object use_default_dir (object pathname);
  local object use_default_dir(pathname)
    var reg3 object pathname;
    { # erst den Pathname kopieren:
      pathname = copy_pathname(pathname);
      # Dann das Default-Directory in den Pathname einbauen:
      { var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
        # Fängt pathname-directory mit :RELATIVE an?
        if (eq(Car(subdirs),S(Krelative)))
          { # ja -> Ersetze :RELATIVE durch default-subdirs, d.h.
            # bilde  (append default-subdirs (cdr subdirs))
            #      = (nreconc (reverse default-subdirs) (cdr subdirs))
            pushSTACK(pathname);
            pushSTACK(Cdr(subdirs));
           {var reg1 object temp = default_directory();
            temp = ThePathname(temp)->pathname_directory;
            temp = reverse(temp);
            subdirs = nreconc(temp,popSTACK());
            pathname = popSTACK();
            # in den Pathname eintragen:
            ThePathname(pathname)->pathname_directory = subdirs;
          }}
      }
      return pathname;
    }

# UP: Macht aus einem Directory-Namestring einen, der für AMIGAOS geeignet ist.
# OSnamestring(namestring)
# > namestring: neu erzeugter Directory-Namestring, mit '/' oder ':' am
#               Schluß, ein Simple-String
# < ergebnis: Namestring zu diesem Directory, im AmigaOS-Format: letzter '/'
#             gestrichen, falls überflüssig, ASCIZ-String
# kann GC auslösen
  local object OSnamestring (object namestring);
  local object OSnamestring(namestring)
    var reg1 object namestring;
    { var reg2 uintL len = TheSstring(namestring)->length;
      if (len==0) goto ok; # Leerstring -> nichts streichen
     {var reg3 uintB ch = TheSstring(namestring)->data[len-1];
      if (!(ch=='/')) goto ok; # kein '/' am Schluß -> nichts streichen
      if (len==1) goto ok; # "/" bedeutet Parent -> nicht streichen
      ch = TheSstring(namestring)->data[len-2];
      if ((ch=='/') || (ch==':')) # davor ein '/' oder ':'
        goto ok; # -> bedeutet Parent -> nicht streichen
      # '/' am Schluß streichen, dann string_to_asciz:
        namestring = copy_string(namestring); # Länge bleibt dabei gleich!
        TheSstring(namestring)->data[len-1] = '\0';
        return namestring;
      ok: # nichts streichen
        return string_to_asciz(namestring);
    }}

# UP: Stellt sicher, daß das Directory eines Pathname existiert.
# assure_dir_exists(tolerantp)
# > STACK_0: nicht-Logical Pathname, bei dem Directory kein :RELATIVE enthält.
# > tolerantp: Flag, ob ein Fehler vermieden werden soll
# > subr_self: Aufrufer (ein SUBR)
# < STACK_0: (evtl. derselbe) Pathname, aber aufgelöst.
# < ergebnis:
#     falls Name=NIL: Directory-Namestring (für AMIGAOS, mit '/' am Schluß)
#     falls Name/=NIL: Namestring (für AMIGAOS, mit Nullbyte am Schluß)
#     falls tolerantp evtl.: nullobj
# < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
#                                sonst ein Pointer auf eine STAT-Information.
# kann GC auslösen
  local var struct FileInfoBlock * filestatus;
  local object assure_dir_exists (boolean tolerantp);
  local object assure_dir_exists(tolerantp)
    var reg5 boolean tolerantp;
    { # Zur Auflösung von :PARENTs, die über Root hinaussteigen,
      # müssen wir das Betriebssystem bemühen. Daher:
      var reg3 object dir_namestring;
      {var reg1 uintC stringcount = directory_namestring_parts(STACK_0); # Strings fürs Directory
       dir_namestring = string_concat(stringcount);
      }
      pushSTACK(dir_namestring);
      dir_namestring = OSnamestring(dir_namestring); # ohne überflüssigen '/' am Schluß
      # Lock für dieses Directory holen:
      set_break_sem_4(); # Unterbrechungen währenddessen verhindern
      begin_system_call();
     {var reg4 BPTR lock = Lock(TheAsciz(dir_namestring),ACCESS_READ);
      if (lock==BPTR_NULL)
        { var reg2 LONG errcode = IoErr();
          end_system_call();
          switch (errcode)
            { case ERROR_OBJECT_NOT_FOUND:
                clr_break_sem_4();
                if (tolerantp) { skipSTACK(1); return nullobj; }
                fehler_dir_not_exists(STACK_0);
              case ERROR_ACTION_NOT_KNOWN:
                # Ein Device, bei dem man keine Locks für Subdirectories holen
                # kann! Hierbei muß es sich wohl um ein spezielles Device handeln
                # (PIPE, CON, AUX, etc.).
                # Wir stoppen die Subdirectory-Überprüfungen. Nicht einmal mehr
                # Examine() rufen wir auf. Wir gehen im Gegenteil davon aus, daß
                # das File im gewöhnlichen Sinne (noch) nicht existiert.
                clr_break_sem_4(); # Unterbrechungen zulassen, da wir nun doch kein Lock belegt haben
                if (namenullp(STACK_(0+1))) # kein File angesprochen?
                  { return popSTACK(); } # ja -> fertig
                  else
                  { var reg1 uintC stringcount = 1; # directory_namestring schon auf dem STACK
                    stringcount += file_namestring_parts(STACK_(0+1)); # Strings für den Filename
                    pushSTACK(O(null_string)); stringcount++; # und Nullbyte
                   {var reg2 object namestring = string_concat(stringcount); # zusammenhängen
                    filestatus = (struct FileInfoBlock *)NULL; # File existiert nicht, sagen wir
                    return namestring;
                  }}
              default:
                OS_error();
        }   }
      end_system_call();
      dir_namestring = popSTACK();
      # und überprüfen, ob's ein Directory ist:
      { var LONGALIGNTYPE(struct FileInfoBlock) fib;
        var reg2 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
        begin_system_call();
       {var reg1 LONG ergebnis = Examine(lock,fibptr);
        if (!ergebnis) { UnLock(lock); OS_error(); }
        if (!(fibptr->fib_DirEntryType > 0)) # etwa kein Directory?
          { UnLock(lock);
            end_system_call();
            if (tolerantp) { return nullobj; }
            # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
            pushSTACK(dir_namestring);
            pushSTACK(TheSubr(subr_self)->name);
            fehler(file_error,
                   DEUTSCH ? "~: ~ ist ein File und kein Directory." :
                   ENGLISH ? "~: ~ names a file, not a directory" :
                   FRANCAIS ? "~ : ~ est un fichier et non un répertoire." :
                   ""
                  );
          }
        end_system_call();
      }}
      # Lock zum Truename machen:
      {var reg1 object new_pathname = directory_truename(lock); # macht clr_break_sem_4();
       var reg2 object old_pathname = STACK_0;
       ThePathname(new_pathname)->pathname_name = ThePathname(old_pathname)->pathname_name;
       ThePathname(new_pathname)->pathname_type = ThePathname(old_pathname)->pathname_type;
       STACK_0 = new_pathname;
     }}
     {var reg4 object pathname = STACK_0;
      # Information zum angesprochenen File holen:
      if (namenullp(pathname)) # kein File angesprochen?
        { return directory_namestring(pathname); } # ja -> fertig
      { var reg2 uintC stringcount = 0;
        stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
        stringcount += file_namestring_parts(pathname); # Strings für den Filename
        pushSTACK(O(null_string)); stringcount++; # und Nullbyte
       {var reg1 object namestring = string_concat(stringcount); # zusammenhängen
        # Lock für dieses File holen:
          begin_system_call();
        { var reg3 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
          if (lock==BPTR_NULL)
            { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
              end_system_call();
              # File existiert nicht.
              filestatus = (struct FileInfoBlock *)NULL; return namestring;
            }
          end_system_call();
          # File existiert.
          # Information holen:
         {local var LONGALIGNTYPE(struct FileInfoBlock) status;
          var reg1 struct FileInfoBlock * statusptr = LONGALIGN(&status);
          begin_system_call();
          if (! Examine(lock,statusptr) ) { UnLock(lock); OS_error(); }
          UnLock(lock);
          end_system_call();
          if (statusptr->fib_DirEntryType > 0) # Ist es ein Directory?
            { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
              pushSTACK(whole_namestring(STACK_0));
              pushSTACK(TheSubr(subr_self)->name);
              fehler(file_error,
                     DEUTSCH ? "~: ~ ist ein Directory und kein File." :
                     ENGLISH ? "~: ~ names a directory, not a file" :
                     FRANCAIS ? "~ : ~ désigne un répertoire et non un fichier." :
                     ""
                    );
            }
            else
            # normales File
            { pushSTACK(namestring);
              # Die Groß-/Kleinschreibung des Truename wird bestimmt durch
              # das bereits existierende File.
              pushSTACK(asciz_to_string(&statusptr->fib_FileName[0]));
              split_name_type(1);
             {var reg1 object pathname = STACK_(0+3); # der kopierte Pathname
              ThePathname(pathname)->pathname_type = popSTACK();
              ThePathname(pathname)->pathname_name = popSTACK();
              # Fertig.
              filestatus = statusptr;
              return popSTACK(); # namestring
            }}
     }}}}}
    }

# Dasselbe unter der Annahme, daß das Directory bereits existiert.
# (Keine Vereinfachung, da wir ja den Truename bestimmen müssen.)
  global object assume_dir_exists (void);
  global object assume_dir_exists()
    { subr_self = L(open); return assure_dir_exists(FALSE); }

#endif

#ifdef PATHNAME_UNIX

# UP: Liefert das aktuelle Directory.
# < ergebnis: aktuelles Directory (als Pathname)
# kann GC auslösen
  local object default_directory (void);
  local object default_directory()
    # Working Directory (von UNIX) ist das aktuelle Directory:
    { var char path_buffer[MAXPATHLEN]; # vgl. GETWD(3)
      # Working Directory in path_buffer ablegen:
      begin_system_call();
      if ( getwd(&path_buffer[0]) ==NULL)
        { pushSTACK(O(punkt_string)); # Wert für Slot PATHNAME von FILE-ERROR
          pushSTACK(asciz_to_string(&path_buffer[0])); # Meldung
          fehler(file_error,
                 DEUTSCH ? "UNIX-Fehler bei GETWD: ~" :
                 ENGLISH ? "UNIX error while GETWD: ~" :
                 FRANCAIS ? "Erreur UNIX pendant GETWD : ~" :
                 "~"
                );
        }
      end_system_call();
      # Es muß mit '/' anfangen:
      if (!(path_buffer[0] == '/'))
        { pushSTACK(O(punkt_string)); # Wert für Slot PATHNAME von FILE-ERROR
          pushSTACK(asciz_to_string(&path_buffer[0]));
          fehler(file_error,
                 DEUTSCH ? "UNIX GETWD lieferte ~" :
                 ENGLISH ? "UNIX GETWD returned ~" :
                 FRANCAIS ? "GETWD d'UNIX a retourné ~" :
                 ""
                );
        }
      # in Pathname umwandeln:
      return asciz_dir_to_pathname(&path_buffer[0]);
    }

# UP: Füllt Default-Directory in einen Pathname ein.
# use_default_dir(pathname)
# > pathname: nicht-Logical Pathname
# < ergebnis: neuer Pathname, bei dem Directory kein :RELATIVE enthält.
#             (kurz: "absoluter Pathname")
# kann GC auslösen
  local object use_default_dir (object pathname);
  local object use_default_dir(pathname)
    var reg3 object pathname;
    { # erst den Pathname kopieren:
      pathname = copy_pathname(pathname);
      # Dann das Default-Directory in den Pathname einbauen:
      { var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
        # Fängt pathname-directory mit :RELATIVE an?
        if (eq(Car(subdirs),S(Krelative)))
          { # ja -> Ersetze :RELATIVE durch default-subdirs, d.h.
            # bilde  (append default-subdirs (cdr subdirs))
            #      = (nreconc (reverse default-subdirs) (cdr subdirs))
            pushSTACK(pathname);
            pushSTACK(Cdr(subdirs));
           {var reg1 object temp = default_directory();
            temp = ThePathname(temp)->pathname_directory;
            temp = reverse(temp);
            subdirs = nreconc(temp,popSTACK());
            pathname = popSTACK();
            # in den Pathname eintragen:
            ThePathname(pathname)->pathname_directory = subdirs;
          }}
      }
      return pathname;
    }

# UP: Stellt sicher, daß das Directory eines Pathname existiert, und löst
# dabei symbolische Links auf.
# assure_dir_exists(tolerantp)
# > STACK_0: nicht-Logical Pathname, bei dem Directory kein :RELATIVE enthält.
# > tolerantp: Flag, ob ein Fehler vermieden werden soll
# > subr_self: Aufrufer (ein SUBR)
# < STACK_0: (evtl. derselbe) Pathname, wobei weder fürs Directory noch
#            für den Filenamen ein symbolisches Link zu verfolgen ist.
# < ergebnis:
#     falls Name=NIL: Directory-Namestring (für UNIX, mit '/' am Schluß)
#     falls Name/=NIL: Namestring (für UNIX, mit Nullbyte am Schluß)
#     falls tolerantp evtl.: nullobj
# < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
#                                sonst ein Pointer auf eine STAT-Information.
# kann GC auslösen
  local var struct stat * filestatus;
  local object assure_dir_exists (boolean tolerantp);
  local object assure_dir_exists(tolerantp)
    var reg7 boolean tolerantp;
    { var reg6 uintC allowed_links = MAXSYMLINKS; # Anzahl der noch erlaubten symbolischen Links
      loop # Schleife über die aufzulösenden symbolischen Links
        { # Truepath des Directory bestimmen:
          var char path_buffer[MAXPATHLEN]; # vgl. REALPATH(3)
          { var reg2 uintC stringcount = directory_namestring_parts(STACK_0); # Strings zum Directory
            pushSTACK(O(punkt_string)); # und "."
            pushSTACK(O(null_string)); # und Nullbyte
           {var reg1 object string = string_concat(stringcount+1+1); # zusammenhängen
            # symbolische Links darin auflösen:
            begin_system_call();
            if ( realpath(TheAsciz(string),&path_buffer[0]) ==NULL)
              { end_system_call();
                if (!(errno==ENOENT)) { OS_error(); }
                if (tolerantp) { return nullobj; }
                fehler_dir_not_exists(asciz_dir_to_pathname(&path_buffer[0])); # fehlerhafte Komponente
              }
            end_system_call();
          }}
          # Neuer Directory-Path muß mit '/' anfangen:
          if (!(path_buffer[0] == '/'))
            { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
              pushSTACK(asciz_to_string(&path_buffer[0]));
              fehler(file_error,
                     DEUTSCH ? "UNIX REALPATH lieferte ~" :
                     ENGLISH ? "UNIX REALPATH returned ~" :
                     FRANCAIS ? "REALPATH d'UNIX a retourné ~" :
                     ""
                    );
            }
          # Am Schluß evtl. ein '/' anfügen:
          {var reg1 char* pathptr = &path_buffer[0];
           var reg2 uintL len = 0; # Stringlänge
           until (*pathptr == 0) { pathptr++; len++; } # ASCIZ-Stringende suchen
           if (!((len>0) && (pathptr[-1]=='/')))
             { *pathptr = '/'; len++; } # ein '/' anfügen
          # und in einen String umwandeln:
           { var reg4 object new_string = make_string((uintB*)(&path_buffer[0]),len);
          # Pathname draus machen und dessen Directory verwenden:
            {var reg3 object new_pathname = coerce_pathname(new_string);
             ThePathname(STACK_0)->pathname_directory
               = ThePathname(new_pathname)->pathname_directory;
          }}}
          # Information zum angesprochenen File holen:
          if (namenullp(STACK_0)) # kein File angesprochen?
            { return directory_namestring(STACK_0); } # ja -> fertig
          { var reg5 object pathname = STACK_0;
            var reg2 uintC stringcount = 0;
            stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
            stringcount += file_namestring_parts(pathname); # Strings für den Filename
            pushSTACK(O(null_string)); stringcount++; # und Nullbyte
           {var reg1 object namestring = string_concat(stringcount); # zusammenhängen
            # Information holen:
            local struct stat status;
            begin_system_call();
            if (!( lstat(TheAsciz(namestring),&status) ==0))
              { if (!(errno==ENOENT)) { OS_error(); }
                # File existiert nicht.
                end_system_call();
                filestatus = (struct stat *)NULL; return namestring;
              }
            end_system_call();
            # File existiert.
            if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
              { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
                pushSTACK(whole_namestring(STACK_0));
                pushSTACK(TheSubr(subr_self)->name);
                fehler(file_error,
                       DEUTSCH ? "~: ~ ist ein Directory und kein File." :
                       ENGLISH ? "~: ~ names a directory, not a file" :
                       FRANCAIS ? "~ : ~ est un répertoire et non un fichier." :
                       ""
                      );
              }
            #ifdef HAVE_LSTAT
            elif (S_ISLNK(status.st_mode)) # Ist es ein symbolisches Link?
              # ja -> weiterverfolgen:
              { if (allowed_links==0) # keine Links mehr erlaubt?
                  { errno = ELOOP_VALUE; OS_error(); } # ja -> UNIX-Error ELOOP simulieren
                allowed_links--; # danach ist ein Link weniger erlaubt
               {var reg4 uintL linklen = status.st_size; # vermutliche Länge des Link-Inhalts
                retry_readlink:
                  pushSTACK(namestring); # Namestring retten
                { var reg3 object linkbuf = allocate_string(linklen); # Buffer für den Link-Inhalt
                  namestring = popSTACK();
                  # Link-Inhalt lesen:
                  begin_system_call();
                 {var reg1 int result = readlink(TheAsciz(namestring),TheAsciz(linkbuf),linklen);
                  end_system_call();
                  if (result<0)
                    { OS_error(); }
                  if (!(result == linklen)) # manchmal (AIX, NFS) stimmt status.st_size nicht
                    { linklen = result; goto retry_readlink; }
                  # Daraus ein Pathname machen:
                  # (MERGE-PATHNAMES (PARSE-NAMESTRING linkbuf) pathname)
                  pushSTACK(linkbuf); funcall(L(parse_namestring),1);
                  pushSTACK(value1); pushSTACK(STACK_(0+1)); funcall(L(merge_pathnames),2);
                  STACK_0 = value1;
              }}}}
            #endif
            else
              # normales File
              { filestatus = &status; return namestring; }
          }}
    }   }

# Dasselbe unter der Annahme, daß das Directory bereits existiert.
# (Keine Vereinfachung, da das File ein symbolisches Link in ein anderes
# Directory sein kann, und dieses muß dann als existent überprüft werden.)
  global object assume_dir_exists (void);
  global object assume_dir_exists()
    { subr_self = L(open); return assure_dir_exists(FALSE); }

#endif

#ifdef PATHNAME_RISCOS

# Ein "absoluter Pathname" ist ein Pathname, bei dem Directory mit
# (:ABSOLUTE :ROOT ...) beginnt.

# UP: Liefert das aktuelle Directory.
# < ergebnis: aktuelles Directory (als Pathname)
# kann GC auslösen
  local object default_directory (void);
  local object default_directory()
    # Working Directory (von RISCOS) ist das aufgelöste "@":
    { var char path_buffer[MAXPATHLEN];
      # Working Directory in path_buffer ablegen:
      begin_system_call();
      if ( realpath("@",&path_buffer[0]) ==NULL) { OS_error(); }
      end_system_call();
      # in Pathname umwandeln:
      return asciz_dir_to_pathname(&path_buffer[0]);
    }

#if 0 # unbenutzt
# UP: Convert a valid RISCOS file namestring to an absolute pathname.
# canonicalise_filename(filename)
# > filename: Simple-Asciz-String
# < result: absolute pathname
  local object canonicalise_filename (object filename);
  local object canonicalise_filename(filename)
    var reg1 object filename;
    { var char path_buffer[MAXPATHLEN];
      begin_system_call();
      if ( realpath(TheAsciz(filename),&path_buffer[0]) ==NULL) { OS_error(); }
      end_system_call();
      # in Pathname umwandeln:
      return coerce_pathname(asciz_to_string(&path_buffer[0]));
    }
#endif

# UP: Convert a valid RISCOS directory namestring to an absolute pathname.
# canonicalise_dirname(pathname,dirname)
# > pathname: Pathname whose host name and device is to be used
# > dirname: Simple-String, ends with '.'
# < result: absolute pathname
  local object canonicalise_dirname (object pathname, object dirname);
  local object canonicalise_dirname(pathname,dirname)
    var reg5 object pathname;
    var reg4 object dirname;
    { var reg3 uintC stringcount = host_namestring_parts(pathname); # Strings für den Host
      # Device, vgl. directory_namestring_parts():
      { var reg1 object device = ThePathname(pathname)->pathname_device;
        if (!(nullp(device))) # NIL -> kein String
          { pushSTACK(O(doppelpunkt_string)); # ":"
            pushSTACK(device); # Device auf den Stack
            pushSTACK(O(punkt_string)); # "."
            stringcount += 3; # und mitzählen
      }   }
      pushSTACK(dirname);
     {var reg1 object dir_string = string_concat(stringcount+1);
      # Punkt am Schluß durch Nullbyte ersetzen:
      TheSstring(dir_string)->data[TheSstring(dir_string)->length-1] = '\0';
      # absolut machen:
      { var char path_buffer[MAXPATHLEN];
        begin_system_call();
        if ( realpath(TheAsciz(dir_string),&path_buffer[0]) ==NULL) { OS_error(); }
        end_system_call();
        # in Pathname umwandeln:
        return asciz_dir_to_pathname(&path_buffer[0]);
    }}}

# UP: Füllt Default-Directory in einen Pathname ein.
# use_default_dir(pathname)
# > pathname: nicht-Logical Pathname
# < ergebnis: neuer Pathname, bei dem Directory kein :RELATIVE u.ä. enthält.
#             (kurz: "absoluter Pathname")
# kann GC auslösen
  local object use_default_dir (object pathname);
  local object use_default_dir(pathname)
    var reg3 object pathname;
    { var reg5 boolean resolved_root = FALSE;
      retry:
      # erst den Pathname kopieren:
      pathname = copy_pathname(pathname);
     {var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
      # Ist das Device angegeben, so muß das Directory mit (:ABSOLUTE :ROOT ...)
      # anfangen (oder mit (:RELATIVE ...) - das wird ersetzt).
      if (!nullp(ThePathname(pathname)->pathname_device))
        { if (eq(Car(subdirs),S(Krelative)))
            { pushSTACK(pathname); # pathname retten
              pushSTACK(allocate_cons());
             {var reg1 object new_cons = allocate_cons();
              subdirs = popSTACK();
              pathname = popSTACK(); # pathname zurück
              Car(subdirs) = S(Kabsolute); Cdr(subdirs) = new_cons;
              Car(new_cons) = S(Kroot); Cdr(new_cons) = Cdr(ThePathname(pathname)->pathname_directory);
              ThePathname(pathname)->pathname_directory = subdirs;
            }}
          elif (!(eq(Car(subdirs),S(Kabsolute)) && eq(Car(Cdr(subdirs)),S(Kroot))))
            { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
              pushSTACK(pathname);
              pushSTACK(O(root_string));
              pushSTACK(TheSubr(subr_self)->name);
              fehler(file_error,
                     DEUTSCH ? "~: Ist ein Device angegeben, muß das Directory mit ~ anfangen: ~" :
                     ENGLISH ? "~: If a device is specified, the directory must begin with ~: ~" :
                     FRANCAIS ? "~ : Quand un composant DEVICE est spécifié, le répertoire doit commencer par ~: ~" :
                     ""
                    );
            }
        }
      pushSTACK(pathname); # pathname retten
      {var reg4 object defaults;
       if (eq(Car(subdirs),S(Krelative)))
         { pushSTACK(Cdr(subdirs)); defaults = default_directory(); }
       else # (eq(Car(subdirs),S(Kabsolute)))
         { var reg1 object next = Car(Cdr(subdirs));
           pushSTACK(Cdr(Cdr(subdirs)));
           if (eq(next,S(Kroot))) # :ROOT -> "$." auflösen oder fertig
             { # "$." wird nur dann aufgelöst, wenn Host oder Device noch
               # unbekannt sind, aber nur einmal (um eine Endlosschleife zu
               # verhindern). Ob Host oder Device =NIL sind, ist nämlich
               # nicht so wichtig.
               if (!resolved_root
                   && (nullp(ThePathname(pathname)->pathname_host)
                       || nullp(ThePathname(pathname)->pathname_device)
                  )   )
                 { defaults = canonicalise_dirname(pathname,O(root_string));
                   resolved_root = TRUE;
                 }
               else
                 { goto resolved; }
             }
           elif (eq(next,S(Khome))) # :HOME -> "&." auflösen
             { defaults = canonicalise_dirname(pathname,O(home_string)); }
           elif (eq(next,S(Kcurrent))) # :CURRENT -> "@." auflösen
             { defaults = canonicalise_dirname(pathname,O(current_string)); }
           elif (eq(next,S(Klibrary))) # :LIBRARY -> "%." auflösen
             { defaults = canonicalise_dirname(pathname,O(library_string)); }
           elif (eq(next,S(Kprevious))) # :PREVIOUS -> "\\." auflösen
             { defaults = canonicalise_dirname(pathname,O(previous_string)); }
           else
             { NOTREACHED }
         }
       # Stackaufbau: pathname, rest-subdirs.
       # Nicht ganz so wie bei MERGE-PATHNAMES verfahren:
       # bilde  (append default-subdirs rest-subdirs)
       #      = (nreconc (reverse default-subdirs) rest-subdirs)
       pathname = STACK_1;
       ThePathname(pathname)->pathname_host = ThePathname(defaults)->pathname_host;
       ThePathname(pathname)->pathname_device = ThePathname(defaults)->pathname_device;
       defaults = ThePathname(defaults)->pathname_directory;
       defaults = reverse(defaults); subdirs = nreconc(defaults,popSTACK());
       pathname = popSTACK();
       ThePathname(pathname)->pathname_directory = subdirs;
       # Es könnte sein, daß auch jetzt noch nicht alles aufgelöst ist.
       goto retry;
     }}
     resolved: # Stackaufbau: pathname, subdir-oldlist.
      # Liste durchgehen und dabei neu aufconsen, dabei "^." verarbeiten.
      # (Sonst müßte dies assure_dir_exists() machen.)
      pushSTACK(S(Kroot)); pushSTACK(S(Kabsolute));
      { var reg1 object newlist = listof(2); pushSTACK(newlist); }
      # Stackaufbau: pathname, subdir-oldlist, subdir-newlist.
      while (mconsp(STACK_1)) # Bis oldlist am Ende ist:
        { var reg4 object subdir = Car(STACK_1); # nächstes subdir
          if (eq(subdir,S(Kparent)))
            # = :PARENT -> newlist um eins verkürzen:
            { if (matomp(Cdr(Cdr(STACK_0)))) # newlist (bis auf :ABSOLUTE und :ROOT) leer ?
                { # :PARENT von "$." aus liefert Error
                  pushSTACK(STACK_2); # Wert für Slot PATHNAME von FILE-ERROR
                  pushSTACK(O(root_string)); # "$."
                  pushSTACK(directory_namestring(STACK_(2+2))); # Directory von pathname
                  fehler(file_error,
                         DEUTSCH ? "Directory ~ oberhalb ~ existiert nicht." :
                         ENGLISH ? "no directory ~ above ~" :
                         FRANCAIS ? "Il n'y a pas de répertoire ~ au delà de ~." :
                         ""
                        );
                }
              STACK_0 = Cdr(STACK_0);
            }
          else
            { # newlist um eins verlängern:
              pushSTACK(subdir);
             {var reg1 object new_cons = allocate_cons();
              Car(new_cons) = popSTACK();
              Cdr(new_cons) = STACK_0;
              STACK_0 = new_cons;
            }}
          STACK_1 = Cdr(STACK_1);
        }
     {var reg2 object subdirs = nreverse(popSTACK()); # newlist, wieder umdrehen
      skipSTACK(1);
      pathname = popSTACK();
      ThePathname(pathname)->pathname_directory = subdirs; # in den Pathname eintragen
      return pathname;
    }}

# UP: Liefert den Namestring eines Pathname als ASCIZ-String.
# namestring_asciz(dir_namestring)
# > STACK_0: nicht-Logical Pathname
# > dir_namestring: Directory-Namestring
# < ergebnis: Namestring (für RISCOS, mit Name/Type vertauscht, mit Nullbyte am Schluß)
# kann GC auslösen
  local object namestring_asciz (object dir_namestring);
  local object namestring_asciz(dir_namestring)
    var reg3 object dir_namestring;
    { var reg1 object pathname = STACK_0;
      var reg2 uintC stringcount;
      pushSTACK(dir_namestring); # Directory-Namestring als 1. String
      stringcount = # und Strings zum Filenamen
        (nullp(ThePathname(pathname)->pathname_type)
         ? nametype_namestring_parts(ThePathname(pathname)->pathname_name,
                                     ThePathname(pathname)->pathname_type,
                                     ThePathname(pathname)->pathname_version)
         # Name und Typ vertauschen (der Typ wird zu einem Subdirectory-Namen):
         : nametype_namestring_parts(ThePathname(pathname)->pathname_type,
                                     ThePathname(pathname)->pathname_name,
                                     ThePathname(pathname)->pathname_version)
        );
      pushSTACK(O(null_string)); # und String mit Nullbyte
      return string_concat(1+stringcount+1); # zusammenhängen
    }

# UP: Stellt sicher, daß das Directory eines Pathname existiert.
# Sonst Fehlermeldung.
# assure_dir_exists(tolerantp)
# > STACK_0: absoluter Pathname ohne Wildcards im Directory
# > tolerantp: Flag, ob ein Fehler vermieden werden soll
# < ergebnis:
#     falls Name=NIL: Directory-Namestring (für RISCOS, mit '.' am Schluß)
#     falls Name/=NIL: Namestring (für RISCOS, mit Nullbyte am Schluß)
#     falls tolerantp evtl.: nullobj
# < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
#                                sonst ein Pointer auf eine STAT-Information.
# kann GC auslösen
  local var struct stat * filestatus;
  local object assure_dir_exists (boolean tolerantp);
  local object assure_dir_exists(tolerantp)
    var reg5 boolean tolerantp;
    { var reg4 object pathname = STACK_0;
      var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings für den Host
      stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
     {var reg1 object dir_namestring = string_concat(stringcount); # zusammenhängen
      # Existenztest:
      var struct stat statbuf;
      var reg1 uintL len = TheSstring(dir_namestring)->length;
      ASSERT((len > 0) && (TheSstring(dir_namestring)->data[len-1]=='.'));
      TheSstring(dir_namestring)->data[len-1] = '\0'; # '.' am Schluß durch Nullbyte ersetzen
      begin_system_call();
      if (stat(TheAsciz(dir_namestring),&statbuf) < 0)
        { end_system_call();
          if (tolerantp && (errno==ENOENT)) { return nullobj; }
          OS_error();
        }
      end_system_call();
      TheSstring(dir_namestring)->data[len-1] = '.'; # '.' wieder zurück
      if (!S_ISDIR(statbuf.st_mode)) # gefundene Datei kein Unterdirectory ?
        { if (tolerantp) { return nullobj; }
          fehler_dir_not_exists(dir_namestring);
        }
      # Information zum angesprochenen File holen:
      if (namenullp(STACK_0)) # kein File angesprochen?
        { return dir_namestring; } # ja -> fertig
        else
        { var reg3 object namestring = namestring_asciz(dir_namestring);
          # Information holen:
          local struct stat status;
          begin_system_call();
          if (stat(TheAsciz(namestring),&status) < 0)
            { if (!(errno==ENOENT)) { OS_error(); }
              # File existiert nicht.
              end_system_call();
              filestatus = (struct stat *)NULL; return namestring;
            }
          end_system_call();
          # File existiert.
          if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
            { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
              pushSTACK(whole_namestring(STACK_0));
              pushSTACK(TheSubr(subr_self)->name);
              fehler(file_error,
                     DEUTSCH ? "~: ~ ist ein Directory und kein File." :
                     ENGLISH ? "~: ~ names a directory, not a file" :
                     FRANCAIS ? "~ : ~ est un répertoire et non un fichier." :
                     ""
                    );
            }
          else
            # normales File
            { filestatus = &status; return namestring; }
    }}  }

# Dasselbe unter der Annahme, daß das Directory bereits existiert.
# (Keine Vereinfachung, da wir ja den Truename bestimmen müssen.)
  global object assume_dir_exists (void);
  global object assume_dir_exists()
    { subr_self = L(open); return assure_dir_exists(FALSE); }

# Ein File "name.type" wird dem RISCOS als "type.name" vermittelt, dabei ist
# "type" der Name eines Unterverzeichnisses! Soll ein File "name.type" angelegt
# werden, muß daher zuerst das Unterverzeichnis "type" erzeugt werden.
# prepare_create(pathname);
# > pathname: ein Pathname
# kann GC auslösen
  local void prepare_create (object pathname);
  local object pathname_add_subdir (void);
  local void prepare_create(pathname)
    var reg1 object pathname;
    { if (!nullp(ThePathname(pathname)->pathname_type))
        { # call pathname_add_subdir:
          pushSTACK(pathname); pushSTACK(ThePathname(pathname)->pathname_type);
          pathname = pathname_add_subdir();
          ThePathname(pathname)->pathname_name = NIL;
          ThePathname(pathname)->pathname_type = NIL;
          # call MAKE-DIR if the directory does not exist:
          pushSTACK(subr_self); # subr_self retten
          pushSTACK(pathname);
          if (eq(assure_dir_exists(TRUE),nullobj))
            { funcall(L(make_dir),1); }
          else
            { skipSTACK(1); }
          subr_self = popSTACK(); # subr_self zurück
    }   }

#endif

#ifdef PATHNAME_ATARI
# UP: Setzt das Default-Drive und sein Default-Directory neu.
# change_default();
# > STACK_0: absoluter Pathname, bei dem Name und Typ =NIL sind.
# kann GC auslösen
  local void change_default (void);
  local void change_default()
    { # Default-Directory zu diesem Drive neu setzen:
      var reg3 object alist = get_drive_alist(STACK_0); # Alisteneintrag zu diesem Device
      var reg2 object seriennummer = Car(ThePathname(STACK_0)->pathname_directory);
      {var reg1 object alistr = alist; # Alisteneintrag durchlaufen
       while (consp(alistr=Cdr(alistr)))
         { var reg1 object entry = Car(alistr);
           if (eq(Car(entry),seriennummer))
             { # die gegebene Seriennummer im Alisteneintrag gefunden.
               Cdr(entry) = STACK_0; # (car entry) = seriennummer, (cdr entry) := pathname
               goto default_dir_ok;
             }
      }  }
      # Bisher (auf diesem Drive) unbekannte Diskette.
      pushSTACK(alist); # Alisteneintrag retten
      {var reg1 object new_cons = allocate_cons(); # Neues Cons
       Car(new_cons) = seriennummer; Cdr(new_cons) = STACK_1;
       pushSTACK(new_cons); # (cons seriennummer pathname) retten
       new_cons = allocate_cons(); # neues Cons
       Car(new_cons) = popSTACK();
       # new_cons = (list (cons seriennummer pathname))
       alist = popSTACK();
       # Alisteneintrag um die 1-elementige Liste new_cons erweitern:
       Cdr(new_cons) = Cdr(alist); Cdr(alist) = new_cons;
      }
      default_dir_ok:
      # Default-Drive neu setzen:
      O(default_drive) = ThePathname(STACK_0)->pathname_device;
      # *DEFAULT-PATHNAME-DEFAULTS* neu setzen:
      recalc_defaults_pathname();
    }
#endif
#if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
#if 0 # unbenutzt
# UP: Macht aus einem Directory-Namestring einen, der für DOS geeignet ist.
# OSnamestring(namestring)
# > namestring: neu erzeugter Directory-Namestring, mit '\' am Schluß,
#               ein Simple-String
# < ergebnis: Namestring zu diesem Directory, im DOS-Format: letzter '\'
#             gestrichen, falls überflüssig, ASCIZ-String
# kann GC auslösen
  local object OSnamestring (object namestring);
  local object OSnamestring(namestring)
    var reg1 object namestring;
    { var reg2 uintL len = TheSstring(namestring)->length;
      if (len==0) goto ok; # Leerstring -> nichts streichen
     {var reg3 uintB ch = TheSstring(namestring)->data[len-1];
      if (!(ch=='\\')) goto ok; # kein '\' am Schluß -> nichts streichen
      if (len==1) goto ok; # "\" bedeutet Root -> nicht streichen
      ch = TheSstring(namestring)->data[len-2];
      if ((ch=='\\') || (ch==':')) # davor ein '\' oder ':'
        goto ok; # -> bedeutet Parent -> nicht streichen
      # '\' am Schluß streichen, dann string_to_asciz:
        namestring = copy_string(namestring); # Länge bleibt dabei gleich!
        TheSstring(namestring)->data[len-1] = '\0';
        return namestring;
      ok: # nichts streichen
        return string_to_asciz(namestring);
    }}
#endif
# UP: Setzt das Default-Drive und sein Default-Directory neu.
# change_default();
# > STACK_0: absoluter Pathname, bei dem Device ein String ist und Directory
#     kein :RELATIVE, :CURRENT, :PARENT enthält, und Name und Typ =NIL sind.
# kann GC auslösen
  local void change_default (void);
  local void change_default()
    { # Default-Directory zu diesem Drive neu setzen:
      { var reg1 object pathname = STACK_0;
        var reg3 uintC stringcount =
          directory_namestring_parts(pathname); # Strings fürs Directory
        # ohne überflüssiges '\' am Schluß, aber mit Nullbyte am Schluß
        if (mconsp(Cdr(ThePathname(pathname)->pathname_directory)))
          { STACK_0 = O(null_string); }
          else
          { pushSTACK(O(null_string)); stringcount++; }
       {var reg2 object string = string_concat(stringcount); # zusammenhängen
        # Default-Directory ändern:
        begin_system_call();
        if (!( chdir(TheAsciz(string)) ==0)) { OS_error(); }
        end_system_call();
      }}
      # Default-Drive neu setzen:
      O(default_drive) = ThePathname(STACK_0)->pathname_device;
      # *DEFAULT-PATHNAME-DEFAULTS* neu setzen:
      recalc_defaults_pathname();
    }
#endif
#ifdef PATHNAME_AMIGAOS
# UP: Setzt das Default-Directory neu.
# change_default();
# > STACK_0: absoluter Pathname, bei dem Directory kein :RELATIVE, :CURRENT,
#     :PARENT enthält, und Name und Typ =NIL sind.
# kann GC auslösen
  local void change_default (void);
  extern BPTR orig_dir_lock; # Lock auf das ursprüngliche Verzeichnis
                             # (das gehört nicht uns, nicht freigeben!)
  local void change_default()
    { var reg3 uintC stringcount =
        directory_namestring_parts(STACK_0); # Strings fürs Directory
      var reg2 object dir_namestring = string_concat(stringcount);
      dir_namestring = OSnamestring(dir_namestring); # Asciz, ohne überflüssigen '/' am Schluß
      # Default-Directory ändern:
      set_break_sem_4();
      begin_system_call();
      {var reg1 BPTR lock = Lock(TheAsciz(dir_namestring),ACCESS_READ);
       if (lock==BPTR_NULL) { OS_error(); }
       lock = CurrentDir(lock); # current directory neu setzen
       # Lock zum alten current directory merken bzw. aufgeben:
       if (orig_dir_lock == BPTR_NONE)
         { orig_dir_lock = lock; }
         else
         { UnLock(lock); }
      }
      end_system_call();
      clr_break_sem_4();
    }
#endif
#ifdef PATHNAME_UNIX
# UP: Setzt das Default-Directory neu.
# change_default();
# > STACK_0: absoluter Pathname, bei dem Directory kein :RELATIVE, :CURRENT,
#     :PARENT enthält, und Name und Typ =NIL sind.
# kann GC auslösen
  local void change_default (void);
  local void change_default()
    { var reg2 uintC stringcount = host_namestring_parts(STACK_0); # Strings für den Host
      stringcount += directory_namestring_parts(STACK_0); # Strings fürs Directory
      pushSTACK(O(null_string)); # und Nullbyte
     {var reg1 object string = string_concat(stringcount+1); # zusammenhängen
      # Default-Directory ändern:
      begin_system_call();
      if (!( chdir(TheAsciz(string)) ==0)) { OS_error(); }
      end_system_call();
    }}
#endif
#ifdef PATHNAME_RISCOS
# UP: Setzt das Default-Directory neu.
# change_default();
# > STACK_0: absoluter Pathname, bei dem Name und Typ =NIL sind.
# kann GC auslösen
  local void change_default (void);
  local void change_default()
    { var reg4 object pathname = STACK_0;
      var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings für den Host
      stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
     {var reg1 object dir_namestring = string_concat(stringcount); # zusammenhängen
      var reg3 uintL len = TheSstring(dir_namestring)->length;
      ASSERT((len > 0) && (TheSstring(dir_namestring)->data[len-1]=='.'));
      TheSstring(dir_namestring)->data[len-1] = '\0'; # '.' am Schluß durch Nullbyte ersetzen
      begin_system_call();
      if (!( chdir(TheAsciz(dir_namestring)) ==0)) { OS_error(); }
      end_system_call();
    }}
#endif

LISPFUN(namestring,1,1,norest,nokey,0,NIL)
# (NAMESTRING pathname), CLTL S. 417
# (NAMESTRING pathname t) -> Namestring im externen Format
#   GEMDOS: ohne Seriennummer, mit Default-Directory
#   Unix: mit Default-Directory
  { var reg2 object flag = popSTACK(); # optionales Argument flag
    var reg1 object pathname = coerce_pathname(popSTACK()); # Argument zu einem Pathname machen
    #if defined(PATHNAME_ATARI) || defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
    if (!eq(flag,unbound) && !nullp(flag))
      # flag /= NIL -> fürs Betriebssystem:
      { check_no_wildcards(pathname); # mit Wildcards -> Fehler
        pathname = use_default_dir(pathname); # Default-Directory einfügen
        # (da GEMDOS/Unix/AMIGAOS das Default-Directory von LISP nicht kennt)
        #ifdef PATHNAME_ATARI
        {var reg2 uintC stringcount;
         stringcount = directory_namestring_parts(pathname,TRUE); # Strings fürs Directory
         stringcount += file_namestring_parts(pathname); # Strings für den Filename
         value1 = string_concat(stringcount); # zusammenhängen
        }
        #else
        value1 = whole_namestring(pathname);
        #endif
      }
      else
    #endif
      # normal
      { value1 = whole_namestring(pathname); }
    mv_count=1;
  }

# Fehlermeldung wegen fehlendem Dateinamen
# fehler_noname(pathname);
# > pathname: Pathname
  nonreturning_function(local, fehler_noname, (object pathname));
  local void fehler_noname(pathname)
    var reg1 object pathname;
    { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
      pushSTACK(pathname);
      fehler(file_error,
             DEUTSCH ? "Dateiname muß angegeben werden: ~" :
             ENGLISH ? "no file name given: ~" :
             FRANCAIS ? "Un nom de fichier doit être fourni : ~" :
             ""
            );
    }

# Test, ob ein File existiert:
# if_file_exists(namestring,statement1,statement2);
# > vorausgegangen: assure_dir_exists()
# > im STACK: Pathname, wie nach Ausführung von assure_dir_exists(), Name/=NIL
# > namestring: dessen Namestring als ASCIZ-String
# Falls das File existiert, wird statement1 ausgeführt, sonst statement2.
  #ifdef ATARI
    #define if_file_exists(namestring,statement1,statement2)  \
      {{var reg2 sintW errorcode;                                               \
        errorcode = # Datei zu öffnen versuchen, Modus 0 (Read)                 \
          GEMDOS_open(TheAsciz(namestring),0);                                  \
        if (errorcode == GEMDOS_open_NotFound) # nicht gefunden?                \
          goto not_exists;                                                      \
        if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden   \
        # Nun enthält errorcode das Handle des geöffneten Files.                \
        errorcode = # Datei gleich wieder schließen                             \
          GEMDOS_close(errorcode);                                              \
        if (errorcode < 0) { OS_error(errorcode); } # Error melden             \
       }                                                                        \
       if (TRUE) { statement1; } else { not_exists: statement2; }               \
      }
  #else
    #define if_file_exists(namestring,statement1,statement2)  \
      { if (file_exists(namestring)) { statement1; } else { statement2; } }
    #ifdef MSDOS
      local int access0 (CONST char* path);
      local int access0(path)
        var reg2 CONST char* path;
        { var reg1 int erg;
          begin_system_call();
          erg = access(path,0);
          end_system_call();
          return erg;
        }
      #define file_exists(namestring)  (access0(TheAsciz(namestring))==0)
    #endif
    #ifdef AMIGAOS
      #define file_exists(namestring)  (!(filestatus == (struct FileInfoBlock *)NULL))
    #endif
    #if defined(UNIX) || defined(RISCOS)
      #define file_exists(namestring)  (!(filestatus == (struct stat *)NULL))
    #endif
  #endif

# Fehlermeldung wegen nicht existenter Datei
# fehler_file_not_exists();
# > STACK_0: Pathname
# > subr_self: Aufrufer (ein SUBR)
  nonreturning_function(local, fehler_file_not_exists, (void));
  local void fehler_file_not_exists()
    { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
      pushSTACK(STACK_0); # pathname
      pushSTACK(TheSubr(subr_self)->name);
      fehler(file_error,
             DEUTSCH ? "~: Datei ~ existiert nicht." :
             ENGLISH ? "~: file ~ does not exist" :
             FRANCAIS ? "~ : Le fichier ~ n'existe pas." :
             ""
            );
    }

LISPFUNN(truename,1)
# (TRUENAME pathname), CLTL S. 413
  { var reg1 object pathname = popSTACK(); # pathname-Argument
    if (streamp(pathname))
      # Stream -> extra behandeln:
      { # muß File-Stream sein:
        pathname = as_file_stream(pathname);
        # Streamtyp File-Stream
        value1 = TheStream(pathname)->strm_file_truename;
      }
      else
      { pathname = coerce_pathname(pathname); # zu einem Pathname machen
        check_no_wildcards(pathname); # mit Wildcards -> Fehler
        pathname = use_default_dir(pathname); # Default-Directory einfügen
        pushSTACK(pathname);
       {# Directory muß existieren:
        var reg3 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
        if (namenullp(STACK_0))
          # Kein Name angegeben
          { if (!nullp(ThePathname(STACK_0)->pathname_type))
              { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
                pushSTACK(STACK_0); # pathname
                pushSTACK(TheSubr(subr_self)->name);
                fehler(file_error,
                       DEUTSCH ? "~: Pathname mit TYPE, aber ohne NAME sinnlos: ~" :
                       ENGLISH ? "~: pathname with type but without name makes no sense: ~" :
                       FRANCAIS ? "~ : Un PATHNAME avec TYPE mais sans NAME est insensé: ~" :
                       ""
                      );
              }
            # Kein Name und kein Typ angegeben -> pathname als Ergebnis
          }
          else
          # Name angegeben.
          { # Überprüfe, ob die Datei existiert:
            if_file_exists(namestring, ; , { fehler_file_not_exists(); } );
            # Datei existiert -> Pathname als Wert
          }
        value1 = popSTACK();
      }}
    mv_count=1;
  }

LISPFUNN(probe_file,1)
# (PROBE-FILE filename), CLTL S. 424
  { var reg1 object pathname = popSTACK(); # pathname-Argument
    if (streamp(pathname))
      # Stream -> extra behandeln:
      { # muß File-Stream sein:
        pathname = as_file_stream(pathname);
        # Streamtyp File-Stream -> Truename nehmen:
       {var reg1 uintB flags = TheStream(pathname)->strmflags;
        pathname = TheStream(pathname)->strm_file_truename;
        if (flags & strmflags_open_B) # Datei geöffnet ?
          # ja -> Truename sofort als Ergebnis:
          { value1 = pathname; mv_count=1; return; }
        # nein -> noch testen, ob die Datei zum Truename existiert.
      }}
      else
      { pathname = coerce_pathname(pathname); } # zu einem Pathname machen
    # pathname ist jetzt ein Pathname.
    check_no_wildcards(pathname); # mit Wildcards -> Fehler
    pathname = use_default_dir(pathname); # Default-Directory einfügen
    if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
    # Name angegeben.
    pushSTACK(pathname);
   {# Directory muß existieren:
    var reg3 object namestring = assure_dir_exists(TRUE); # Filename als ASCIZ-String
    if (eq(namestring,nullobj))
      # Pfad zur Datei existiert nicht -> NIL als Wert:
      { skipSTACK(1); value1 = NIL; mv_count=1; return; }
    # Überprüfe, ob die Datei existiert:
    if_file_exists(namestring,
      { value1 = popSTACK(); mv_count=1; }, # Datei existiert -> Pathname als Wert
      { skipSTACK(1); value1 = NIL; mv_count=1; return; } # sonst NIL als Wert
      );
  }}

# UP: Stellt fest, ob eine Datei geöffnet ist.
# openp(pathname)
#if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
# > pathname: absoluter Pathname, ohne Wildcards.
#endif
#ifdef PATHNAME_AMIGAOS
# > pathname: absoluter Pathname, ohne Wildcards, ohne :PARENT
#endif
#ifdef PATHNAME_UNIX
# > pathname: absoluter Pathname, ohne Wildcards, nach Auflösung
#             symbolischer Links
#endif
# < ergebnis: TRUE, falls ein geöffneter File-Stream auf diese Datei existiert.
  local boolean openp (object pathname);
  local boolean openp(pathname)
    var reg2 object pathname;
    { var reg1 object flist = O(open_files); # Liste aller offenen Files durchlaufen
      while (consp(flist))
        { var reg3 object f = Car(flist); # nächster offener Stream
          if_strm_file_p(f, # File-Stream ?
            { if (equal(TheStream(f)->strm_file_truename,pathname))
                { return TRUE; }
            },
            ; );
          flist = Cdr(flist);
        }
      return FALSE;
    }

# Fehlermeldung wegen Löschversuch auf geöffnete Datei
# fehler_delete_open(pathname);
# > pathname: Truename der Datei
  nonreturning_function(local, fehler_delete_open, (object pathname));
  local void fehler_delete_open(pathname)
    var reg1 object pathname;
    { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
      pushSTACK(pathname);
      fehler(file_error,
             DEUTSCH ? "Datei ~ kann nicht gelöscht werden, weil ein File-Stream auf sie geöffnet wurde." :
             ENGLISH ? "cannot delete file ~ since there is file stream open to it" :
             FRANCAIS ? "Le fichier ~ ne peut pas être effacé car il est encore ouvert comme «stream»." :
             ""
            );
    }

LISPFUNN(delete_file,1)
# (DELETE-FILE filename), CLTL S. 424
  { var reg1 object pathname = popSTACK(); # pathname-Argument
    if (streamp(pathname))
      # Stream -> extra behandeln:
      { var object stream = as_file_stream(pathname); # muß File-Stream sein
        # Streamtyp File-Stream.
        # Falls Datei geöffnet, erst Datei schließen:
        if (TheStream(stream)->strmflags & strmflags_open_B) # Datei geöffnet ?
          { stream_close(&stream); }
        # Dann den Truename als zu löschende Datei nehmen:
        pathname = TheStream(stream)->strm_file_truename;
      }
      else
      { pathname = coerce_pathname(pathname); } # zu einem Pathname machen
    # pathname ist jetzt ein Pathname.
    check_no_wildcards(pathname); # mit Wildcards -> Fehler
    pathname = use_default_dir(pathname); # Default-Directory einfügen
    if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
    # Name angegeben.
    pushSTACK(pathname);
   {# Directory muß existieren:
    var reg3 object namestring = assure_dir_exists(TRUE); # Filename als ASCIZ-String
    if (eq(namestring,nullobj))
      # Pfad zur Datei existiert nicht -> Wert NIL
      { skipSTACK(1); value1 = NIL; mv_count=1; return; }
    if (openp(STACK_0)) { fehler_delete_open(STACK_0); } # Keine offenen Dateien löschen!
    # Datei löschen:
    #ifdef ATARI
    {var reg2 sintW errorcode;
     errorcode = # Datei zu löschen versuchen
       GEMDOS_unlink(TheAsciz(namestring));
     if (errorcode == GEMDOS_open_NotFound) # nicht gefunden -> Wert NIL
       { skipSTACK(1); value1 = NIL; mv_count=1; return; }
     if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
    }
    #endif
    #ifdef AMIGAOS
    if (!file_exists(namestring))
      { skipSTACK(1); value1 = NIL; mv_count=1; return; } # File existiert nicht -> Wert NIL
    begin_system_call();
    if (! DeleteFile(TheAsciz(namestring)) ) { OS_error(); }
    end_system_call();
    #endif
    #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
    begin_system_call();
    if (!( unlink(TheAsciz(namestring)) ==0))
      { if (!(errno==ENOENT)) { OS_error(); }
        end_system_call();
        # File existiert nicht -> Wert NIL
        skipSTACK(1); value1 = NIL; mv_count=1; return;
      }
    end_system_call();
    #endif
    # Datei existierte, wurde gelöscht -> Pathname (/=NIL) als Wert
    value1 = popSTACK(); mv_count=1;
  }}

# Fehlermeldung wegen Umbenennungsversuch einer geöffneten Datei
# fehler_rename_open(pathname);
# > pathname: Truename der Datei
  nonreturning_function(local, fehler_rename_open, (object pathname));
  local void fehler_rename_open(pathname)
    var reg1 object pathname;
    { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
      pushSTACK(pathname);
      fehler(file_error,
             DEUTSCH ? "Datei ~ kann nicht umbenannt werden, weil ein File-Stream auf sie geöffnet wurde." :
             ENGLISH ? "cannot rename file ~ since there is file stream open to it" :
             FRANCAIS ? "Le fichier ~ ne peut pas être renommé car il est encore ouvert comme «stream»." :
             ""
            );
    }

# UP: Führt eine Datei-Umbenennung durch.
# rename_file();
# > Stackaufbau: filename, newname, oldpathname.
# < Stackaufbau: filename, newname, oldpathname, newpathname,
#                oldtruename, oldnamestring, newtruename, newnamestring.
  local void rename_file (void);
  local void rename_file()
    { # 1. newpathname := (MERGE-PATHNAMES newname oldpathname)
      { pushSTACK(STACK_1); # newname als 1. Argument
        pushSTACK(STACK_(0+1)); # oldpathname als 2. Argument
        funcall(L(merge_pathnames),2);
        pushSTACK(value1);
      }
      # Stackaufbau: filename, newname, oldpathname, newpathname.
      # 2. oldpathname überprüfen:
      { var reg1 object oldpathname = STACK_1;
        check_no_wildcards(oldpathname); # mit Wildcards -> Fehler
        oldpathname = use_default_dir(oldpathname); # Default-Directory einfügen
        if (namenullp(oldpathname)) { fehler_noname(oldpathname); } # Kein Name angegeben -> Fehler
        # Name angegeben.
        pushSTACK(oldpathname);
       {# Directory muß existieren:
        var reg2 object old_namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
        if (openp(STACK_0)) { fehler_rename_open(STACK_0); } # Keine offenen Dateien umbenennen!
        pushSTACK(old_namestring);
      }}
      # Stackaufbau: filename, newname, oldpathname, newpathname,
      #              oldtruename, oldnamestring.
      # 3. newpathname überprüfen:
      { var reg1 object newpathname = coerce_pathname(STACK_2);
        check_no_wildcards(newpathname); # mit Wildcards -> Fehler
        newpathname = use_default_dir(newpathname); # Default-Directory einfügen
        if (namenullp(newpathname)) { fehler_noname(newpathname); } # Kein Name angegeben -> Fehler
        # Name angegeben.
        pushSTACK(newpathname);
       {# Directory muß existieren:
        var reg2 object new_namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
        pushSTACK(new_namestring);
      }}
      # Stackaufbau: filename, newname, oldpathname, newpathname,
      #              oldtruename, oldnamestring, newtruename, newnamestring.
      # 4. Datei umbenennen:
      #ifdef ATARI
      {var reg1 sintW errorcode;
       errorcode = # Datei umzubenennen versuchen
         GEMDOS_rename(TheAsciz(STACK_2),TheAsciz(STACK_0));
       if (errorcode == GEMDOS_rename_exists) # 'Zugriff verweigert' ?
         # ja -> Datei existiert bereits
         { fehler_file_exists(S(rename_file),STACK_1); }
       if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
      }
      #endif
      #if defined(UNIX) || defined(AMIGAOS) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
      if (file_exists(STACK_0))
        # Datei existiert bereits -> nicht ohne Vorwarnung löschen
        { fehler_file_exists(S(rename_file),STACK_1); }
      # Nun kann gefahrlos umbenannt werden:
      #ifdef PATHNAME_RISCOS
      prepare_create(STACK_4);
      #endif
      begin_system_call();
      #ifdef AMIGAOS
      if (! Rename(TheAsciz(STACK_2),TheAsciz(STACK_0)) ) { OS_error(); }
      #endif
      #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
      if (!( rename(TheAsciz(STACK_2),TheAsciz(STACK_0)) ==0))
        { OS_error(); }
      #endif
      end_system_call();
      #endif
    }

LISPFUNN(rename_file,2)
# (RENAME-FILE filename newname), CLTL S. 423
  { var reg1 object filename = STACK_1; # filename-Argument
    if (streamp(filename))
      # Stream -> extra behandeln:
      { # muß File-Stream sein:
        filename = as_file_stream(filename);
        # Streamtyp File-Stream -> Truename verwenden:
        filename = TheStream(filename)->strm_file_truename;
        pushSTACK(filename);
        # Umbenennen:
        rename_file();
        # Stream aktualisieren:
        filename = STACK_7;
        TheStream(filename)->strm_file_name = STACK_4; # newpathname als neuer Name
        TheStream(filename)->strm_file_truename = STACK_1; # newtruename als neuer Truename
        # Handle etc. unverändert lassen
      }
      else
      { filename = coerce_pathname(filename); # zu einem Pathname machen
        pushSTACK(filename);
        # Umbenennen:
        rename_file();
      }
    value1 = STACK_4; # newpathname als 1. Wert
    value2 = STACK_3; # oldtruename als 2. Wert
    value3 = STACK_1; # newtruename als 3. Wert
    mv_count=3; skipSTACK(8); # 3 Werte
  }

# UP: erzeugt ein File-Stream
# open_file(filename,direction,if_exists,if_not_exists,type,eltype_size)
# > filename: Filename, ein Pathname
# > direction: Modus (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO, 3 = :INPUT-IMMUTABLE)
# > if_exists: :IF-EXISTS-Argument
#         (0 = nichts, 1 = :ERROR, 2 = NIL,
#          3 = :RENAME, 4 = :RENAME-AND-DELETE, 5 = :NEW-VERSION,:SUPERSEDE,
#          6 = :APPEND, 7 = :OVERWRITE)
# > if_not_exists: :IF-DOES-NOT-EXIST-Argument
#         (0 = nichts, 1 = :ERROR, 2 = NIL, 3 = :CREATE)
# > type: nähere Typinfo
#         (STRMTYPE_SCH_FILE oder STRMTYPE_CH_FILE oder
#          STRMTYPE_IU_FILE oder STRMTYPE_IS_FILE)
# > eltype_size: (bei Integer-Streams) Größe der Elemente in Bits,
#         ein Fixnum >0 und <intDsize*uintC_max
# < ergebnis: Stream oder NIL
# kann GC auslösen
  local object open_file (object filename, uintB direction, uintB if_exists, uintB if_not_exists,
                          uintB type, object eltype_size);
  local object open_file(filename,direction,if_exists,if_not_exists,type,eltype_size)
    var reg5 object filename;
    var reg8 uintB direction;
    var reg3 uintB if_exists;
    var reg4 uintB if_not_exists;
    var reg7 uintB type;
    var reg9 object eltype_size;
    { pushSTACK(filename); # Filename retten
      check_no_wildcards(filename); # mit Wildcards -> Fehler
      filename = use_default_dir(filename); # Default-Directory einfügen
      if (namenullp(filename)) { fehler_noname(filename); } # Kein Name angegeben -> Fehler
      pushSTACK(filename); # absPathname retten
      # Stackaufbau: Pathname, absPathname.
      { # Directory muß existieren:
        var reg3 object namestring = # Filename als ASCIZ-String
          assure_dir_exists((direction == 0) && ((if_not_exists % 2) == 0)); # tolerant nur bei :PROBE und if_not_exists = 0 oder 2
        # Stackaufbau: Pathname, Truename.
        # Filename überprüfen und Handle holen:
        var reg2 object handle;
        var reg6 boolean append_flag = FALSE;
        switch (direction)
          { case 0: # Modus ist :PROBE
              if (eq(namestring,nullobj))
                # Pfad zur Datei existiert nicht, und :IF-DOES-NOT-EXIST = nichts oder NIL
                goto ergebnis_NIL;
              #ifdef ATARI
              { # erst mit GEMDOS_open erfragen, ob die Datei existiert:
                var reg1 sintW errorcode;
                errorcode = # Datei zu öffnen versuchen, Modus 0 (Read)
                  GEMDOS_open(TheAsciz(namestring),0);
                if (errorcode == GEMDOS_open_NotFound) # nicht gefunden?
                  # Datei existiert nicht
                  { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                    if (if_not_exists==1) # :ERROR -> Error
                      goto fehler_notfound;
                    if (!(if_not_exists==3)) # nichts oder NIL -> NIL
                      goto ergebnis_NIL;
                    # :CREATE -> Datei mit GEMDOS_create erzeugen (Attribute=0) und schließen:
                    errorcode = GEMDOS_create(TheAsciz(namestring),0);
                  }
                if (errorcode<0) { OS_error(errorcode); } # sonstigen Error melden
                # Datei existiert, errorcode ist das Handle
                # Datei wieder schließen:
                errorcode = GEMDOS_close(errorcode);
                if (errorcode<0) { OS_error(errorcode); } # Error melden
                handle = NIL; # Handle := NIL
                break;
              }
              #endif
              #if defined(UNIX) || defined(AMIGAOS) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
              if (!file_exists(namestring))
                # Datei existiert nicht
                { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                  if (if_not_exists==1) # :ERROR -> Error
                    goto fehler_notfound;
                  if (!(if_not_exists==3)) # nichts oder NIL -> NIL
                    goto ergebnis_NIL;
                  #ifdef PATHNAME_RISCOS
                  pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
                  #endif
                 {# :CREATE -> Datei mit open erzeugen und schließen:
                  #ifdef AMIGAOS
                  var reg1 Handle handle;
                  begin_system_call();
                  handle = Open(TheAsciz(namestring),MODE_NEWFILE);
                  if (handle == Handle_NULL) { OS_error(); } # Error melden
                  # Datei wurde erzeugt, handle ist das Handle.
                  # Datei wieder schließen:
                  (void) Close(handle);
                  end_system_call();
                  #endif
                  #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
                  var reg1 int ergebnis;
                  begin_system_call();
                  #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
                  ergebnis = creat(TheAsciz(namestring),my_open_mask);
                  if (ergebnis<0) { OS_error(); } # Error melden
                  setmode(ergebnis,O_BINARY);
                  #endif
                  #if defined(UNIX) || defined(RISCOS)
                  ergebnis = OPEN(TheAsciz(namestring),
                                  O_WRONLY | O_CREAT | O_TRUNC,
                                  my_open_mask
                                 );
                  if (ergebnis<0) { OS_error(); } # Error melden
                  #endif
                  # Datei wurde erzeugt, ergebnis ist das Handle.
                  # Datei wieder schließen:
                  ergebnis = CLOSE(ergebnis);
                  if (!(ergebnis==0)) { OS_error(); } # Error melden
                  end_system_call();
                  #endif
                }}
              handle = NIL; # Handle := NIL
              break;
              #endif
            case 1: case 3: # Modus ist :INPUT
              #ifdef ATARI
              { # erst mit GEMDOS_open erfragen, ob die Datei existiert:
                var reg1 sintW errorcode;
                errorcode = # Datei zu öffnen versuchen, Modus 0 (Read)
                  GEMDOS_open(TheAsciz(namestring),0);
                if (errorcode == GEMDOS_open_NotFound) # nicht gefunden?
                  # Datei existiert nicht
                  { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                    if (if_not_exists==2) # NIL -> NIL
                      goto ergebnis_NIL;
                    if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
                      goto fehler_notfound;
                    # :CREATE -> Datei mit GEMDOS_create erzeugen (Attribute=0):
                    errorcode = GEMDOS_create(TheAsciz(namestring),0);
                  }
                if (errorcode<0) { OS_error(errorcode); } # sonstigen Error melden
                # Datei existiert, errorcode ist das Handle
                handle = allocate_handle(errorcode); # Handle
                break;
              }
              #endif
              #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
              { # erst mit open erfragen, ob die Datei existiert:
                var reg1 sintW ergebnis;
                # Datei zu öffnen versuchen:
                begin_system_call();
                ergebnis = open(TheAsciz(namestring),O_RDONLY);
                if (ergebnis<0)
                  { if (errno == ENOENT) # nicht gefunden?
                      # Datei existiert nicht
                      { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                        if (if_not_exists==2) # NIL -> NIL
                          goto ergebnis_NIL;
                        if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
                          goto fehler_notfound;
                        # :CREATE -> Datei mit creat erzeugen:
                        ergebnis = creat(TheAsciz(namestring),my_open_mask);
                        if (ergebnis<0) { OS_error(); }
                      }
                      else
                      { OS_error(); } # sonstigen Error melden
                  }
                setmode(ergebnis,O_BINARY);
                end_system_call();
                # Datei existiert, ergebnis ist das Handle
                handle = allocate_handle(ergebnis); # Handle
                break;
              }
              #endif
              #ifdef AMIGAOS
              { # erst mit Open erfragen, ob die Datei existiert:
                var reg1 Handle handl;
                begin_system_call();
                handl = Open(TheAsciz(namestring),MODE_OLDFILE);
                if (handl==Handle_NULL)
                  { if (IoErr()==ERROR_OBJECT_NOT_FOUND)
                      # Datei existiert nicht
                      { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                        if (if_not_exists==2) # NIL -> NIL
                          goto ergebnis_NIL;
                        if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
                          goto fehler_notfound;
                        # :CREATE -> Datei mit Open erzeugen:
                        handl = Open(TheAsciz(namestring),MODE_READWRITE);
                  }   }
                if (handl==Handle_NULL) { OS_error(); } # Error melden
                end_system_call();
                # Datei existiert, handle ist das Handle
                handle = allocate_handle(handl); # Handle als Lisp-Objekt
                break;
              }
              #endif
              #if defined(UNIX) || defined(RISCOS)
              { var reg2 int o_flags = O_RDONLY;
                if (!file_exists(namestring))
                  # Datei existiert nicht
                  { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                    if (if_not_exists==2) # NIL -> NIL
                      goto ergebnis_NIL;
                    if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
                      goto fehler_notfound;
                    # :CREATE -> Datei mit open erzeugen
                    #ifdef PATHNAME_RISCOS
                    pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
                    #endif
                    o_flags |= O_CREAT;
                  }
               {var reg1 int ergebnis;
                begin_system_call();
                ergebnis = OPEN(TheAsciz(namestring),
                                o_flags, # O_RDONLY bzw. O_RDONLY | O_CREAT
                                my_open_mask
                               );
                if (ergebnis<0) { OS_error(); } # Error melden
                end_system_call();
                # Datei existiert, ergebnis ist das Handle
                handle = allocate_handle(ergebnis); # Handle
              }}
              break;
              #endif
            default: # Modus ist :OUTPUT oder :IO
              { # Defaultwert für if_not_exists ist von if_exists abhängig:
                if (if_not_exists==0) # falls if_not_exists nicht angegeben:
                  { if (if_exists<6) # if_exists = :APPEND oder :OVERWRITE -> if_not_exists unverändert
                      { if_not_exists = 3; } # weder :APPEND noch :OVERWRITE -> Default ist :CREATE
                  }
                # Defaultwert für if_exists ist :NEW-VERSION :
                if (if_exists==0) { if_exists = 5; }
                #ifdef ATARI
                # Bei if_exists=5 und if_not_exists=3 kann man sofort
                # CREATE ansteuern, sonst muß man vorher OPEN versuchen:
                if (!((if_exists==5) && (if_not_exists==3)))
                  { var reg1 sintW errorcode;
                    errorcode = # Datei zu öffnen versuchen, Modus 2 (Read/Write)
                      GEMDOS_open(TheAsciz(namestring),2);
                    if (errorcode == GEMDOS_open_NotFound) # nicht gefunden?
                      # Datei existiert nicht
                      { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                        if (if_not_exists<2) # (Default bei :APPEND oder :OVERWRITE) oder :ERROR ?
                          goto fehler_notfound;
                        if (if_not_exists==2) # NIL -> NIL
                          goto ergebnis_NIL;
                        # :CREATE
                      }
                      else
                      if (errorcode<0) { OS_error(errorcode); } # sonstigen Error melden
                      else
                      # Datei existiert, errorcode ist das Handle
                      { # :IF-EXISTS-Argument entscheidet:
                        switch (if_exists)
                          { case 1: # :ERROR -> schließen und Error
                              { errorcode = GEMDOS_close(errorcode);
                                if (errorcode<0) { OS_error(errorcode); } # Error melden
                                goto fehler_exists;
                              }
                            case 2: # NIL -> schließen und NIL
                              { errorcode = GEMDOS_close(errorcode);
                                if (errorcode<0) { OS_error(errorcode); } # Error melden
                                goto ergebnis_NIL;
                              }
                            case 6: # :APPEND
                              append_flag = TRUE; # am Schluß ans Ende positionieren
                            case 7: # :OVERWRITE -> bestehende Datei benutzen
                              handle = allocate_handle(errorcode);
                              goto handle_ok;
                            default: ;
                              # :RENAME, :RENAME-AND-DELETE -> Datei umbenennen und dann neu eröffnen.
                              # :NEW-VERSION, :SUPERSEDE -> Datei auf Länge 0 kürzen.
                          }
                        # In beiden Fällen erst die Datei schließen:
                        errorcode = GEMDOS_close(errorcode);
                        if (errorcode<0) { OS_error(errorcode); } # Error melden
                        if ((if_exists==3) || (if_exists==4))
                          # :RENAME oder :RENAME-AND-DELETE -> umbenennen:
                          { # Truename mit ".BAK" erweitern:
                            var reg1 object filename = STACK_0;
                            if (openp(filename)) { fehler_rename_open(filename); } # Keine offenen Dateien umbenennen!
                            pushSTACK(namestring); # namestring retten
                            # filename := (merge-pathnames ".BAK" filename) :
                            filename = copy_pathname(filename); # kopieren
                            ThePathname(filename)->pathname_type = O(backuptype_string); # mit Extension "BAK"
                            if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien löschen!
                            pushSTACK(filename);
                           {# Directory existiert schon:
                            var reg3 object new_namestring = assume_dir_exists(); # Filename als ASCIZ-String
                            # Datei mit diesem Namen löschen, falls vorhanden:
                            {var reg2 sintW errorcode = # Datei zu löschen versuchen
                               GEMDOS_unlink(TheAsciz(new_namestring));
                             if (!(errorcode == GEMDOS_open_NotFound)) # nicht gefunden -> OK
                               if (errorcode<0) { OS_error(errorcode); } # sonstigen Error melden
                            }
                            # Datei vom alten auf diesen Namen umbenennen:
                            skipSTACK(1);
                            namestring = popSTACK(); # namestring zurück
                            {var reg2 sintW errorcode = # Datei umbenennen
                               GEMDOS_rename(TheAsciz(namestring),TheAsciz(new_namestring));
                             if (errorcode<0) { OS_error(errorcode); } # Error melden
                            }
                            # :RENAME-AND-DELETE -> löschen:
                            if (if_exists==4)
                              {var reg2 sintW errorcode =
                                 GEMDOS_unlink(TheAsciz(new_namestring));
                               if (errorcode<0) { OS_error(errorcode); } # Error melden
                              }
                          }}
                      }
                  }
                # Datei mit CREATE erzeugen:
                { var reg1 sintW errorcode = # erzeugen (Attribute=0)
                    GEMDOS_create(TheAsciz(namestring),0);
                  if (errorcode<0) { OS_error(errorcode); } # Error melden
                  # Datei neu erzeugt, errorcode ist das Handle
                  handle = allocate_handle(errorcode);
                }
                #endif
                #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
                # Bei if_exists=5 und if_not_exists=3 kann man sofort
                # CREAT ansteuern, sonst muß man vorher OPEN versuchen:
                if (!((if_exists==5) && (if_not_exists==3)))
                  { begin_system_call();
                   {var reg1 sintW ergebnis = # Datei zu öffnen versuchen
                      open(TheAsciz(namestring),O_RDWR);
                    if (ergebnis<0)
                      { end_system_call();
                        if (errno == ENOENT) # nicht gefunden?
                          # Datei existiert nicht
                          { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                            if (if_not_exists<2) # (Default bei :APPEND oder :OVERWRITE) oder :ERROR ?
                              goto fehler_notfound;
                            if (if_not_exists==2) # NIL -> NIL
                              goto ergebnis_NIL;
                            # :CREATE
                          }
                          else
                          { OS_error(); } # sonstigen Error melden
                      }
                      else
                      # Datei existiert, ergebnis ist das Handle
                      { # :IF-EXISTS-Argument entscheidet:
                        switch (if_exists)
                          { case 1: # :ERROR -> schließen und Error
                              { if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
                                end_system_call();
                                goto fehler_exists;
                              }
                            case 2: # NIL -> schließen und NIL
                              { if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
                                end_system_call();
                                goto ergebnis_NIL;
                              }
                            case 6: # :APPEND
                              append_flag = TRUE; # am Schluß ans Ende positionieren
                            case 7: # :OVERWRITE -> bestehende Datei benutzen
                              setmode(ergebnis,O_BINARY);
                              end_system_call();
                              handle = allocate_handle(ergebnis);
                              goto handle_ok;
                            default: ;
                              # :RENAME, :RENAME-AND-DELETE -> Datei umbenennen und dann neu eröffnen.
                              # :NEW-VERSION, :SUPERSEDE -> Datei auf Länge 0 kürzen.
                          }
                        # In beiden Fällen erst die Datei schließen:
                        if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
                        end_system_call();
                        if ((if_exists==3) || (if_exists==4))
                          # :RENAME oder :RENAME-AND-DELETE -> umbenennen:
                          { # Truename mit ".BAK" erweitern:
                            var reg1 object filename = STACK_0;
                            if (openp(filename)) { fehler_rename_open(filename); } # Keine offenen Dateien umbenennen!
                            pushSTACK(namestring); # namestring retten
                            # filename := (merge-pathnames ".BAK" filename) :
                            filename = copy_pathname(filename); # kopieren
                            ThePathname(filename)->pathname_type = O(backuptype_string); # mit Extension "BAK"
                            if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien löschen!
                            pushSTACK(filename);
                           {# Directory existiert schon:
                            var reg3 object new_namestring = assume_dir_exists(); # Filename als ASCIZ-String
                            # Datei mit diesem Namen löschen, falls vorhanden:
                            begin_system_call();
                            if ( unlink(TheAsciz(new_namestring)) <0) # Datei zu löschen versuchen
                              { if (!(errno==ENOENT)) # nicht gefunden -> OK
                                  { OS_error(); } # sonstigen Error melden
                              }
                            end_system_call();
                            # Datei vom alten auf diesen Namen umbenennen:
                            skipSTACK(1);
                            namestring = popSTACK(); # namestring zurück
                            begin_system_call();
                            if ( rename(TheAsciz(namestring),TheAsciz(new_namestring)) <0) # Datei umbenennen
                              { OS_error(); } # Error melden
                            end_system_call();
                            # :RENAME-AND-DELETE -> löschen:
                            if (if_exists==4)
                              { begin_system_call();
                                if ( unlink(TheAsciz(new_namestring)) <0)
                                  { OS_error(); } # Error melden
                                end_system_call();
                              }
                          }}
                      }
                  }}
                # Datei mit CREAT erzeugen:
                begin_system_call();
                { var reg1 sintW ergebnis = # erzeugen
                    creat(TheAsciz(namestring),my_open_mask);
                  if (ergebnis<0) { OS_error(); } # Error melden
                  setmode(ergebnis,O_BINARY);
                  end_system_call();
                  # Datei neu erzeugt, ergebnis ist das Handle
                  handle = allocate_handle(ergebnis);
                }
                #endif
                #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
                if (file_exists(namestring))
                  # Datei existiert
                  { # :IF-EXISTS-Argument entscheidet:
                    switch (if_exists)
                      { case 1: # :ERROR -> Error
                          goto fehler_exists;
                        case 2: # NIL -> NIL
                          goto ergebnis_NIL;
                        case 3: case 4: # :RENAME oder :RENAME-AND-DELETE -> umbenennen:
                          #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
                          { # Truename mit "%" bzw. ".bak" bzw. "~" erweitern:
                            var reg1 object filename = STACK_0;
                            var reg3 object new_namestring;
                            if (openp(filename)) { fehler_rename_open(filename); } # Keine offenen Dateien umbenennen!
                            pushSTACK(namestring); # namestring retten
                            #if defined(UNIX) || defined(AMIGAOS)
                            # filename := (parse-namestring (concatenate 'string (namestring filename) "%")) :
                            filename = whole_namestring(filename); # als String
                            pushSTACK(filename); pushSTACK(O(backupextend_string)); # "%"
                            filename = string_concat(2); # dazuhängen
                            pushSTACK(filename); # retten
                            filename = coerce_pathname(filename); # wieder als Filename
                            if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien löschen!
                            # Directory existiert schon. Hier keine weiteren Links verfolgen.
                            new_namestring = string_to_asciz(popSTACK()); # Filename als ASCIZ-String
                            #endif
                            #ifdef RISCOS
                            # Dem Namen ein "~" voranstellen:
                            filename = copy_pathname(filename);
                            pushSTACK(filename);
                            pushSTACK(O(backupprepend_string)); pushSTACK(ThePathname(filename)->pathname_name);
                            { var reg1 object new_name = string_concat(2);
                              filename = STACK_0;
                              ThePathname(filename)->pathname_name = new_name;
                            }
                            if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien löschen!
                            new_namestring = assure_dir_exists(FALSE);
                            skipSTACK(1);
                            #endif
                            # Datei (oder Link) mit diesem Namen löschen, falls vorhanden:
                            #if defined(AMIGAOS)
                            begin_system_call();
                            if (! DeleteFile(TheAsciz(new_namestring)) )
                              { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); } # Error melden
                                # nicht gefunden -> OK
                              }
                            end_system_call();
                            #endif
                            #if (defined(UNIX) && 0) || defined(RISCOS) # Das tut UNIX nachher automatisch, RISCOS aber nicht
                            begin_system_call();
                            if (!( unlink(TheAsciz(new_namestring)) ==0))
                              { if (!(errno==ENOENT)) { OS_error(); } # Error melden
                                # nicht gefunden -> OK
                              }
                            end_system_call();
                            #endif
                            # Datei vom alten auf diesen Namen umbenennen:
                            namestring = popSTACK(); # namestring zurück
                            begin_system_call();
                            #ifdef AMIGAOS
                            if (! Rename(TheAsciz(namestring),TheAsciz(new_namestring)) )
                              { OS_error(); }
                            #endif
                            #if defined(UNIX) || defined(RISCOS)
                            if (!( rename(TheAsciz(namestring),TheAsciz(new_namestring)) ==0))
                              { OS_error(); }
                            #endif
                            # :RENAME-AND-DELETE -> löschen:
                            if (if_exists==4)
                              {
                                #ifdef AMIGAOS
                                if (! DeleteFile(TheAsciz(new_namestring)) )
                                  { OS_error(); }
                                #endif
                                #if defined(UNIX) || defined(RISCOS)
                                if (!( unlink(TheAsciz(new_namestring)) ==0))
                                  { OS_error(); }
                                #endif
                              }
                            end_system_call();
                          }
                          #endif
                          break;
                        case 6: # :APPEND
                          append_flag = TRUE; # am Schluß ans Ende positionieren
                        default: ;
                          # :OVERWRITE -> bestehende Datei benutzen
                          # :NEW-VERSION, :SUPERSEDE -> Datei auf Länge 0 kürzen.
                  }   }
                  else
                  # Datei existiert nicht
                  { # :IF-DOES-NOT-EXIST-Argument entscheidet:
                    if (if_not_exists<2) # (Default bei :APPEND oder :OVERWRITE) oder :ERROR ?
                      goto fehler_notfound;
                    if (if_not_exists==2) # NIL -> NIL
                      goto ergebnis_NIL;
                    # :CREATE
                  }
                #ifdef PATHNAME_RISCOS
                pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
                #endif
                # Datei mit open öffnen:
                { # if-exists-Handling: bei if_exists<=5 Inhalt löschen,
                  # sonst (bei :APPEND, :OVERWRITE) bestehenden Inhalt lassen.
                  # if-not-exists-Handling: neue Datei erzeugen.
                  #ifdef AMIGAOS
                  var reg1 Handle handl;
                  begin_system_call();
                  handl = Open(TheAsciz(namestring),
                               (if_exists<=5 ? MODE_NEWFILE : MODE_READWRITE)
                              );
                  if (handl==Handle_NULL) { OS_error(); } # Error melden
                  end_system_call();
                  handle = allocate_handle(handl);
                  #endif
                  #if defined(UNIX) || defined(RISCOS)
                  var reg1 int ergebnis;
                  begin_system_call();
                  ergebnis = OPEN(TheAsciz(namestring),
                                  (if_exists<=5 ? O_RDWR | O_CREAT | O_TRUNC
                                                : O_RDWR | O_CREAT
                                  ),
                                  my_open_mask
                                 );
                  if (ergebnis<0) { OS_error(); } # Error melden
                  end_system_call();
                  # Datei wurde geöffnet, ergebnis ist das Handle.
                  handle = allocate_handle(ergebnis);
                  #endif
                }
                #endif
                break;
              }
            ergebnis_NIL: # Ergebnis NIL
              skipSTACK(2); # beide Pathnames vergessen
              return NIL;
            fehler_notfound: # Fehler, da Datei nicht gefunden
              # STACK_0 = Truename, Wert für Slot PATHNAME von FILE-ERROR
              pushSTACK(STACK_0);
              fehler(file_error,
                     DEUTSCH ? "Eine Datei mit Namen ~ existiert nicht." :
                     ENGLISH ? "file ~ does not exist" :
                     FRANCAIS ? "Un fichier de nom ~ n'existe pas." :
                     ""
                    );
            fehler_exists: # Fehler, da Datei bereits existiert
              # STACK_0 = Truename, Wert für Slot PATHNAME von FILE-ERROR
              pushSTACK(STACK_0);
              fehler(file_error,
                     DEUTSCH ? "Eine Datei mit Namen ~ existiert bereits." :
                     ENGLISH ? "a file named ~ already exists" :
                     FRANCAIS ? "Un fichier de nom ~ existe déjà." :
                     ""
                    );
          }
        handle_ok:
        # handle und append_flag sind jetzt fertig.
        # Stream erzeugen:
        return make_file_stream(handle,direction,type,eltype_size,append_flag);
    } }

LISPFUN(open,1,0,norest,key,4,\
        (kw(direction),kw(element_type),kw(if_exists),kw(if_does_not_exist)) )
# (OPEN filename :direction :element-type :if-exists :if-does-not-exist),
# CLTL S. 418
  { var reg2 object filename = STACK_4; # filename
    if (streamp(filename))
      { # muß File-Stream sein:
        filename = as_file_stream(filename);
        # Streamtyp File-Stream -> Truename verwenden:
        filename = TheStream(filename)->strm_file_truename;
      }
      else
      { filename = coerce_pathname(filename); } # zu einem Pathname machen
    # filename ist jetzt ein Pathname.
   {var reg3 uintB direction;
    var reg4 uintB if_exists;
    var reg5 uintB if_not_exists;
    var reg6 uintB type;
    var reg7 object eltype_size = NIL;
    # :direction überprüfen und in direction übersetzen:
    { var reg1 object arg = STACK_3;
      if (eq(arg,unbound) || eq(arg,S(Kinput))) { direction = 1; }
      elif (eq(arg,S(Kinput_immutable))) { direction = 3; }
      elif (eq(arg,S(Koutput))) { direction = 4; }
      elif (eq(arg,S(Kio))) { direction = 5; }
      elif (eq(arg,S(Kprobe))) { direction = 0; }
      else
      { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(O(type_direction)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(arg); pushSTACK(S(open));
        fehler(type_error,
               DEUTSCH ? "~: Als :DIRECTION-Argument ist ~ unzulässig." :
               ENGLISH ? "~: illegal :DIRECTION argument ~" :
               FRANCAIS ? "~ : ~ n'est pas permis comme argument pour :DIRECTION." :
               ""
              );
    } }
    # :element-type überprüfen und in type und eltype_size übersetzen:
    { var reg1 object arg = STACK_2;
      if (eq(arg,unbound) || eq(arg,S(string_char)) || eq(arg,S(Kdefault))) # STRING-CHAR, :DEFAULT
        { type = strmtype_sch_file; }
      elif (eq(arg,S(character))) # CHARACTER
        { type = strmtype_ch_file; }
      elif (eq(arg,S(bit))) # BIT
        { type = strmtype_iu_file; eltype_size = Fixnum_1; }
      elif (eq(arg,S(unsigned_byte))) # UNSIGNED-BYTE
        { type = strmtype_iu_file; eltype_size = fixnum(8); }
      elif (eq(arg,S(signed_byte))) # SIGNED-BYTE
        { type = strmtype_is_file; eltype_size = fixnum(8); }
      elif (consp(arg) && mconsp(Cdr(arg)) && nullp(Cdr(Cdr(arg)))) # zweielementige Liste
        { var reg2 object h = Car(arg);
          if (eq(h,S(mod))) # (MOD n)
            { type = strmtype_iu_file;
              h = Car(Cdr(arg)); # n
              # muß ein Integer >0 sein:
              if (!(integerp(h) && positivep(h) && !eq(h,Fixnum_0)))
                goto bad_eltype;
              # eltype_size := (integer-length (1- n)) bilden:
              pushSTACK(filename); # filename retten
              pushSTACK(h); funcall(L(einsminus),1); # (1- n)
              pushSTACK(value1); funcall(L(integer_length),1); # (integer-length (1- n))
              eltype_size = value1;
              filename = popSTACK(); # filename zurück
            }
          elif (eq(h,S(unsigned_byte))) # (UNSIGNED-BYTE n)
            { type = strmtype_iu_file;
              eltype_size = Car(Cdr(arg));
            }
          elif (eq(h,S(signed_byte))) # (SIGNED-BYTE n)
            { type = strmtype_is_file;
              eltype_size = Car(Cdr(arg));
            }
          else goto bad_eltype;
          # eltype_size überprüfen:
          if (!(posfixnump(eltype_size) && !eq(eltype_size,Fixnum_0)
                && ((oint_data_len < log2_intDsize+intCsize) # (Bei oint_data_len <= log2(intDsize)+intCsize-1
                    # ist stets eltype_size < 2^oint_data_len < intDsize*(2^intCsize-1).)
                    || (as_oint(eltype_size) < as_oint(fixnum(intDsize*(uintL)(bitm(intCsize)-1))))
             ) )   )
            goto bad_eltype;
        }
      else
        { bad_eltype:
          pushSTACK(STACK_2); pushSTACK(S(open));
          fehler(error, # type_error ??
                 DEUTSCH ? "~: Als :ELEMENT-TYPE-Argument ist ~ unzulässig." :
                 ENGLISH ? "~: illegal :ELEMENT-TYPE argument ~" :
                 FRANCAIS ? "~ : ~ n'est pas permis comme argument pour :ELEMENT-TYPE." :
                 ""
                );
    }   }
    # :if-exists überprüfen und in if_exists übersetzen:
    { var reg1 object arg = STACK_1;
      if (eq(arg,unbound)) { if_exists = 0; }
      elif (eq(arg,S(Kerror))) { if_exists = 1; }
      elif (eq(arg,NIL)) { if_exists = 2; }
      elif (eq(arg,S(Krename))) { if_exists = 3; }
      elif (eq(arg,S(Krename_and_delete))) { if_exists = 4; }
      elif (eq(arg,S(Knew_version)) || eq(arg,S(Ksupersede))) { if_exists = 5; }
      elif (eq(arg,S(Kappend))) { if_exists = 6; }
      elif (eq(arg,S(Koverwrite))) { if_exists = 7; }
      else
      { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(O(type_if_exists)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(arg); pushSTACK(S(open));
        fehler(type_error,
               DEUTSCH ? "~: Als :IF-EXISTS-Argument ist ~ unzulässig." :
               ENGLISH ? "~: illegal :IF-EXISTS argument ~" :
               FRANCAIS ? "~ : ~ n'est pas permis comme argument pour :IF-EXISTS." :
               ""
              );
    } }
    # :if-does-not-exist überprüfen und in if_not_exists übersetzen:
    { var reg1 object arg = STACK_0;
      if (eq(arg,unbound)) { if_not_exists = 0; }
      elif (eq(arg,S(Kerror))) { if_not_exists = 1; }
      elif (eq(arg,NIL)) { if_not_exists = 2; }
      elif (eq(arg,S(Kcreate))) { if_not_exists = 3; }
      else
      { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(O(type_if_does_not_exist)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(arg); pushSTACK(S(open));
        fehler(type_error,
               DEUTSCH ? "~: Als :IF-DOES-NOT-EXIST-Argument ist ~ unzulässig." :
               ENGLISH ? "~: illegal :IF-DOES-NOT-EXIST argument ~" :
               FRANCAIS ? "~ : ~ n'est pas permis comme argument pour :IF-DOES-NOT-EXIST." :
               ""
              );
    } }
    # File öffnen:
    skipSTACK(5);
    value1 = open_file(filename,direction,if_exists,if_not_exists,type,eltype_size);
    mv_count=1;
  }}

# UP: Liefert eine Liste aller matchenden Pathnames.
# directory_search(pathname)
# > pathname: Pathname mit Device /= :WILD
#ifdef UNIX
# > STACK_1: Circle-Flag
#endif
# > STACK_0: Full-Flag
# < ergebnis:
#     Falls name=NIL und type=NIL:     Liste aller matchenden Directories,
#     sonst (name=NIL -> name=:WILD):  Liste aller matchenden Dateien.
#     Jeweils als absoluter Pathname ohne Wildcards,
#     bzw. bei Dateien und Full-Flag /=NIL als Liste
#          (Pathname Write-Date Length)
#          mit  Pathname ohne :WILD/:WILD-INFERIORS-Komponenten,
#               Write-Date = Datum der Dateierstellung (ss mm hh dd mm yy),
#                 als Decoded-Time passend für ENCODE-UNIVERSAL-TIME,
#               Length = Länge der Datei (in Bytes).
# kann GC auslösen
  local object directory_search (object pathname);
  # Methode: Breadth-first-search, damit nur eine Suchoperation gleichzeitig
  # läuft (und auf dem ATARI nur 1 DTA-Buffer gebraucht wird).
  #
  #ifdef PATHNAME_EXT83
  #
  #ifdef WATCOM
    # Die findfirst/findnext-Routinen sollen gefälligst errno setzen:
    local int findfirst (const char * path, struct ffblk * buf, unsigned int attr);
    local int findnext (struct ffblk * buf);
    local int findfirst(path,buf,attr)
      var reg2 const char * path;
      var reg3 struct ffblk * buf;
      var reg4 unsigned int attr;
      { var reg1 unsigned int result = _dos_findfirst(path,attr,buf);
        if (result==0)
          { return 0; } # kein Error
          else
          { errno = result; # = _doserrno;
            return -1; # Error
      }   }
    local int findnext(buf)
      var reg2 struct ffblk * buf;
      { var reg1 unsigned int result = _dos_findnext(buf);
        if (result==0)
          { return 0; } # kein Error
          else
          { errno = result; # = _doserrno;
            return -1; # Error
      }   }
  #endif
  #
  # UP: Extrahiert Name und Typ aus dem DTA-Buffer.
  # Es wird angenommen, daß Name und Typ aus zulässigen Großbuchstaben
  # bestehen und eine Länge <= 8 bzw. 3 haben.
  # > asciz: Adresse des ASCIZ-Strings im DTA-Buffer
  # > def: Default-Typ
  # < -(STACK): Typ
  # < -(STACK): Name
  # Erniedrigt STACK um 2.
  # kann GC auslösen
    local void extract (const uintB* asciz, object def);
    local void extract(asciz,def)
      var reg3 const uintB* asciz;
      var reg4 object def;
      { pushSTACK(def); # Default-Typ in den Stack
       {# in Name.Typ aufspalten:
        var reg1 const uintB* ptr = asciz;
        var reg2 uintL count = 0;
        loop
          { var reg3 uintB ch = *ptr; # nächstes Zeichen
            if ((ch == 0) || (ch == '.')) # bei Nullbyte oder '.'
              break; # ist der Name zu Ende
            ptr++; count++; # weiterrücken
          }
        pushSTACK(make_string(asciz,count)); # String für Name erzeugen
        if (*ptr++ == 0) # mit Nullbyte beendet ?
          ; # ja -> Typ bleibt Default
          else
          { asciz = ptr; count = 0;
            until (*ptr++ == 0) { count++; } # bei Nullbyte ist der Typ zu Ende
            STACK_1 = make_string(asciz,count); # String für Typ erzeugen
          }
      }}
  #
  # UP: Sucht Subdirectories eines gegebenen Pathname.
  # subdirs(pathstring)
  # STACK_0 = Pathname, dessen Subdirectories zu suchen sind
  # STACK_1 = Liste, auf die die Pathnames der matchenden Subdirectories
  #           gepusht werden
  # > pathstring: Suchpfad als fertiger ASCIZ-String
  # verändert STACK_1, kann GC auslösen
    local void subdirs (object pathstring);
    local void subdirs(pathstring)
      var reg3 object pathstring;
      {
       #ifdef ATARI
        # Dateisuche gemäß GEMDOS-Konvention:
        var reg2 sintW errorcode;
        set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
        GEMDOS_SetDTA(&DTA_buffer); # DTA-Buffer setzen
        # Suchanfang, die Maske 0x10 sucht nach Ordnern und normalen Dateien:
        errorcode =
          GEMDOS_Sfirst(TheAsciz(pathstring),0x10);
        if (!(errorcode == GEMDOS_Sfirst_notfound)) # 'Keine Datei gefunden' ?
          # ja -> Schleife nicht durchlaufen
          loop
            { if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
              # Stackaufbau: new-pathname-list, pathname.
              # gefundene Datei untersuchen:
              if (DTA_buffer.d_attrib & 0x10) # sollte ein Unterdirectory sein
                if (!(DTA_buffer.d_fname[0] == '.')) # sollte nicht mit '.' anfangen
                  # (sonst ist es wohl '.' oder '..', wird übergangen)
                  { # in Name.Typ aufspalten, Default-Typ "" :
                    extract(&DTA_buffer.d_fname[0],O(leer_string));
                   {var reg1 object new_cons = allocate_cons();
                    Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
                    # new_cons = (name . type)
                    pushSTACK(new_cons);
                    new_cons = allocate_cons();
                    Car(new_cons) = popSTACK();
                    # in ein-elementiger Liste new_cons = list1 = ((name . type))
                    pushSTACK(new_cons);
                   }# Stackaufbau: new-pathname-list, pathname, list1.
                    # letzten Pathname kopieren:
                   {var reg1 object temp = copy_pathname(STACK_1);
                    pushSTACK(temp);
                    # und darin Directory um list1 = ((name . type)) verlängern:
                    # (append pathname-dir list1) = (nreconc (reverse pathname-dir) list1)
                    temp = reverse(ThePathname(temp)->pathname_directory);
                    temp = nreconc(temp,STACK_1);
                    ThePathname(STACK_0)->pathname_directory = temp;
                   }# Stackaufbau: new-pathname-list, pathname, list1, newpathname.
                    # newpathname auf die Liste new-pathname-list pushen:
                   {var reg1 object new_cons = allocate_cons();
                    Car(new_cons) = popSTACK(); skipSTACK(1);
                    Cdr(new_cons) = STACK_1; STACK_1 = new_cons;
                  }}
              # nächstes File:
              errorcode = GEMDOS_Snext();
              if (errorcode == GEMDOS_Snext_notfound) # 'Keine weitere Datei gefunden' ?
                break; # ja -> Schleifenende
            }
        clr_break_sem_4();
       #endif
       #ifdef MSDOS
        # Dateisuche gemäß DOS-Konvention:
        var struct ffblk DTA_buffer;
        set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
        # Suchanfang, suche nach Ordnern und normalen Dateien:
        begin_system_call();
        if (findfirst(TheAsciz(pathstring),&DTA_buffer,FA_DIREC|FA_ARCH|FA_RDONLY) <0)
          { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); } }
          else # Keine Datei gefunden -> Schleife nicht durchlaufen
          loop
            { # Stackaufbau: new-pathname-list, pathname.
              end_system_call();
              # gefundene Datei untersuchen:
              if (DTA_buffer.ff_attrib & FA_DIREC) # sollte ein Unterdirectory sein
                if (!(DTA_buffer.ff_name[0] == '.')) # sollte nicht mit '.' anfangen
                  # (sonst ist es wohl '.' oder '..', wird übergangen)
                  { # in Name.Typ aufspalten, Default-Typ "" :
                    extract(&DTA_buffer.ff_name[0],O(leer_string));
                   {var reg1 object new_cons = allocate_cons();
                    Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
                    # new_cons = (name . type)
                    pushSTACK(new_cons);
                    new_cons = allocate_cons();
                    Car(new_cons) = popSTACK();
                    # in ein-elementiger Liste new_cons = list1 = ((name . type))
                    pushSTACK(new_cons);
                   }# Stackaufbau: new-pathname-list, pathname, list1.
                    # letzten Pathname kopieren:
                   {var reg1 object temp = copy_pathname(STACK_1);
                    pushSTACK(temp);
                    # und darin Directory um list1 = ((name . type)) verlängern:
                    # (append pathname-dir list1) = (nreconc (reverse pathname-dir) list1)
                    temp = reverse(ThePathname(temp)->pathname_directory);
                    temp = nreconc(temp,STACK_1);
                    ThePathname(STACK_0)->pathname_directory = temp;
                   }# Stackaufbau: new-pathname-list, pathname, list1, newpathname.
                    # newpathname auf die Liste new-pathname-list pushen:
                   {var reg1 object new_cons = allocate_cons();
                    Car(new_cons) = popSTACK(); skipSTACK(1);
                    Cdr(new_cons) = STACK_1; STACK_1 = new_cons;
                  }}
              # nächstes File:
              begin_system_call();
              if (findnext(&DTA_buffer) <0)
                { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); }
                  break; # Keine weitere Datei -> Schleifenende
                }
            }
        end_system_call();
        clr_break_sem_4();
       #endif
      }
  #
  # UP: Sucht alle Subdirectories (beliebiger Tiefe) eines gegebenen Pathname.
  # allsubdirs(pathnamelist)
  # > pathnamelist: Liste, dessen CAR der gegebene Pathname ist.
  # Die Pathnames aller echten Subdirectories (beliebiger Tiefe) werden als
  # Liste destruktiv zwischen pathnamelist und (cdr pathnamelist) gehängt.
  # < ergebnis: das ursprüngliche (cdr pathnamelist)
  # kann GC auslösen
    local object allsubdirs (object pathnamelist);
    local object allsubdirs(pathnamelist)
      var reg1 object pathnamelist;
      { pushSTACK(pathnamelist);
        pushSTACK(NIL); # new-pathname-list := NIL
        {var reg2 object pathname = Car(pathnamelist);
         pushSTACK(pathname);
         # Stackaufbau: pathnamelist, new-pathname-list, pathname.
         {var reg3 uintC stringcount =
            directory_namestring_parts_(pathname); # Directory-Namestring-Teile,
          pushSTACK(O(wild_wild_string)); # "*.*"
          pushSTACK(O(null_string)); # und Nullbyte
          {var reg4 object pathstring = string_concat(stringcount+1+1); # zusammenhängen
           subdirs(pathstring); # alle subdirs auf new-pathname-list pushen
        }}}
        skipSTACK(1); # pathname vergessen
        { var reg2 object new_pathname_list = popSTACK();
          pathnamelist = popSTACK();
          # Stackaufbau: (leer).
          # Mit  (setf (cdr pathnamelist)
          #            (nreconc new-pathname-list (cdr pathnamelist))
          #      )
          # die new-pathname-list umdrehen und gleichzeitig einhängen:
          new_pathname_list = nreconc(new_pathname_list,Cdr(pathnamelist));
          pushSTACK(Cdr(pathnamelist)); Cdr(pathnamelist) = new_pathname_list;
          pathnamelist = new_pathname_list;
        }
        # Stackaufbau: ursprüngliches (cdr pathnamelist).
        # Liste pathnamelist durchlaufen, bis bei STACK_0 angelangt,
        # und rekursiv alle Subdirectories bestimmen und einhängen:
        until (eq(pathnamelist,STACK_0))
          { pathnamelist = allsubdirs(pathnamelist); }
        skipSTACK(1);
        return pathnamelist;
      }
  #
  local object directory_search(pathname)
    var reg4 object pathname;
    { pathname = use_default_dir(pathname); # Default-Directory einfügen
      # pathname ist jetzt ein Pathname, bei dem Device ein überprüfter
      # String ist und Directory [die Seriennummer, aber] kein
      # :RELATIVE, :CURRENT, :PARENT enthält.
      pushSTACK(pathname);
      #if HAS_SERNR
      pushSTACK(Cdr(ThePathname(pathname)->pathname_directory)); # subdir-list
      #else
      pushSTACK(ThePathname(pathname)->pathname_directory); # subdir-list
      #endif
      # pathname kopieren:
      pushSTACK(copy_pathname(pathname));
      # und dessen Directory auf ([Seriennummer] :ABSOLUTE) verkürzen:
      {var reg1 object new_cons = allocate_cons(); # neues Cons mit CDR=NIL
       Car(new_cons) = S(Kabsolute); # :ABSOLUTE als CAR
       #if HAS_SERNR
       pushSTACK(new_cons);
       new_cons = allocate_cons(); # neues Cons
       Cdr(new_cons) = popSTACK(); # mit anderem Cons als CDR
       Car(new_cons) = Car(ThePathname(STACK_0)->pathname_directory); # und Seriennummer als CAR
       #endif
       ThePathname(STACK_0)->pathname_directory = new_cons;
      }
      # und in einelementige Liste packen:
      {var reg1 object new_cons = allocate_cons();
       Car(new_cons) = STACK_0;
       STACK_0 = new_cons;
      }
      while
        # Stackaufbau: pathname, subdir-list, pathname-list.
        # Dabei enthalten die Pathnames aus pathname-list das Directory
        # nur so tief, daß es danach mit (cdr subdir-list) weitergeht.
        # Nächste subdir-Ebene abarbeiten:
        (consp (STACK_1 = Cdr(STACK_1))) # subdir-list verkürzen
        { # pathname-list durchgehen und dabei neue Liste aufbauen:
          pushSTACK(STACK_0); pushSTACK(NIL);
          loop
            { # Stackaufbau: ..., pathname-list-rest, new-pathname-list.
              var reg2 object pathname_list_rest = STACK_1;
              if (atomp(pathname_list_rest)) break;
              STACK_1 = Cdr(pathname_list_rest);
             {var reg5 object next_pathname = Car(pathname_list_rest); # nächster Pathname
              var reg3 object subdir_list = STACK_(1+2);
              pushSTACK(next_pathname); # in den Stack
              if (!eq(Car(subdir_list),S(Kwild_inferiors))) # nächstes subdir = :WILD-INFERIORS ?
                { # normales subdir:
                  var reg1 uintC stringcount =
                    directory_namestring_parts_(next_pathname); # Directory-Namestring-Teile (keine GC!)
                  stringcount +=
                    subdir_namestring_parts(subdir_list); # und Strings zum nächsten subdir
                  pushSTACK(O(null_string)); stringcount += 1; # und Nullbyte
                 {var reg6 object pathstring = string_concat(stringcount); # zusammenhängen
                  subdirs(pathstring); # alle subdirs auf new-pathname-list pushen
                  skipSTACK(1); # next-pathname vergessen
                }}
                else
                { # subdir = :WILD-INFERIORS -> alle Subdirs bestimmen:
                  {var reg1 object list1 = allocate_cons();
                   Car(list1) = STACK_0;
                   STACK_0 = list1; # einelementige Liste (next-pathname)
                   allsubdirs(list1); # alle Subdirectories bestimmen
                  }
                  # Liste aller Subdirectories vor new-pathname-list
                  # in umgekehrter Reihenfolge davorhängen:
                  # (nreconc subdirlist new-pathname-list)
                  {var reg1 object newsubdirlist = popSTACK();
                   STACK_0 = nreconc(newsubdirlist,STACK_0);
                } }
              # nächsten Pathname aus pathname-list-rest nehmen
            }}
         {var reg1 object new_pathname_list = popSTACK(); skipSTACK(1);
          # umdrehen und als nächste pathname-list verwenden:
          STACK_0 = nreverse(new_pathname_list);
        }}
      # Stackaufbau: pathname, nix, pathname-list.
      pathname = STACK_2;
      {var reg2 object name = ThePathname(pathname)->pathname_name;
       var reg3 object type = ThePathname(pathname)->pathname_type;
       if (nullp(name)) # Name=NIL ?
         { if (nullp(type)) # auch Typ=NIL ?
             { var reg1 object new_pathname_list = popSTACK(); # ja ->
               skipSTACK(2); return new_pathname_list; # schon fertig
             }
             else
             # nein -> verwende :WILD (statt NIL) als Name
             { name = S(Kwild); }
         }
       # Alle Files name.type in den gegebenen Subdirectories suchen:
       { var reg1 uintC stringcount =
           nametype_namestring_parts(name,type,ThePathname(pathname)->pathname_version); # Teilstrings zu Name und Typ
         pushSTACK(O(null_string)); stringcount++; # und Nullbyte
        {var reg2 object name_type_asciz = string_concat(stringcount);
         STACK_2 = name_type_asciz;
      }}}
      STACK_1 = STACK_0; # pathname-list
      STACK_0 = NIL; # new-pathname-list := NIL
      # Stackaufbau: name-type-asciz, pathname-list, new-pathname-list.
      loop
        { var reg5 object pathname_list_rest = STACK_1;
          if (atomp(pathname_list_rest)) break;
          STACK_1 = Cdr(pathname_list_rest);
         {var reg8 object next_pathname = Car(pathname_list_rest); # nächster Pathname
          var reg7 object name_type_asciz = STACK_2;
          pushSTACK(next_pathname); # in den Stack
          {var reg3 uintC stringcount =
             directory_namestring_parts_(next_pathname); # Directory-Namestring-Teile (keine GC!)
           pushSTACK(name_type_asciz); stringcount += 1; # und name-type-asciz
           {var reg6 object pathstring = string_concat(stringcount); # zusammenhängen
            #ifdef ATARI
             # Dateisuche gemäß GEMDOS-Konvention:
             var reg2 sintW errorcode;
             set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
             GEMDOS_SetDTA(&DTA_buffer); # DTA-Buffer setzen
             # Suchanfang, die Maske 0x00 sucht nur nach normalen Dateien:
             errorcode =
               GEMDOS_Sfirst(TheAsciz(pathstring),0x00);
             if (!(errorcode == GEMDOS_Sfirst_notfound)) # 'Keine Datei gefunden' ?
               # ja -> Schleife nicht durchlaufen
               loop
                 { if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
                   # Stackaufbau: ..., next-pathname.
                   # gefundene Datei untersuchen:
                   { # in Name.Typ aufspalten, Default-Typ NIL :
                     extract(&DTA_buffer.d_fname[0],NIL);
                    {# letzten Pathname kopieren und Name und Typ eintragen:
                     var reg1 object new = copy_pathname(STACK_2);
                     ThePathname(new)->pathname_name = popSTACK();
                     ThePathname(new)->pathname_type = popSTACK();
                     # Full-Flag abtesten und evtl. mehr Information besorgen:
                     if (!nullp(STACK_(0+3+1)))
                       { pushSTACK(new); # newpathname als 1. Listenelement
                         pushSTACK(new); # newpathname als 2. Listenelement
                         { # Uhrzeit und Datum von Atari-Format in Decoded-Time umwandeln:
                           var decoded_time timepoint;
                           convert_timedate(DTA_buffer.d_time,DTA_buffer.d_date,
                                        &timepoint);
                           pushSTACK(timepoint.Sekunden);
                           pushSTACK(timepoint.Minuten);
                           pushSTACK(timepoint.Stunden);
                           pushSTACK(timepoint.Tag);
                           pushSTACK(timepoint.Monat);
                           pushSTACK(timepoint.Jahr);
                           new = listof(6); # 6-elementige Liste bauen
                         }
                         pushSTACK(new); # als 3. Listenelement
                         pushSTACK(UL_to_I(DTA_buffer.d_length)); # Länge als 4. Listenelement
                         new = listof(4); # 4-elementige Liste bauen
                       }
                     # new auf die Liste new-pathname-list pushen:
                      pushSTACK(new);
                     {var reg1 object new_cons = allocate_cons();
                      Car(new_cons) = popSTACK();
                      Cdr(new_cons) = STACK_(0+1);
                      STACK_(0+1) = new_cons;
                   }}}
                   # nächstes File:
                   errorcode = GEMDOS_Snext();
                   if (errorcode == GEMDOS_Snext_notfound) # 'Keine weitere Datei gefunden' ?
                     break; # ja -> Schleifenende
                 }
             clr_break_sem_4();
            #endif
            #ifdef MSDOS
             # Dateisuche gemäß DOS-Konvention:
             var struct ffblk DTA_buffer;
             set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
             # Suchanfang, suche nur nach normalen Dateien:
             begin_system_call();
             if (findfirst(TheAsciz(pathstring),&DTA_buffer,FA_ARCH|FA_RDONLY) <0)
               { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); } }
               else # Keine Datei gefunden -> Schleife nicht durchlaufen
               loop
                 { # Stackaufbau: ..., next-pathname.
                   end_system_call();
                   # gefundene Datei untersuchen:
                   { # in Name.Typ aufspalten, Default-Typ NIL :
                     extract(&DTA_buffer.ff_name[0],NIL);
                    {# letzten Pathname kopieren und Name und Typ eintragen:
                     var reg1 object new = copy_pathname(STACK_2);
                     ThePathname(new)->pathname_name = popSTACK();
                     ThePathname(new)->pathname_type = popSTACK();
                     # Full-Flag abtesten und evtl. mehr Information besorgen:
                     if (!nullp(STACK_(0+3+1)))
                       { pushSTACK(new); # newpathname als 1. Listenelement
                         pushSTACK(new); # newpathname als 2. Listenelement
                         { # Uhrzeit und Datum von DOS-Format in Decoded-Time umwandeln:
                           var decoded_time timepoint;
                           convert_timedate((uintW)DTA_buffer.ff_ftime,(uintW)DTA_buffer.ff_fdate,
                                        &timepoint);
                           pushSTACK(timepoint.Sekunden);
                           pushSTACK(timepoint.Minuten);
                           pushSTACK(timepoint.Stunden);
                           pushSTACK(timepoint.Tag);
                           pushSTACK(timepoint.Monat);
                           pushSTACK(timepoint.Jahr);
                           new = listof(6); # 6-elementige Liste bauen
                         }
                         pushSTACK(new); # als 3. Listenelement
                         pushSTACK(UL_to_I(*(uintL*)(&DTA_buffer.ff_fsize))); # Länge als 4. Listenelement
                         new = listof(4); # 4-elementige Liste bauen
                       }
                     # new auf die Liste new-pathname-list pushen:
                      pushSTACK(new);
                     {var reg1 object new_cons = allocate_cons();
                      Car(new_cons) = popSTACK();
                      Cdr(new_cons) = STACK_(0+1);
                      STACK_(0+1) = new_cons;
                   }}}
                   # nächstes File:
                   begin_system_call();
                   if (findnext(&DTA_buffer) <0)
                     { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); }
                       break; # Keine weitere Datei -> Schleifenende
                     }
                 }
             end_system_call();
             clr_break_sem_4();
            #endif
          }}
          skipSTACK(1); # next-pathname vergessen
        }}
      {# new-pathname-list wieder umdrehen:
       var reg1 object new_pathname_list = nreverse(popSTACK());
       skipSTACK(2); return new_pathname_list;
    } }
  #
  #endif # PATHNAME_EXT83
  #
  #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  #
  # UP: Erweitert das Directory eines Pathname um eine Komponente.
  # > STACK_1: ein Pathname
  # > STACK_0: neue Subdir-Komponente, ein Simple-String
  # < ergebnis: neuer Pathname mit um subdir verlängertem Directory
  # Erhöht STACK um 2
  # kann GC auslösen
  local object pathname_add_subdir (void);
  local object pathname_add_subdir()
    { # Pathname kopieren und dessen Directory gemäß
      # (append x (list y)) = (nreverse (cons y (reverse x))) verlängern:
      var reg2 object pathname = copy_pathname(STACK_1);
      STACK_1 = pathname;
      pushSTACK(reverse(ThePathname(pathname)->pathname_directory));
     {var reg1 object new_cons = allocate_cons();
      Cdr(new_cons) = popSTACK();
      Car(new_cons) = popSTACK();
      new_cons = nreverse(new_cons);
      pathname = popSTACK();
      ThePathname(pathname)->pathname_directory = new_cons;
      return pathname;
    }}
  #
  #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  # UP: Erweitert einen Pathname um die File-Information.
  # > STACK_1: absoluter Pathname
  # > STACK_0: absoluter Pathname, Links aufgelöst
  # > *filestatus: dessen stat-Info
  # < STACK_0: Liste (Pathname Truename Write-Date Length [Kommentar]) im :FULL-Format
  local void with_stat_info (void);
  local void with_stat_info()
    { var reg2 object new;
      #if defined(UNIX) || defined(RISCOS)
      var reg3 uintL size = filestatus->st_size;
      #endif
      #ifdef AMIGAOS
      var reg3 uintL size = filestatus->fib_Size;
      #endif
      # Pathname schon in STACK_1, als 1. Listenelement
      # Truename schon in STACK_0, als 2. Listenelement
      { var decoded_time timepoint; # Write-Date in decodierter Form
        #if defined(UNIX) || defined(RISCOS)
        convert_time(&filestatus->st_mtime,&timepoint);
        #endif
        #ifdef AMIGAOS
        convert_time(&filestatus->fib_Date,&timepoint);
        #endif
        pushSTACK(timepoint.Sekunden);
        pushSTACK(timepoint.Minuten);
        pushSTACK(timepoint.Stunden);
        pushSTACK(timepoint.Tag);
        pushSTACK(timepoint.Monat);
        pushSTACK(timepoint.Jahr);
        new = listof(6); # 6-elementige Liste bauen
      }
      pushSTACK(new); # als 3. Listenelement
      pushSTACK(UL_to_I(size)); # Länge als 4. Listenelement
      #if defined(UNIX) || defined(RISCOS)
      new = listof(4); # 4-elementige Liste bauen
      #endif
      #ifdef AMIGAOS
      pushSTACK(asciz_to_string(&filestatus->fib_Comment[0])); # Kommentar als 5. Listenelement
      new = listof(5); # 5-elementige Liste bauen
      #endif
      pushSTACK(Car(new)); # pathname wieder in den Stack
      pushSTACK(new); # Liste in den Stack
    }
  #endif
  #
  local object directory_search(pathname)
    var reg9 object pathname;
    {
      #ifdef PATHNAME_RISCOS
      # If we search for a file with type /= NIL, we have to interpret the last
      # subdir as the type.
      var boolean name_and_type = FALSE;
      #endif
      pathname = use_default_dir(pathname); # Default-Directory einfügen
      # pathname ist jetzt neu und ein absoluter Pathname.
      pushSTACK(NIL); # result-list := NIL
      pushSTACK(pathname);
      # Falls name=NIL und type/=NIL: Setze name := "*".
      if (nullp(ThePathname(pathname)->pathname_name)
          && !nullp(ThePathname(pathname)->pathname_type)
         )
        { ThePathname(pathname)->pathname_name = O(wild_string); }
      #ifdef PATHNAME_RISCOS
      # If the name and type are both set, then make the type part of
      # the directory specification and set the new type to NIL.
      if (!nullp(ThePathname(pathname)->pathname_name)
          && !nullp(ThePathname(pathname)->pathname_type)
         )
        { name_and_type = TRUE;
          pushSTACK(pathname); pushSTACK(ThePathname(pathname)->pathname_type);
          STACK_0 = pathname = pathname_add_subdir();
          ThePathname(pathname)->pathname_type = NIL;
        }
      #endif
      # Zum Matchen: Name und Typ zu einem String zusammenfassen:
      if (nullp(ThePathname(pathname)->pathname_name))
        { pushSTACK(NIL); } # name=NIL -> auch type=NIL -> keine Files suchen
        else
        {var reg1 uintC stringcount = file_namestring_parts(pathname);
         var reg1 object nametype_string = string_concat(stringcount);
         pathname = STACK_0;
         pushSTACK(nametype_string);
        }
      pushSTACK(ThePathname(pathname)->pathname_directory); # subdir-list
      #ifdef PATHNAME_RISCOS
      STACK_0 = Cdr(STACK_0); # Liste fängt mit (:ABSOLUTE :ROOT ...) an, verkürze sie
      #endif
      # pathname kopieren und dabei Name und Typ streichen und
      # Directory zu (:ABSOLUTE) bzw. (:ABSOLUTE :ROOT) verkürzen:
      pathname = copy_pathname(pathname);
      ThePathname(pathname)->pathname_name = NIL;
      ThePathname(pathname)->pathname_type = NIL;
      ThePathname(pathname)->pathname_directory = O(directory_absolute);
      pushSTACK(pathname);
      # und in einelementige Liste packen:
      {var reg1 object new_cons = allocate_cons();
       Car(new_cons) = STACK_0;
       STACK_0 = new_cons;
      }
     {var reg7 boolean recursively = # Flag, ob die nächste Operation auf
        FALSE;                       # alle Subdirectories anzuwenden ist.
      loop
        # Stackaufbau: result-list, pathname, name&type, subdir-list, pathname-list.
        # result-list = Liste der fertigen Pathnames/Listen, umgedreht.
        # name&type = NIL oder Simple-String, gegen den die Filenamen zu matchen sind.
        # pathname-list = Liste der noch abzuarbeitenden Directories.
        # Dabei enthalten die Pathnames aus pathname-list das Directory
        # nur so tief, daß es danach mit (cdr subdir-list) weitergeht.
        { # Nächste subdir-Ebene abarbeiten:
          STACK_1 = Cdr(STACK_1); # subdir-list verkürzen
         {var reg6 signean next_task; # Was mit den Dirs aus pathname-list zu tun ist:
            # 0: nichts, fertig
            # 1: nach einem File gegebenen Namens/Typs sehen
            # -1: nach einem Subdirectory gegebenen Namens sehen
            # 2: nach allen Files suchen, die gegebenen Namen/Typ matchen
            # -2: nach allen Subdirectories suchen, die gegebenen Namen matchen
          if (matomp(STACK_1)) # subdir-list zu Ende?
            { var reg1 object nametype = STACK_2;
              if (nullp(nametype)) # name=NIL und type=NIL -> keine Files suchen
                { next_task = 0; }
              #ifndef MSDOS
              elif (!has_wildcards(nametype))
                   # === !(has_wildcards(name) || ((!nullp(type)) && has_wildcards(type)))
                { next_task = 1; } # File suchen
              #endif
              else
                { next_task = 2; } # Files mit Wildcards suchen
            }
            else
            { var reg1 object next_subdir = Car(STACK_1);
              if (eq(next_subdir,S(Kwild_inferiors))) # '...' ?
                # wird erst beim nächsten Durchlauf behandelt
                { recursively = TRUE; goto passed_subdir; }
              #ifndef MSDOS
              if (
                  #ifdef PATHNAME_AMIGAOS
                  eq(next_subdir,S(Kparent)) ||
                  #endif
                  #ifdef PATHNAME_RISCOS
                  !simple_string_p(next_subdir) ||
                  #endif
                  !has_wildcards(next_subdir)
                 )
                { next_task = -1; } # Subdir suchen
                else
              #endif
                { next_task = -2; } # Subdirs mit Wildcards suchen
            }
          # pathname-list durchgehen und dabei neue Liste aufbauen:
          pushSTACK(NIL);
          #ifdef UNIX
          if (!nullp(STACK_(1+5+1))) # ;CIRCLE-Flag abfragen
            { # Hash-Tabelle aller bisher abgesuchten Directories (jeweils
              # als Cons (dev . ino)) führen:
              pushSTACK(S(Ktest)); pushSTACK(S(equal));
              funcall(L(make_hash_table),2); # (MAKE-HASH-TABLE :TEST 'EQUAL)
              pushSTACK(value1);
            }
            else
            { pushSTACK(NIL); }
          #define H 1
          #else
          #define H 0
          #endif
          pushSTACK(STACK_(0+1+H));
          loop
            { # Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest.
              var reg9 object pathname_list_rest = STACK_0;
              if (atomp(pathname_list_rest)) break;
              STACK_0 = Cdr(pathname_list_rest); # Liste verkürzen
              pushSTACK(NIL); # pathnames-to-insert := NIL
              # Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest, pathnames-to-insert.
             {var reg9 object pathname = Car(pathname_list_rest); # nächstes Directory
              pushSTACK(pathname); # in den Stack
              # Versuche, die Task ein wenig abzukürzen:
              if (!recursively)
                { switch (next_task)
                    { case 0: # Dieses pathname liefern
                        #ifdef UNIX
                        assure_dir_exists(FALSE); # erst noch Links auflösen
                        #endif
                        # und STACK_0 vor result-list pushen:
                        {var reg1 object new_cons = allocate_cons();
                         Car(new_cons) = popSTACK();
                         Cdr(new_cons) = STACK_(4+(1+H+2));
                         STACK_(4+(1+H+2)) = new_cons;
                        }
                        goto next_pathname;
                      #ifndef MSDOS
                      case 1: # In diesem pathname nach einem File sehen
                        ThePathname(pathname)->pathname_name = # Name (/=NIL) einsetzen
                          ThePathname(STACK_(3+(1+H+2)+1))->pathname_name;
                        ThePathname(pathname)->pathname_type = # Typ einsetzen
                          ThePathname(STACK_(3+(1+H+2)+1))->pathname_type;
                        pushSTACK(pathname);
                        #ifdef PATHNAME_RISCOS
                        if (name_and_type && nullp(ThePathname(pathname)->pathname_type))
                          # Move the last subdir into the type slot of the pathname.
                          { # subdirs := (butlast subdirs) = (nreverse (cdr (reverse subdirs)))
                            var reg1 object subdirs = reverse(ThePathname(pathname)->pathname_directory);
                            pathname = STACK_0;
                            ThePathname(pathname)->pathname_type = Car(subdirs);
                            ThePathname(pathname)->pathname_directory = nreverse(Cdr(subdirs));
                          }
                        #endif
                        assure_dir_exists(FALSE); # Links auflösen, File suchen
                        if (file_exists(_EMA_)) # falls File existiert
                          { if (!nullp(STACK_(0+5+(1+H+2)+2))) # :FULL gewünscht?
                              { with_stat_info(); } # ja -> STACK_0 erweitern
                            # und STACK_0 vor result-list pushen:
                           {var reg1 object new_cons = allocate_cons();
                            Car(new_cons) = STACK_0;
                            Cdr(new_cons) = STACK_(4+(1+H+2)+2);
                            STACK_(4+(1+H+2)+2) = new_cons;
                          }}
                        skipSTACK(2);
                        goto next_pathname;
                      case -1: # In diesem pathname nach einem Subdirectory sehen
                        { var reg2 object namestring = assure_dir_exists(FALSE); # Links auflösen, Directory-Namestring
                          pushSTACK(namestring); # Directory-Namestring
                          {var reg1 object subdir = Car(STACK_(1+(1+H+2)+1+1)); # (car subdir-list)
                           #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
                           if (eq(subdir,S(Kparent))) # für Parent-Directory
                             {
                               #ifdef PATHNAME_AMIGAOS
                               pushSTACK(O(slash_string)); # zusätzliches "/" ans Ende
                               #endif
                               #ifdef PATHNAME_RISCOS
                               pushSTACK(O(parent_string)); # zusätzliches "^" ans Ende
                               #endif
                             }
                             else
                           #endif
                           pushSTACK(subdir);
                          }
                          pushSTACK(O(null_string)); # und Nullbyte
                          namestring = string_concat(3); # zusammenhängen
                          # Information holen:
                         #if defined(UNIX) || defined(RISCOS)
                         {var struct stat status;
                          begin_system_call();
                          if (!( stat(TheAsciz(namestring),&status) ==0))
                            { if (!(errno==ENOENT)) { OS_error(); }
                              end_system_call();
                              # Subdirectory existiert nicht -> OK.
                            }
                            else
                            # File existiert.
                            { end_system_call();
                              if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
                                # ja -> neuen Pathname dazu bilden:
                                { # pathname kopieren und dessen Directory um
                                  # (car subdir-list) verlängern:
                                  pushSTACK(Car(STACK_(1+(1+H+2)+1)));
                                 {var reg1 object pathname = pathname_add_subdir();
                                  pushSTACK(pathname);
                                 }# Diesen neuen Pathname vor new-pathname-list pushen:
                                 {var reg1 object new_cons = allocate_cons();
                                  Car(new_cons) = STACK_0;
                                  Cdr(new_cons) = STACK_(H+2+1);
                                  STACK_(H+2+1) = new_cons;
                                }}
                         }  }
                         #endif
                         #ifdef AMIGAOS
                         { var LONGALIGNTYPE(struct FileInfoBlock) fib;
                           var reg1 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
                           set_break_sem_4();
                           begin_system_call();
                          {var reg2 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
                           if (lock==BPTR_NULL)
                             { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
                               end_system_call();
                               clr_break_sem_4();
                               # Subdirectory existiert nicht -> OK.
                             }
                             else
                             # File existiert.
                             { if (! Examine(lock,fibptr) ) { UnLock(lock); OS_error(); }
                               UnLock(lock);
                               end_system_call();
                               clr_break_sem_4();
                               if (fibptr->fib_DirEntryType > 0) # Ist es ein Directory?
                                 # ja -> neuen Pathname dazu bilden:
                                 { # pathname kopieren und dessen Directory um
                                   # (car subdir-list) verlängern:
                                   pushSTACK(Car(STACK_(1+(1+H+2)+1)));
                                  {var reg1 object pathname = pathname_add_subdir();
                                   pushSTACK(pathname);
                                  }# Diesen neuen Pathname vor new-pathname-list pushen:
                                  {var reg1 object new_cons = allocate_cons();
                                   Car(new_cons) = STACK_0;
                                   Cdr(new_cons) = STACK_(H+2+1);
                                   STACK_(H+2+1) = new_cons;
                                 }}
                         }}  }
                         #endif
                        }
                        skipSTACK(1);
                        goto next_pathname;
                        #endif
                }   }
              # Um die Task zu erledigen, müssen alle Einträge dieses
              # Directory abgesucht werden:
              {{var reg1 object dir_namestring = assure_dir_exists(FALSE); # Links auflösen, Directory-Name bilden
                pushSTACK(dir_namestring); # retten
               }# Stackaufbau: ..., pathname, dir_namestring.
               #ifdef UNIX
                if (!nullp(STACK_(1+5+(1+H+2)+2))) # ;CIRCLE-Flag abfragen
                  { # pathname in der Hash-Tabelle suchen:
                    pushSTACK(STACK_0); # Directory-Name
                    pushSTACK(O(punkt_string)); # und "."
                    pushSTACK(O(null_string)); # und Nullbyte
                    {var reg8 object namestring = string_concat(3); # zusammenhängen
                     var struct stat status;
                     begin_system_call();
                     if (!( stat(TheAsciz(namestring),&status) ==0)) # Information holen
                       { if (!(errno==ENOENT)) { OS_error(); }
                         end_system_call();
                         # Eintrag existiert doch nicht (das kann uns
                         # wohl nur bei symbolischen Links passieren)
                         # -> wird übergangen
                         skipSTACK(2); goto next_pathname;
                       }
                     end_system_call();
                     # Eintrag existiert (welch Wunder...)
                     pushSTACK(UL_to_I(status.st_dev)); # Device-Nummer und
                     pushSTACK(UL_to_I(status.st_ino)); # Inode-Nummer
                     {var reg1 object new_cons = allocate_cons(); # zusammenconsen
                      Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
                      # und in der Hash-Tabelle aufsuchen und ablegen:
                      if (!nullp(shifthash(STACK_(2+2),new_cons,T)))
                        # war schon drin -> wird übergangen
                        { skipSTACK(2); goto next_pathname; }
                  } }}
               #endif
                if (next_task==0)
                  # Pathname STACK_1 vor result-list pushen:
                  {var reg1 object new_cons = allocate_cons();
                   Car(new_cons) = STACK_1;
                   Cdr(new_cons) = STACK_(4+(1+H+2)+2);
                   STACK_(4+(1+H+2)+2) = new_cons;
                  }
               #if defined(UNIX) || defined(RISCOS)
               { var reg8 object namestring;
                 #ifdef UNIX
                 pushSTACK(STACK_0); # Directory-Name
                 pushSTACK(O(punkt_string)); # und "."
                 pushSTACK(O(null_string)); # und Nullbyte
                 namestring = string_concat(3); # zusammenhängen
                 #endif
                 #ifdef RISCOS
                 var reg10 object wildcard_mask;
                 namestring = copy_string(STACK_0); # Directory-Name
                 TheSstring(namestring)->data[TheSstring(namestring)->length-1] = '\0'; # mit Nullbyte statt '.' am Schluß
                 # Statt wildcard_match() selber aufzurufen, überlassen wir das dem Betriebssystem:
                 pushSTACK(namestring); # retten
                 wildcard_mask = string_to_asciz(next_task<0 ? Car(STACK_(1+(1+H+2)+3)) : STACK_(2+(1+H+2)+3));
                 # In wildcard_mask die Wildchar-Characters '?' ins synonyme '#' umwandeln:
                 { var reg1 uintB* ptr = &TheSstring(wildcard_mask)->data[0];
                   var reg2 uintL count = TheSstring(wildcard_mask)->length;
                   dotimespL(count,count, { if (*ptr == '?') { *ptr = '#'; } ptr++; } );
                 }
                 namestring = popSTACK();
                 #endif
                 # Directory absuchen:
                {var reg5 DIR* dirp;
                 set_break_sem_4();
                 begin_system_call();
                 #ifdef UNIX
                 dirp = opendir(TheAsciz(namestring)); # Directory öffnen
                 #endif
                 #ifdef RISCOS
                 dirp = opendir(TheAsciz(namestring),TheAsciz(wildcard_mask)); # Directory zum Suchen öffnen
                 #endif
                 if (dirp == (DIR*)NULL) { OS_error(); }
                 end_system_call();
                 loop
                   { var reg2 SDIRENT* dp;
                     errno = 0;
                     begin_system_call();
                     dp = readdir(dirp); # nächsten Directory-Eintrag holen
                     end_system_call();
                     if (dp == (SDIRENT*)NULL) # Error oder Directory zu Ende
                       { if (!(errno==0)) { OS_error(); } else break; }
                     # Directory-Eintrag in String umwandeln:
                    {var reg4 object direntry;
                     {var reg3 uintL direntry_len;
                      #ifdef DIRENT_WITHOUT_NAMLEN
                      # Unter UNIX_LINUX reicht direntry_len := dp->d_reclen, aber i.a. ist
                      # direntry_len := min(dp->d_reclen,asciz_length(dp->d_name))  nötig:
                      {var reg1 const uintB* ptr = (const uintB*)(&dp->d_name[0]);
                       var reg1 uintL count;
                       direntry_len = 0;
                       dotimesL(count,dp->d_reclen,
                         { if (*ptr == '\0') break;
                           ptr++; direntry_len++;
                         });
                      }
                      #else
                      direntry_len = dp->d_namlen;
                      #endif
                      direntry = make_string((const uintB*)(&dp->d_name[0]),direntry_len);
                     }
                     #ifndef RISCOS
                     # "." und ".." übergehen:
                     if (!(equal(direntry,O(punkt_string))
                           || equal(direntry,O(punktpunkt_string))
                        ) )
                     #endif
                       { pushSTACK(direntry);
                         # Stackaufbau: ..., pathname, dir_namestring, direntry.
                         # Feststellen, ob es ein Directory oder ein File ist:
                         pushSTACK(STACK_1); # Directory-Namestring
                         pushSTACK(direntry); # direntry
                         pushSTACK(O(null_string)); # und Nullbyte
                        {var reg3 object namestring = string_concat(3); # zusammenhängen
                         # Information holen:
                         var struct stat status;
                         begin_system_call();
                         if (!( stat(TheAsciz(namestring),&status) ==0))
                           { if (!(errno==ENOENT)) { OS_error(); }
                             end_system_call();
                             # Eintrag existiert doch nicht (das kann uns
                             # wohl nur bei symbolischen Links passieren)
                             # -> wird übergangen
                           }
                           else
                           { end_system_call();
                             # Eintrag existiert (welch Wunder...)
                             if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
                               # Eintrag ist ein Directory.
                               { if (recursively) # alle rekursiven Subdirectories gewünscht?
                                   # ja -> zu einem Pathname machen und auf
                                   # pathnames-to-insert pushen (wird nachher
                                   # vor pathname-list-rest eingefügt):
                                   { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
                                    {var reg1 object pathname = pathname_add_subdir();
                                     pushSTACK(pathname);
                                    }# Diesen neuen Pathname vor pathname-to-insert pushen:
                                    {var reg1 object new_cons = allocate_cons();
                                     Car(new_cons) = popSTACK();
                                     Cdr(new_cons) = STACK_(0+3);
                                     STACK_(0+3) = new_cons;
                                   }}
                                 if (next_task<0)
                                   {
                                     #ifndef RISCOS
                                     # (car subdir-list) mit direntry matchen:
                                     if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
                                     #endif
                                       # Subdirectory matcht -> zu einem Pathname
                                       # machen und auf new-pathname-list pushen:
                                       { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
                                        {var reg1 object pathname = pathname_add_subdir();
                                         pushSTACK(pathname);
                                        }# Diesen neuen Pathname vor new-pathname-list pushen:
                                        {var reg1 object new_cons = allocate_cons();
                                         Car(new_cons) = popSTACK();
                                         Cdr(new_cons) = STACK_(H+2+3);
                                         STACK_(H+2+3) = new_cons;
                                   }   }}
                               }
                               else
                               # Eintrag ist ein (halbwegs) normales File.
                               { if (next_task>0)
                                   {
                                     #ifndef RISCOS
                                     # name&type mit direntry matchen:
                                     if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
                                     #endif
                                       # File matcht -> zu einem Pathname machen
                                       # und auf result-list pushen:
                                       {
                                         #ifndef PATHNAME_RISCOS
                                         pushSTACK(STACK_0); # direntry
                                         split_name_type(1); # in Name und Typ aufspalten
                                         {var reg1 object pathname = copy_pathname(STACK_(2+2));
                                          ThePathname(pathname)->pathname_type = popSTACK(); # Typ einsetzen
                                          ThePathname(pathname)->pathname_name = popSTACK(); # Name einsetzen
                                          pushSTACK(pathname);
                                          pushSTACK(pathname);
                                         }
                                         #else # PATHNAME_RISCOS
                                         {var reg1 object pathname = copy_pathname(STACK_2);
                                          pushSTACK(pathname);
                                          if (name_and_type && nullp(ThePathname(pathname)->pathname_type))
                                            # Move the last subdir into the type slot of the pathname.
                                            { # subdirs := (butlast subdirs) = (nreverse (cdr (reverse subdirs)))
                                              var reg1 object subdirs = reverse(ThePathname(pathname)->pathname_directory);
                                              pathname = STACK_0;
                                              ThePathname(pathname)->pathname_type = Car(subdirs);
                                              ThePathname(pathname)->pathname_directory = nreverse(Cdr(subdirs));
                                            }
                                          ThePathname(pathname)->pathname_name = STACK_1; # direntry
                                          pushSTACK(pathname);
                                         }
                                         #endif
                                         # Truename bilden (symbolische Links auflösen):
                                         assure_dir_exists(FALSE);
                                         if (file_exists(_EMA_)) # falls File (immer noch...) existiert
                                           { if (!nullp(STACK_(0+5+(1+H+2)+3+2))) # :FULL gewünscht?
                                               with_stat_info(); # ja -> STACK_0 erweitern
                                             # und STACK_0 vor result-list pushen:
                                            {var reg1 object new_cons = allocate_cons();
                                             Car(new_cons) = STACK_0;
                                             Cdr(new_cons) = STACK_(4+(1+H+2)+3+2);
                                             STACK_(4+(1+H+2)+3+2) = new_cons;
                                           }}
                                         skipSTACK(2);
                                   }   }
                           }   }
                         skipSTACK(1); # direntry vergessen
                   }}  }}
                 begin_system_call();
                 if (CLOSEDIR(dirp)) { OS_error(); }
                 end_system_call();
                 clr_break_sem_4();
               }}
               #endif
               #ifdef AMIGAOS
                # Directory absuchen:
               { var reg7 object namestring = OSnamestring(STACK_0);
                 set_break_sem_4();
                 begin_system_call();
                {var reg6 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
                 var LONGALIGNTYPE(struct FileInfoBlock) fib;
                 var reg5 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
                 if (lock==BPTR_NULL) { OS_error(); }
                 if (! Examine(lock,fibptr) ) { OS_error(); }
                 end_system_call();
                 loop
                   { begin_system_call();
                     if (! ExNext(lock,fibptr) ) # Error oder Directory zu Ende?
                       break;
                     end_system_call();
                     # Directory-Eintrag in String umwandeln:
                    {var reg4 object direntry = asciz_to_string(&fibptr->fib_FileName[0]);
                     pushSTACK(direntry);
                     # Stackaufbau: ..., pathname, dir_namestring, direntry.
                     # Feststellen, ob es ein Directory oder ein File ist:
                     if (fibptr->fib_DirEntryType > 0) # Ist es ein Directory?
                       # Eintrag ist ein Directory.
                       { if (recursively) # alle rekursiven Subdirectories gewünscht?
                           # ja -> zu einem Pathname machen und auf
                           # pathnames-to-insert pushen (wird nachher
                           # vor pathname-list-rest eingefügt):
                           { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
                            {var reg1 object pathname = pathname_add_subdir();
                             pushSTACK(pathname);
                            }# Diesen neuen Pathname vor pathname-to-insert pushen:
                            {var reg1 object new_cons = allocate_cons();
                             Car(new_cons) = popSTACK();
                             Cdr(new_cons) = STACK_(0+3);
                             STACK_(0+3) = new_cons;
                           }}
                         if (next_task<0)
                           { # (car subdir-list) mit direntry matchen:
                             if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
                               # Subdirectory matcht -> zu einem Pathname
                               # machen und auf new-pathname-list pushen:
                               { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
                                {var reg1 object pathname = pathname_add_subdir();
                                 pushSTACK(pathname);
                                }# Diesen neuen Pathname vor new-pathname-list pushen:
                                {var reg1 object new_cons = allocate_cons();
                                 Car(new_cons) = popSTACK();
                                 Cdr(new_cons) = STACK_(H+2+3);
                                 STACK_(H+2+3) = new_cons;
                           }   }}
                       }
                       else
                       # Eintrag ist ein (halbwegs) normales File.
                       { if (next_task>0)
                           { # name&type mit direntry matchen:
                             if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
                               # File matcht -> zu einem Pathname machen
                               # und auf result-list pushen:
                               { pushSTACK(STACK_0); # direntry
                                 split_name_type(1); # in Name und Typ aufspalten
                                {var reg1 object pathname = copy_pathname(STACK_(2+2));
                                 ThePathname(pathname)->pathname_type = popSTACK(); # Typ einsetzen
                                 ThePathname(pathname)->pathname_name = popSTACK(); # Name einsetzen
                                 pushSTACK(pathname);
                                 pushSTACK(pathname);
                                }
                                assure_dir_exists(FALSE); # Truename bilden (symbolische Links auflösen)
                                { if (!nullp(STACK_(0+5+(1+H+2)+3+2))) # :FULL gewünscht?
                                    with_stat_info(); # ja -> STACK_0 erweitern
                                  # und STACK_0 vor result-list pushen:
                                 {var reg1 object new_cons = allocate_cons();
                                  Car(new_cons) = STACK_0;
                                  Cdr(new_cons) = STACK_(4+(1+H+2)+3+2);
                                  STACK_(4+(1+H+2)+3+2) = new_cons;
                                }}
                                skipSTACK(2);
                       }   }   }
                     skipSTACK(1); # direntry vergessen
                   }}
                 UnLock(lock);
                 if (!(IoErr()==ERROR_NO_MORE_ENTRIES)) { OS_error(); }
                 end_system_call();
                 clr_break_sem_4();
               }}
               #endif
               #ifdef MSDOS
                pushSTACK(STACK_0); # Directory-Name
                pushSTACK(O(wild_wild_string)); # und "*.*"
                pushSTACK(O(null_string)); # und Nullbyte
               {var reg8 object namestring = string_concat(3); # zusammenhängen
                # Directory absuchen, gemäß DOS-Konvention:
                var struct ffblk DTA_buffer;
                set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
                # Suchanfang, suche nach Ordnern und normalen Dateien:
                begin_system_call();
                if (findfirst(TheAsciz(namestring),&DTA_buffer,FA_DIREC|FA_ARCH|FA_RDONLY) <0)
                  { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); } }
                  else # Keine Datei gefunden -> Schleife nicht durchlaufen
                  loop
                    { end_system_call();
                     {# Directory-Eintrag in String umwandeln:
                      var reg4 object direntry = asciz_to_string(&DTA_buffer.ff_name[0]);
                      # "." und ".." übergehen:
                      if (!(equal(direntry,O(punkt_string))
                            || equal(direntry,O(punktpunkt_string))
                         ) )
                        { pushSTACK(direntry);
                          # Stackaufbau: ..., pathname, dir_namestring, direntry.
                          if (DTA_buffer.ff_attrib & FA_DIREC) # Ist es ein Directory?
                            # Eintrag ist ein Directory.
                            { if (recursively) # alle rekursiven Subdirectories gewünscht?
                                # ja -> zu einem Pathname machen und auf
                                # pathnames-to-insert pushen (wird nachher
                                # vor pathname-list-rest eingefügt):
                                { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
                                 {var reg1 object pathname = pathname_add_subdir();
                                  pushSTACK(pathname);
                                 }# Diesen neuen Pathname vor pathname-to-insert pushen:
                                 {var reg1 object new_cons = allocate_cons();
                                  Car(new_cons) = popSTACK();
                                  Cdr(new_cons) = STACK_(0+3);
                                  STACK_(0+3) = new_cons;
                                }}
                              if (next_task<0)
                                { # (car subdir-list) mit direntry matchen:
                                  if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
                                    # Subdirectory matcht -> zu einem Pathname
                                    # machen und auf new-pathname-list pushen:
                                    { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
                                     {var reg1 object pathname = pathname_add_subdir();
                                      pushSTACK(pathname);
                                     }# Diesen neuen Pathname vor new-pathname-list pushen:
                                     {var reg1 object new_cons = allocate_cons();
                                      Car(new_cons) = popSTACK();
                                      Cdr(new_cons) = STACK_(H+2+3);
                                      STACK_(H+2+3) = new_cons;
                                }   }}
                            }
                            else
                            # Eintrag ist ein (halbwegs) normales File.
                            { if (next_task>0)
                                { # name&type mit direntry matchen:
                                  if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
                                    # File matcht -> zu einem Pathname machen
                                    # und auf result-list pushen:
                                    { pushSTACK(STACK_0); # direntry
                                      split_name_type(1); # in Name und Typ aufspalten
                                     {var reg1 object new = copy_pathname(STACK_(2+2));
                                      ThePathname(new)->pathname_type = popSTACK(); # Typ einsetzen
                                      ThePathname(new)->pathname_name = popSTACK(); # Name einsetzen
                                      # Full-Flag abtesten und evtl. mehr Information besorgen:
                                      if (!nullp(STACK_(0+5+(1+H+2)+3))) # :FULL gewünscht?
                                        { pushSTACK(new); # newpathname als 1. Listenelement
                                          pushSTACK(new); # newpathname als 2. Listenelement
                                          { # Uhrzeit und Datum von DOS-Format in Decoded-Time umwandeln:
                                            var decoded_time timepoint;
                                            convert_timedate((uintW)DTA_buffer.ff_ftime,(uintW)DTA_buffer.ff_fdate,
                                                             &timepoint);
                                            pushSTACK(timepoint.Sekunden);
                                            pushSTACK(timepoint.Minuten);
                                            pushSTACK(timepoint.Stunden);
                                            pushSTACK(timepoint.Tag);
                                            pushSTACK(timepoint.Monat);
                                            pushSTACK(timepoint.Jahr);
                                            new = listof(6); # 6-elementige Liste bauen
                                          }
                                          pushSTACK(new); # als 3. Listenelement
                                          pushSTACK(UL_to_I(*(uintL*)(&DTA_buffer.ff_fsize))); # Länge als 4. Listenelement
                                          new = listof(4); # 4-elementige Liste bauen
                                        }
                                      pushSTACK(new);
                                     }# und STACK_0 vor result-list pushen:
                                     {var reg1 object new_cons = allocate_cons();
                                      Car(new_cons) = popSTACK();
                                      Cdr(new_cons) = STACK_(4+(1+H+2)+3);
                                      STACK_(4+(1+H+2)+3) = new_cons;
                            }   }   }}
                          skipSTACK(1); # direntry vergessen
                        }
                      # nächstes File:
                      begin_system_call();
                      if (findnext(&DTA_buffer) <0)
                        { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); }
                          break; # Keine weitere Datei -> Schleifenende
                        }
                    }}
                end_system_call();
                clr_break_sem_4();
               }
               #endif
              }
              skipSTACK(2); # pathname und dir-namestring vergessen
              next_pathname: ;
             }# Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest, pathnames-to-insert.
              # Vor dem Weiterrücken mit pathname-list-rest :
              # pathname-list-rest := (nreconc pathnames-to-insert pathname-list-rest) :
             {var reg1 object pathnames_to_insert = popSTACK();
              STACK_0 = nreconc(pathnames_to_insert,STACK_0);
            }}
          skipSTACK(H+1); # leere pathname-list-rest und evtl. Hash-Tabelle vergessen
          #undef H
          # new-pathname-list umdrehen, ersetzt die geleerte pathname-list:
          {var reg1 object new_pathname_list = popSTACK();
           STACK_0 = nreverse(new_pathname_list); # neue pathname-list
          }
          # Mit dieser Subdir-Stufe sind wir fertig.
          if (matomp(STACK_1)) break; # (atom subdir-list) -> fertig.
          recursively = FALSE; # die nächste (vorläufig) nicht-rekursiv
          passed_subdir: ;
        }}
      # Stackaufbau: result-list, pathname, name&type, subdir-list, pathname-list.
      # subdir-list ist =NIL geworden, auch pathname-list = NIL (denn beim
      # letzten Schleifendurchlauf ist immer next_task=0,1,2, und dadurch
      # wurde nichts auf new-pathname-list gepusht).
      skipSTACK(4);
      return popSTACK(); # result-list als Ergebnis
    }}
  #
  #endif # PATHNAME_NOEXT

LISPFUN(directory,0,1,norest,key,2, (kw(circle),kw(full)) )
# (DIRECTORY [pathname [:circle] [:full]]), CLTL S. 427
  { # Stackaufbau: pathname, circle, full.
    #ifdef UNIX
    # :CIRCLE-Argument hat Defaultwert NIL:
    if (eq(STACK_1,unbound)) { STACK_1 = NIL; }
    #endif
    # :FULL-Argument hat Defaultwert NIL:
    if (eq(STACK_0,unbound)) { STACK_0 = NIL; }
    # Pathname-Argument überprüfen:
   {var reg1 object pathname = STACK_2;
    if (eq(pathname,unbound))
      {
        #ifdef PATHNAME_EXT83
        pathname = O(wild_wild_string); # Default ist "*.*" bzw. "*.*;*"
        #endif
        #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
        pathname = O(wild_string); # Default ist "*"
        #endif
      }
    pathname = coerce_pathname(pathname); # zu einem Pathname machen
    # Los geht's:
    #ifdef PATHNAME_ATARI
    if (eq(ThePathname(pathname)->pathname_device,S(Kwild))) # Device = :WILD ?
      # alle Devices abzusuchen
      { STACK_2 = pathname;
        pushSTACK(O(drive_alist)); # Aliste aller Drives
        pushSTACK(NIL); # bisherige Pathname-Liste := NIL
        pushSTACK(STACK_(0+2)); # full (für directory_search)
        # Stackaufbau: pathname, circle, full, Drive-Alist, pathname-list, full.
        while (mconsp(STACK_2)) # alle Drives durchlaufen
          { var reg3 object newpathname = copy_pathname(STACK_(2+3)); # Pathname kopieren
           {var reg2 object alistr = STACK_2; # restliche Drive-Aliste
            STACK_2 = Cdr(alistr); # verkürzen
            alistr = Car(alistr); # Alisteneintrag
            ThePathname(newpathname)->pathname_device = Car(alistr); # Drive übernehmen
           }# innerhalb eines Laufwerks suchen:
           {var reg2 object newpathnames = directory_search(newpathname);
            # und Pathname-Liste vor STACK_1 hängen:
            STACK_1 = nreconc(newpathnames,STACK_1);
          }}
        value1 = nreverse(STACK_1); # Pathname-Liste wieder umdrehen
        skipSTACK(3+3);
      }
      else
      # nur ein Device abzusuchen
    #endif
    #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
    if (eq(ThePathname(pathname)->pathname_device,S(Kwild))) # Device = :WILD ?
      # alle Devices abzusuchen
      { STACK_2 = pathname;
        pushSTACK(NIL); # bisherige Pathname-Liste := NIL
        pushSTACK(STACK_(0+1)); # full (für directory_search)
        # Stackaufbau: pathname, circle, full, pathname-list, full.
        {var uintB drive;
         for (drive='A'; drive<='Z'; drive++) # alle Drives durchlaufen
           if (good_drive(drive))
             { pushSTACK(make_string(&drive,1)); # Device, einelementiger String
              {var reg2 object newpathname = copy_pathname(STACK_(2+2+1)); # Pathname kopieren
               ThePathname(newpathname)->pathname_device = popSTACK(); # Drive übernehmen
               # innerhalb eines Laufwerks suchen:
               {var reg3 object newpathnames = directory_search(newpathname);
                # und Pathname-Liste vor STACK_1 hängen:
                STACK_1 = nreconc(newpathnames,STACK_1);
        }    }}}
        value1 = nreverse(STACK_1); # Pathname-Liste wieder umdrehen
        skipSTACK(3+2);
      }
      else
      # nur ein Device abzusuchen
    #endif
      { value1 = directory_search(pathname); # matchende Pathnames bilden
        skipSTACK(3);
      }
    mv_count=1;
  }}

LISPFUN(cd,0,1,norest,nokey,0,NIL)
# (CD [pathname]) setzt das aktuelle Laufwerk und das aktuelle Directory.
  { var reg1 object pathname = popSTACK();
    if (eq(pathname,unbound)) { pathname = O(leer_string); } # "" als Default
    pathname = coerce_pathname(pathname); # zu einem Pathname machen
    # kopieren und Name und Typ auf NIL setzen:
    pathname = copy_pathname(pathname);
    ThePathname(pathname)->pathname_name = NIL;
    ThePathname(pathname)->pathname_type = NIL;
    check_no_wildcards(pathname); # mit Wildcards -> Fehler
    pathname = use_default_dir(pathname); # Pathname mit Seriennummer draus machen
    pushSTACK(pathname);
    assure_dir_exists(FALSE); # Directory muß existieren
    change_default(); # Default-Drive, Default-Directory setzen
    value1 = popSTACK(); mv_count=1; # neuer pathname als Wert
  }

# UP: Überprüft ein Pathname-Argument, ob Name und Typ beide =NIL sind,
# und ob das Directory "fast" existiert.
# shorter_directory_arg()
# > STACK_0 : Pathname-Argument
#if defined(ATARI) || defined(MSDOS)
# < ergebnis: Directory-Namestring (für DOS, ASCIZ, ohne '\' am Schluß)
#endif
#if defined(UNIX) || defined(AMIGAOS)
# < ergebnis: Directory-Namestring (fürs OS, ASCIZ, ohne '/' am Schluß)
#endif
#if defined(RISCOS)
# < ergebnis: Directory-Namestring (fürs OS, ASCIZ, ohne '.' am Schluß)
#endif
# Erhöht STACK um 1.
# kann GC auslösen
  local object shorter_directory_arg (void);
  local object shorter_directory_arg()
    { var reg1 object pathname = coerce_pathname(popSTACK()); # Argument zu einem Pathname machen
      check_no_wildcards(pathname); # mit Wildcards -> Fehler
      pathname = use_default_dir(pathname); # Default-Directory einfügen
      # Überprüfe, ob Name=NIL und Typ=NIL :
      if (!(nullp(ThePathname(pathname)->pathname_name)
            && nullp(ThePathname(pathname)->pathname_type)
         ) )
        { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
          pushSTACK(pathname);
          fehler(file_error,
                 DEUTSCH ? "Das ist keine Directory-Angabe: ~" :
                 ENGLISH ? "not a directory: ~" :
                 FRANCAIS ? "Ceci ne désigne pas un répertoire : ~" :
                 ""
                );
        }
      pushSTACK(pathname); # neuen Pathname retten
      # verkürze das Directory:
      {var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
       #if HAS_SERNR
       if (nullp(Cdr(Cdr(subdirs)))) # Root-Directory ?
       #else
       if (nullp(Cdr(subdirs))) # Root-Directory ?
       #endif
         { baddir:
           # STACK_0 = pathname, Wert für Slot PATHNAME von FILE-ERROR
           pushSTACK(STACK_0);
           fehler(file_error,
                  DEUTSCH ? "Hier sind nur echte Unterdirectories zulässig, nicht ~" :
                  ENGLISH ? "root directory not allowed here: ~" :
                  FRANCAIS ? "Le répertoire racine n'est pas permis ici : ~" :
                  ""
                 );
         }
       subdirs = reverse(subdirs); # Liste kopieren und dabei umdrehen
       #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
       if (eq(Car(subdirs),S(Kparent))) # letztes Subdir muß /= :PARENT sein
         goto baddir;
       #endif
       pushSTACK(subdirs); # Cons mit letztem Subdir als CAR retten
       subdirs = Cdr(subdirs); # alle Subdirs bis aufs letzte
       subdirs = nreverse(subdirs); # wieder in die richtige Reihenfolge bringen
       pathname = STACK_1;
       ThePathname(pathname)->pathname_directory = subdirs; # und in den Pathname setzen
       # Dieses Directory muß existieren:
       pushSTACK(pathname);
       # Stackaufbau: pathname, subdircons, pathname.
       {var reg3 object dir_namestring = assure_dir_exists(FALSE);
        # Baue ASCIZ-String des Subdir für OS:
        STACK_0 = dir_namestring; # bisheriger Directory-Namestring als 1. String
        {var reg4 uintC stringcount =
           subdir_namestring_parts(STACK_1); # und Strings zum letzten Subdir
         # und kein '\' am Schluß (für DOS)
         # und kein '/' am Schluß (fürs OS)
         pushSTACK(O(null_string)); # und Nullbyte als letzten String
         {var reg5 object dirstring = string_concat(1+stringcount+1); # zusammenhängen
          skipSTACK(2);
          return dirstring;
    } }}}}

LISPFUNN(make_dir,1)
# (MAKE-DIR pathname) legt ein neues Unterdirectory pathname an.
  { var reg1 object pathstring = shorter_directory_arg();
    #ifdef ATARI
    var reg2 sintW errorcode =
      GEMDOS_mkdir(TheAsciz(pathstring)); # Unterdirectory erzeugen
    if (errorcode < 0) { OS_error(errorcode); } # Error melden
    #endif
    #ifdef AMIGAOS
    set_break_sem_4();
    begin_system_call();
    {var reg2 BPTR lock = CreateDir(TheAsciz(pathstring)); # Unterdirectory erzeugen
     if (lock==BPTR_NULL) { OS_error(); }
     UnLock(lock); # Lock freigeben
    }
    end_system_call();
    clr_break_sem_4();
    #endif
    #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
    begin_system_call();
    if (mkdir(TheAsciz(pathstring),0777)) # Unterdirectory erzeugen
      { OS_error(); }
    end_system_call();
    #endif
    value1 = T; mv_count=1; # 1 Wert T
  }

LISPFUNN(delete_dir,1)
# (DELETE-DIR pathname) entfernt das Unterdirectory pathname.
  { var reg1 object pathstring = shorter_directory_arg();
    #ifdef ATARI
    var reg2 sintW errorcode =
      GEMDOS_rmdir(TheAsciz(pathstring)); # Unterdirectory löschen
    if (errorcode < 0) { OS_error(errorcode); } # Error melden
    #endif
    #ifdef AMIGAOS
    # Noch Test, ob's auch ein Directory und kein File ist??
    begin_system_call();
    if (! DeleteFile(TheAsciz(pathstring)) ) # Unterdirectory löschen
      { OS_error(); }
    end_system_call();
    #endif
    #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
    begin_system_call();
    if (rmdir(TheAsciz(pathstring))) # Unterdirectory löschen
      { OS_error(); }
    end_system_call();
    #endif
    #ifdef RISCOS
    begin_system_call();
    if (unlink(TheAsciz(pathstring))) # Unterdirectory löschen
      { OS_error(); }
    end_system_call();
    #endif
    value1 = T; mv_count=1; # 1 Wert T
  }

# UP: Initialisiert das Pathname-System.
# init_pathnames();
# kann GC auslösen
  global void init_pathnames (void);
  global void init_pathnames()
    {
      #ifdef PATHNAME_ATARI
      # Default-Drive initialisieren:
      { var reg2 sintW errorcode = GEMDOS_CurrentDisk();
        if (errorcode<0) { OS_error(errorcode); }
        # errorcode ist jetzt die Nummer des aktuellen Laufwerks.
       {var reg1 object string = allocate_string(1); # String der Länge 1
        TheSstring(string)->data[0] = 'A' + errorcode; # mit Laufwerksbuchstaben
        O(default_drive) = string;
      }}
      # Drive-Alist initialisieren:
      { var reg3 uint16 drivebits = # Bitvektor aller angeschlossenen Laufwerke
          BIOS_DriveMap();
        pushSTACK(NIL); # Liste := NIL
       {var reg4 uintB bitnr = 16;
        # Bits 15..0 durchlaufen (abwärts):
        do { bitnr--;
             if (drivebits & bit(15)) # Bit bitnr im Bitvektor drivebits gesetzt ?
               { var reg2 object string = allocate_string(1); # String der Länge 1
                 TheSstring(string)->data[0] = 'A' + bitnr; # mit Laufwerksbuchstaben
                 pushSTACK(string);
                {var reg1 object new_cons = allocate_cons(); # neues Alisten-Cons
                 Car(new_cons) = popSTACK(); # new_cons = (drive . NIL)
                 # auf STACK_0 consen:
                 pushSTACK(new_cons);
                 new_cons = allocate_cons();
                 Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
                 STACK_0 = new_cons;
               }}
             drivebits <<= 1;
           }
           until (bitnr == 0);
        O(drive_alist) = popSTACK();
      }}
      # Aktuellen Pfad (von GEMDOS) zum aktuellen Directory auf der
      # im Default-Drive befindlichen Diskette erklären:
      { # Buffer für GEMDOS-Interaktion, vgl. GEMDOS_GetDir:
        var uintB path_buffer[64+1];
        var reg3 object pathname;
        { # aktuelles Directory im aktuellen Drive in path_buffer ablegen:
         {var reg2 sintW errorcode = GEMDOS_GetDir(&path_buffer[0],0);
          if (errorcode<0) { OS_error(errorcode); }
         }# Am Schluß ein '\' anfügen:
         {var reg1 uintB* pathptr = &path_buffer[0];
          var reg2 uintL len = 0; # Stringlänge
          until (*pathptr == 0) { pathptr++; len++; } # ASCIZ-Stringende suchen
          *pathptr = '\\'; len++; # ein '\' anfügen
          # und in einen String umwandeln:
          pathname = make_string(&path_buffer[0],len);
        }}
        pathname = coerce_pathname(pathname); # Pathname draus machen
        # Pathname enthält jetzt das aktuelle Directory.
        pathname = use_default_dir(pathname);
        # Pathname enthält jetzt das aktuelle Laufwerk und von der darin
        # befindlichen Diskette die Seriennummer und das aktuelle Directory.
        pushSTACK(pathname);
        change_default(); # Default-Drive, Default-Directory setzen,
                          # *DEFAULT-PATHNAME-DEFAULTS* initialisieren
        skipSTACK(1);
      }
      #else
      #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
      { # Default-Drive initialisieren:
        var uintB drive = default_drive();
        O(default_drive) = make_string(&drive,1);
      }
      #endif
      # *DEFAULT-PATHNAME-DEFAULTS* initialisieren:
      recalc_defaults_pathname();
      #endif
      #ifdef USER_HOMEDIR
      #ifdef UNIX
      # Wir ziehen uns das Home-Directory und die benutzbare Shell aus dem
      # Environment. Es enthält (fast) immer mindestens folgende Variablen:
      #   LOGNAME = Username beim ersten Einloggen ("wahre" Identität des Benutzers)
      #   USER    = aktueller Username
      #   HOME    = aktuelles Home-Directory, aus /etc/passwd geholt
      #   SHELL   = aktuelle Standard-Shell, aus /etc/passwd geholt
      #   PATH    = Suchpfad bei Programmaufruf
      #   TERM    = Terminalemulation
      # Wir holen uns HOME (für "~" - Übersetzung) und SHELL (für EXECUTE).
      # Bei "~username" müssen wir das /etc/passwd - File absuchen.
      { # Im Environment nach Variable HOME suchen:
        begin_system_call();
       {var reg1 const char* homedir = getenv("HOME");
        end_system_call();
        if (!(homedir==NULL)) # gefunden?
          { O(user_homedir) = asciz_dir_to_pathname(homedir); } # ja -> eintragen
          else
          # nein -> Home-Directory aus dem Passwort-File holen:
          { # empfohlene Methode (siehe GETLOGIN(3V)): erst
            # getpwnam(getlogin()), dann getpwuid(getuid()) probieren.
            var reg2 const char* username;
            var reg1 struct passwd * userpasswd;
            begin_system_call();
            # 1. Versuch: getpwnam(getenv("USER"))
            username = getenv("USER"); # Username aus dem Environment holen
            if (!(username==NULL))
              { errno = 0; userpasswd = getpwnam(username); # passwd-Eintrag dazu
                if (!(userpasswd==NULL)) goto userpasswd_ok; # gefunden -> ok
                if (!(errno==0)) { OS_error(); } # Error melden
              }
            # 2. Versuch: getpwnam(getlogin())
            errno = 0; username = getlogin(); # Username aus /etc/utmp holen
            if (username==NULL)
              { if (!(errno==0)) { OS_error(); } } # Error melden
              else
              { errno = 0; userpasswd = getpwnam(username); # passwd-Eintrag dazu
                if (!(userpasswd==NULL)) goto userpasswd_ok; # gefunden -> ok
                if (!(errno==0)) { OS_error(); } # Error melden
              }
            # 3. Versuch: getpwuid(getuid())
            errno = 0; userpasswd = getpwuid(user_uid);
            if (!(userpasswd==NULL)) # gefunden?
              { userpasswd_ok:
                end_system_call();
                O(user_homedir) = asciz_dir_to_pathname(userpasswd->pw_dir); # ja -> Homedir als Pathname eintragen
              }
              else
              { if (!(errno==0)) { OS_error(); } # Error melden
                end_system_call();
                # nein -> aktuelles Directory nehmen:
                O(user_homedir) = default_directory();
      }}  }   }
      #endif
      #endif
      #if defined(HAVE_SHELL) && !defined(ATARI) && !defined(AMIGAOS)
      #ifdef UNIX
      # Die Kommando-Shell O(command_shell) bleibt unverändert, sonst
      # handelt man sich zu viele Portabilitätsprobleme ein.
      { # Im Environment nach Variable SHELL suchen:
        begin_system_call();
       {var reg1 const char* shell = getenv("SHELL");
        end_system_call();
        if (!(shell==NULL)) # gefunden?
          { O(user_shell) = asciz_to_string(shell); } # ja -> eintragen
          # sonst bleibt O(user_shell) auf dem Defaultwert "/bin/csh".
      }}
      #endif
      #ifdef MSDOS
      { # Im Environment nach Variable COMSPEC suchen:
        begin_system_call();
       {var reg1 const char* shell = getenv("COMSPEC");
        end_system_call();
        if (!(shell==NULL)) # gefunden?
          { O(command_shell) = asciz_to_string(shell); } # ja -> eintragen
          # sonst bleibt O(command_shell) auf dem Defaultwert "\\COMMAND.COM".
      }}
      #endif
      #endif
    }

#if defined(ATARI) || defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
# UP: Legt Datum/Uhrzeit der Datei mit dem Handle handle im 4-Byte-Buffer ab.
# get_file_write_datetime(handle);
# > handle: Handle eines (offenen) Files
# < file_datetime: Datum und Uhrzeit der Datei
  local var struct { uintW time; uintW date; } file_datetime; # Buffer fürs Ergebnis
  local void get_file_write_datetime (uintW handle);
  #ifdef ATARI
  local void get_file_write_datetime(handle)
    var reg1 uintW handle;
    { # Datum und Uhrzeit der Datei in den Buffer:
      var reg2 sintW errorcode = GEMDOS_GSDTOF(&file_datetime,handle);
      if (errorcode<0) { OS_error(errorcode); } # Fehler aufgetreten?
    }
  #endif
  #if defined(DJUNIX) || defined(WATCOM)
  #include <dos.h>
  local void get_file_write_datetime(handle)
    var reg1 uintW handle;
    {
     #ifndef GNU
      var union REGS in;
      var union REGS out;
      in.regB.ah = 0x57; in.regB.al = 0; # DOS Function 57H
      in.regW.bx = handle;
      intdos(&in,&out);
      file_datetime.time = out.regW.cx;
      file_datetime.date = out.regW.dx;
     #else # dasselbe, nur effizienter
      var uintW time;
      var uintW date;
      __asm__ (# DOS Function 57H
               " movw $0x5700,%%ax ; int $0x21 "
               : "=c" /* %cx */ (time), "=d" /* %dx */ (date)     # OUT
               :                                                  # IN
               : "ax","bx","si","di" /* %eax, %ebx, %esi, %edi */ # CLOBBER
              );
      file_datetime.time = time;
      file_datetime.date = date;
     #endif
    }
  #endif
  #ifdef EMUNIX_OLD_8d
  extern int __filetime ( /* int handle, int flag, struct _ftd * */ );
  #define get_file_write_datetime(handle)  __filetime(handle,0,&file_datetime)
  #endif
#endif
#ifdef AMIGAOS
  local var struct DateStamp file_datetime; # Buffer für Datum/Uhrzeit einer Datei
#endif
#if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(RISCOS)
  local var time_t file_datetime; # Buffer für Datum/Uhrzeit einer Datei
#endif

LISPFUNN(file_write_date,1)
# (FILE-WRITE-DATE file), CLTL S. 424
  { var reg1 object pathname = popSTACK(); # pathname-Argument
    if (streamp(pathname))
      # Stream -> extra behandeln:
      { # muß File-Stream sein:
        pathname = as_file_stream(pathname);
        # Streamtyp File-Stream
       #if !defined(AMIGAOS)
        if ((TheStream(pathname)->strmflags & strmflags_open_B)
            && (!nullp(TheStream(pathname)->strm_file_handle))
           )
          # offener File-Stream
          { # direkt mit dem Handle arbeiten:
            #if defined(ATARI) || defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
            begin_system_call();
            get_file_write_datetime(TheHandle(TheStream(pathname)->strm_file_handle));
            end_system_call();
            #endif
            #if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(RISCOS)
            var struct stat status;
            begin_system_call();
            if (!( fstat(TheHandle(TheStream(pathname)->strm_file_handle),&status) ==0))
              { OS_error(); }
            end_system_call();
            file_datetime = status.st_mtime;
            #endif
          }
          else
       #endif
          # geschlossener File-Stream -> Truename als Pathname verwenden
          { pathname = TheStream(pathname)->strm_file_truename;
            goto is_pathname;
          }
      }
      else
      { pathname = coerce_pathname(pathname); # zu einem Pathname machen
        is_pathname: # pathname ist jetzt wirklich ein Pathname
        check_no_wildcards(pathname); # mit Wildcards -> Fehler
        pathname = use_default_dir(pathname); # Default-Directory einfügen
        if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
        # Name angegeben.
        pushSTACK(pathname);
       {# Directory muß existieren:
        var reg3 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
        #ifdef ATARI
        # Datei öffnen:
        var reg2 sintW errorcode;
        errorcode = # Datei zu öffnen versuchen, Modus 0 (Read)
          GEMDOS_open(TheAsciz(namestring),0);
        if (errorcode < 0) { OS_error(errorcode); } # Error melden
        # Nun enthält errorcode das Handle des geöffneten Files.
        get_file_write_datetime(errorcode); # Datum/Uhrzeit holen
        errorcode = # Datei gleich wieder schließen
          GEMDOS_close(errorcode);
        if (errorcode < 0) { OS_error(errorcode); } # Error melden
        #endif
        #ifdef MSDOS
         #if defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
          # Datei öffnen:
          begin_system_call();
          { var reg2 sintW ergebnis = # Datei zu öffnen versuchen
              open(TheAsciz(namestring),O_RDONLY);
            if (ergebnis < 0) { OS_error(); } # Error melden
            # Nun enthält ergebnis das Handle des geöffneten Files.
            get_file_write_datetime(ergebnis); # Datum/Uhrzeit holen
            if (CLOSE(ergebnis) < 0) { OS_error(); } # Datei gleich wieder schließen
          }
          end_system_call();
         #else # defined(EMUNIX_NEW_8e)
          { var struct stat statbuf;
            begin_system_call();
            if (stat(TheAsciz(namestring),&statbuf) < 0) { OS_error(); }
            end_system_call();
            if (!S_ISREG(statbuf.st_mode)) { fehler_file_not_exists(); } # Datei muß existieren
            file_datetime = statbuf.st_mtime;
          }
         #endif
        #endif
        #ifdef AMIGAOS
        if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei muß existieren
        file_datetime = filestatus->fib_Date;
        #endif
        #if defined(UNIX) || defined(RISCOS)
        if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei muß existieren
        file_datetime = filestatus->st_mtime;
        #endif
        skipSTACK(1);
      }}
    # Datum/Uhrzeit steht nun im Buffer file_datetime.
    # In Decoded-Time-Format umwandeln:
    { var decoded_time timepoint;
      #if defined(ATARI) || defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
      convert_timedate(file_datetime.time,file_datetime.date,&timepoint);
      #endif
      #if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(AMIGAOS) || defined(RISCOS)
      convert_time(&file_datetime,&timepoint);
      #endif
      pushSTACK(timepoint.Sekunden);
      pushSTACK(timepoint.Minuten);
      pushSTACK(timepoint.Stunden);
      pushSTACK(timepoint.Tag);
      pushSTACK(timepoint.Monat);
      pushSTACK(timepoint.Jahr);
      funcall(S(encode_universal_time),6);
      # (ENCODE-UNIVERSAL-TIME Sekunden Minuten Stunden Tag Monat Jahr)
      # als Ergebnis
  } }

LISPFUNN(file_author,1)
# (FILE-AUTHOR file), CLTL S. 424
  { var reg1 object pathname = popSTACK(); # pathname-Argument
    if (streamp(pathname))
      # Stream -> extra behandeln:
      { # muß File-Stream sein:
        pathname = as_file_stream(pathname);
        # Streamtyp File-Stream
        if (TheStream(pathname)->strmflags & strmflags_open_B)
          # offener File-Stream -> OK
          {}
          else
          # geschlossener File-Stream -> Truename als Pathname verwenden
          { pathname = TheStream(pathname)->strm_file_truename;
            goto is_pathname;
          }
      }
      else
      { pathname = coerce_pathname(pathname); # zu einem Pathname machen
        is_pathname: # pathname ist jetzt wirklich ein Pathname
        # pathname ist jetzt ein Pathname.
        check_no_wildcards(pathname); # mit Wildcards -> Fehler
        pathname = use_default_dir(pathname); # Default-Directory einfügen
        if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
        # Name angegeben.
        pushSTACK(pathname);
       {# Directory muß existieren:
        var reg3 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
        #ifdef ATARI
        # Überprüfe, ob die Datei existiert:
        var reg2 sintW errorcode;
        errorcode = # Datei zu öffnen versuchen, Modus 0 (Read)
          GEMDOS_open(TheAsciz(namestring),0);
        if (errorcode < 0) { OS_error(errorcode); } # Error melden
        # Nun enthält errorcode das Handle des geöffneten Files.
        errorcode = # Datei gleich wieder schließen
          GEMDOS_close(errorcode);
        if (errorcode < 0) { OS_error(errorcode); } # Error melden
        #endif
        #ifdef MSDOS
         #if 1
          # Datei öffnen:
          begin_system_call();
          { var reg2 sintW ergebnis = # Datei zu öffnen versuchen
              open(TheAsciz(namestring),O_RDONLY);
            if (ergebnis < 0) { OS_error(); } # Error melden
            # Nun enthält ergebnis das Handle des geöffneten Files.
            if (CLOSE(ergebnis) < 0) { OS_error(); } # Datei gleich wieder schließen
          }
          end_system_call();
         #else
          { var struct stat statbuf;
            begin_system_call();
            if (stat(TheAsciz(namestring),&statbuf) < 0) { OS_error(); }
            end_system_call();
            if (!S_ISREG(statbuf.st_mode)) { fehler_file_not_exists(); } # Datei muß existieren
          }
         #endif
        #endif
        #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
        if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei muß existieren
        #endif
        skipSTACK(1);
      }}
    # Datei existiert -> NIL als Wert
    value1 = NIL; mv_count=1;
  }

#ifdef ATARI

LISPFUN(execute,1,2,norest,nokey,0,NIL)
# (EXECUTE file [command-tail [space]]) ruft file auf, mit command-tail als
# Argumentstring. Es werden space Bytes fürs Programm zur Verfügung gestellt.
# Default für command-tail ist "".
# Default für space ist ein wenig mehr als (file-length file).
  { # file überprüfen:
   {var reg1 object pathname = STACK_2;
    pathname = coerce_pathname(pathname); # zu einem Pathname machen
    # pathname ist jetzt ein Pathname.
    check_no_wildcards(pathname); # mit Wildcards -> Fehler
    pathname = use_default_dir(pathname); # Default-Directory einfügen
    if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
    # Name angegeben.
    pushSTACK(pathname);
   }# Directory muß existieren:
    STACK_(2+1) = assure_dir_exists(FALSE); # Filename als ASCIZ-String
    # Stackaufbau: filename, command-tail, space, pathname.
    # Command-Tail überprüfen:
   {var reg1 object command_tail = STACK_(1+1);
    if (eq(command_tail,unbound))
      { command_tail = O(leer_string); } # "" als Default
      else
      { if (!stringp(command_tail))
          { pushSTACK(command_tail); # Wert für Slot DATUM von TYPE-ERROR
            pushSTACK(S(string)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
            pushSTACK(command_tail);
            pushSTACK(TheSubr(subr_self)->name);
            fehler(type_error,
                   DEUTSCH ? "~: Command-Tail muß ein String sein, nicht ~" :
                   ENGLISH ? "~: command tail should be a string, not ~" :
                   FRANCAIS ? "~ : le paramètre de commande doit être une chaîne et non ~" :
                   ""
                  );
          }
        command_tail = coerce_ss(command_tail); # in Simple-String umwandeln
      }
    STACK_(1+1) = command_tail;
   }# space überprüfen:
   {var reg5 uintL space; # Fürs aufzurufende Programm benötigter Platz
    if (!eq(STACK_(0+1),unbound))
      # space angegeben
      { skipSTACK(1); # Pathname vergessen
        if (!mposfixnump(STACK_0))
          { # STACK_0 = space, Wert für Slot DATUM von TYPE-ERROR
            pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
            pushSTACK(STACK_1);
            pushSTACK(TheSubr(subr_self)->name);
            fehler(type_error,
                   DEUTSCH ? "~: Platz-Angabe muß ein Fixnum >=0 sein, nicht ~" :
                   ENGLISH ? "~: space need should be a nonnegative fixnum, not ~" :
                   FRANCAIS ? "~ : Le besoin en place doit être exprimé par un Fixnum positif et non ~" :
                   ""
                  );
          }
        space = posfixnum_to_L(popSTACK()); # space-Argument verwenden
      }
      else
      # space bestimmt sich aus dem Header des File. STACK_0 = pathname.
      { # (OPEN pathname :ELEMENT-TYPE 'UNSIGNED-BYTE) ausführen:
        pushSTACK(S(Kelement_type)); pushSTACK(S(unsigned_byte));
        funcall(L(open),3);
       {var reg4 object stream = value1; # offener Byte-Stream auf pathname
        # Stackaufbau: filename, command-tail, dummy.
        # Überprüfe, ob das File ein ausführbares Programm ist:
        # Erste 14 Bytes lesen (testet auch, ob File-Länge >=14):
        var uintB buffer[14]; # Word-aligned!
        {var reg1 uintB* buffptr = &buffer[0];
         var reg3 uintC count;
         dotimesC(count,14,
           { var reg2 object b = read_byte(stream); # nächstes Byte lesen (löst keine GC aus)
             if (eq(b,eof_value)) { goto bad; } # File zu klein -> war nix
             *buffptr++ = (uintB)posfixnum_to_L(b); # Byte ablegen
           });
        }
        # File muß mit $601A anfangen:
        if (!(*(uintW*)(&buffer[0]) == 0x601A))
          { bad: # File zu kurz oder fängt nicht mit $601A an
            STACK_0 = stream; stream_close(&STACK_0); # File wieder schließen
            pushSTACK(STACK_2); # Wert für Slot PATHNAME von FILE-ERROR
            pushSTACK(STACK_(2+1)); # filename
            pushSTACK(TheSubr(subr_self)->name);
            fehler(file_error,
                   DEUTSCH ? "~: File ~ ist kein ausführbares Programm." :
                   ENGLISH ? "~: file ~ is not an executable program" :
                   FRANCAIS ? "~ : Le fichier ~ n'est pas exécutable." :
                   ""
                  );
          }
        space = *(uintL*)(&buffer[2]) # Länge TEXT-Segment
                + *(uintL*)(&buffer[6]) # Länge DATA-Segment
                + *(uintL*)(&buffer[10]) # Länge BSS-Segment
                + sizeof(BASEPAGE) # Länge Basepage
                + 1000 # genehmigte Stacklänge
                ;
        STACK_0 = stream; stream_close(&STACK_0); # File wieder schließen
        skipSTACK(1);
      }}
    # Stackaufbau: filename (Simple-ASCIZ-String), Command-tail (Simple-String)
    # Programm aufrufen:
    {var reg1 sintL ergebnis = execute(floor(space,2)*2);
     if (ergebnis < 0) { OS_error(ergebnis); } # Error melden
     # Rückgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
     value1 = (ergebnis==0 ? T : NIL); mv_count=1;
  }}}

#endif

#if defined(UNIX) || defined(MSDOS) || defined(RISCOS)

LISPFUN(execute,1,0,rest,nokey,0,NIL)
# (EXECUTE file arg1 arg2 ...) ruft ein File mit gegebenen Argumenten auf.
  {var reg6 object* args_pointer = rest_args_pointer STACKop 1;
   {var reg1 object* argptr = args_pointer; # Pointer über die Argumente
    # File überprüfen:
    { var reg2 object* file_ = &NEXT(argptr);
      var reg3 object pathname = *file_;
      pathname = coerce_pathname(pathname); # zu einem Pathname machen
      check_no_wildcards(pathname); # mit Wildcards -> Fehler
      pathname = use_default_dir(pathname); # Default-Directory einfügen
      if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
      # Name angegeben.
      pushSTACK(pathname);
     {# Directory muß existieren:
      var reg4 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
      # Überprüfe, ob die Datei existiert:
      if_file_exists(namestring, ; , { fehler_file_not_exists(); } );
      *file_ = namestring; # retten
      skipSTACK(1);
    }}
    # restliche Argumente überprüfen:
    { var reg3 uintC count;
      dotimesC(count,argcount,
        { var reg2 object* arg_ = &NEXT(argptr);
          pushSTACK(*arg_); funcall(L(string),1); # nächstes Argument in String umwandeln
          *arg_ = string_to_asciz(value1); # und ASCIZ-String umwandeln
        });
   }}
   #if defined(WATCOM) && defined(WINDOWS)
   # Alle Argumente (nun ASCIZ-Strings) zusammenhängen, mit Spaces dazwischen:
   {var reg1 object* argptr = args_pointer; # Pointer über die Argumente
    var reg3 uintC count;
    dotimesC(count,argcount, # alle Argumente außer dem letzten durchlaufen
      { var reg2 object string = NEXT(argptr); # nächster Argumentstring
        TheSstring(string)->data[TheSstring(string)->length - 1] = ' ';
      });
   }
   { var reg2 object command = string_concat(1+argcount);
     # Programm aufrufen:
     begin_system_call();
    {var reg1 int ergebnis = system(TheAsciz(command));
     end_system_call();
     # Rückgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
     value1 = (ergebnis==0 ? T : NIL); mv_count=1;
   }}
   #endif
   #if defined(DJUNIX) || defined(EMUNIX) || (defined(WATCOM) && !defined(WINDOWS))
   {# argv-Array aufbauen:
    var DYNAMIC_ARRAY(reg5,argv,char*,1+(uintL)argcount+1);
    { var reg1 object* argptr = args_pointer;
      var reg2 char** argvptr = &argv[0];
      var reg4 uintC count;
      dotimespC(count,argcount+1,
        { var reg3 object arg = NEXT(argptr); # nächstes Argument, ASCIZ-String
          *argvptr++ = TheAsciz(arg); # in argv einfüllen
        });
      *argvptr = NULL; # und mit Nullpointer abschließen
    }
    # Programm aufrufen:
    begin_system_call();
    {var reg2 int flags =
       #ifdef EMUNIX_NEW_9a
         P_QUOTE  # Argumente korrekt quoten
       #else
         0
       #endif
       ;
     var reg1 int ergebnis = spawnv(P_WAIT|flags,argv[0],argv);
     end_system_call();
     if (ergebnis < 0) { OS_error(); } # Error melden
     # Fertig.
     set_args_end_pointer(args_pointer); # STACK aufräumen
     # Rückgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
     value1 = (ergebnis==0 ? T : NIL); mv_count=1;
    }
    FREE_DYNAMIC_ARRAY(argv);
   }
   #endif
   #if defined(UNIX) || defined(RISCOS)
   { # argv-Array im Stack aufbauen und Strings in den Stack kopieren:
     var reg9 uintL argvdata_length = 0;
     { var reg1 object* argptr = args_pointer;
       var reg3 uintC count;
       dotimespC(count,argcount+1,
         { var reg2 object arg = NEXT(argptr); # nächstes Argument, ASCIZ-String
           argvdata_length += TheSstring(arg)->length;
         });
     }
    {var DYNAMIC_ARRAY(reg9,argv,char*,1+(uintL)argcount+1);
     var DYNAMIC_ARRAY(reg9,argvdata,char,argvdata_length);
     { var reg8 object* argptr = args_pointer;
       var reg7 char** argvptr = &argv[0];
       var reg1 char* argvdataptr = &argvdata[0];
       var reg5 uintC count;
       dotimespC(count,argcount+1,
         { var reg4 object arg = NEXT(argptr); # nächstes Argument, ASCIZ-String
           var reg2 char* ptr = TheAsciz(arg);
           var reg3 uintL len = TheSstring(arg)->length;
           *argvptr++ = argvdataptr; # in argv einfüllen
           dotimespL(len,len, { *argvdataptr++ = *ptr++; } ); # und kopieren
         });
       *argvptr = NULL; # und mit Nullpointer abschließen
     }
     # einen neuen Prozeß starten:
     { var reg2 int child;
       begin_system_call();
       if ((child = vfork()) ==0)
         # Dieses Programmstück wird vom Child-Prozeß ausgeführt:
         { execv(argv[0],argv); # Programm aufrufen
           _exit(-1); # sollte dies mißlingen, Child-Prozeß beenden
         }
       # Dieses Programmstück wird wieder vom Aufrufer ausgeführt:
       if (child==-1)
         # Etwas ist mißlungen, entweder beim vfork oder beim execv.
         # In beiden Fällen wurde errno gesetzt.
         { OS_error(); }
       # Warten, bis der Child-Prozeß beendet wird:
      {var int status = wait2(child);
       # vgl. WAIT(2V) und #include <sys/wait.h> :
       #   WIFSTOPPED(status)  ==  ((status & 0xFF) == 0177)
       #   WEXITSTATUS(status)  == ((status & 0xFF00) >> 8)
       end_system_call();
       # Fertig.
       set_args_end_pointer(args_pointer); # STACK aufräumen
       value1 = (((status & 0xFF) == 0000) # Prozeß normal beendet (ohne Signal, ohne Core-Dump) ?
                 ? # ja -> Exit-Status als Wert:
                   fixnum( (status & 0xFF00) >> 8)
                 : NIL # nein -> NIL als Wert
                );
       mv_count=1;
     }}
     FREE_DYNAMIC_ARRAY(argvdata);
     FREE_DYNAMIC_ARRAY(argv);
   }}
   #endif
  }

#endif

#ifdef AMIGAOS

LISPFUN(execute,1,0,norest,nokey,0,NIL)
# (EXECUTE command-string) schickt einen String an das Betriebssystem.
# Das ist in diesem Fall mit (SHELL command-string) synonym.
  { C_shell(); } # SHELL aufrufen, selber Stackaufbau

#endif

#ifdef HAVE_SHELL

# (SHELL) ruft eine Shell auf.
# (SHELL command) ruft eine Shell auf und läßt sie ein Kommando ausführen.

#if defined(ATARI)

local void (*online_shell)(); # Pointer auf eine online verfügbare Shell, oder NULL

# UP: Holt den Pointer auf die Online-Shell, falls vorhanden.
  local void get_online_shell (void);
  local void get_online_shell()
    { online_shell = *(void* *)0x04F6; } # nur im Supervisor-Modus aufzurufen!

# UP: führt ein Shell-Kommando aus.
# > command: Kommando, ein String
# kann GC auslösen
  local void do_shell (object command);
  local void do_shell(command)
    var reg1 object command; # Kommando, ein String
    { if (!(online_shell==NULL))
        # Online-Shell verfügbar
        { (*online_shell)(TheAsciz(string_to_asciz(command))); }
        else
        # Unsere eigene kleine "Shell" aufrufen:
        { pushSTACK(command); funcall(S(myshell),1); } # (SYS::MYSHELL command)
    }

LISPFUN(shell,0,1,norest,nokey,0,NIL)
  { var reg1 object command = popSTACK();
    Supervisor_Exec(get_online_shell);
    if (eq(command,unbound))
      { # Wir lesen Zeile für Zeile ein und übergeben diese der Shell.
        # (loop
        #   (write-string "$ ")
        #   (let ((line (read-line)))
        #     (cond ((string-equal line "exit") (return))
        #           ((string-equal line "help") (write-line "Mit EXIT zurück zum Lisp."))
        #           (t (shell line))
        # ) ) )
        loop
          { pushSTACK(O(shell_prompt)); funcall(L(write_string),1); # Prompt ausgeben
            funcall(L(read_line),0); # Zeile lesen
            if (!stringp(value1)) break; # EOF -> fertig
            if (string_equal(value1,O(shell_exit))) break; # EXIT -> fertig
            if (string_equal(value1,O(shell_help))) # HELP-Kommando
              { pushSTACK(OL(shell_helpstring)); funcall(L(write_line),1); }
            else
              { do_shell(value1); } # sonstiges Shell-Kommando ausführen
          }
      }
      else
      { pushSTACK(command); funcall(L(string),1); # Argument in String umwandeln
        do_shell(value1);
      }
    value1 = T; mv_count=1; # T als Wert
  }

#elif defined(AMIGAOS)

LISPFUN(shell,0,1,norest,nokey,0,NIL)
  { var reg1 object command = popSTACK();
    if (eq(command,unbound))
      # Kommandointerpreter aufrufen:
      { run_time_stop();
        begin_system_call();
       {var reg2 BOOL ergebnis = FALSE;
        #if 0 # so einfach geht's wohl nicht
        ergebnis = Execute("",Input_handle,Output_handle);
        #else
        var reg3 Handle terminal = Open("*",MODE_READWRITE);
        if (!(terminal==Handle_NULL))
          { ergebnis = Execute("",terminal,Handle_NULL);
            Close(terminal);
            Write(Output_handle,CRLFstring,1);
          }
        #endif
        end_system_call();
        run_time_restart();
        # Rückgabewert verwerten: ausgeführt -> T, nicht gefunden -> NIL :
        value1 = (ergebnis ? T : NIL); mv_count=1;
      }}
      else
      # einzelnes Kommando ausführen:
      { if (!stringp(command))
          { pushSTACK(command); # Wert für Slot DATUM von TYPE-ERROR
            pushSTACK(S(string)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
            pushSTACK(command);
            pushSTACK(TheSubr(subr_self)->name);
            fehler(type_error,
                   DEUTSCH ? "~: Befehl muß ein String sein, nicht ~." :
                   ENGLISH ? "~: the command should be a string, not ~" :
                   FRANCAIS ? "~ : La commande doit être de type STRING et non ~." :
                   ""
                  );
          }
        command = string_to_asciz(command); # in Simple-String umwandeln
        # Kommando ausführen:
        run_time_stop();
        begin_system_call();
       {var reg2 BOOL ergebnis = Execute(TheAsciz(command),Handle_NULL,Output_handle);
        end_system_call();
        run_time_restart();
        # Rückgabewert verwerten: ausgeführt -> T, nicht gefunden -> NIL :
        value1 = (ergebnis ? T : NIL); mv_count=1;
      }}
  }

#else # UNIX || MSDOS || ...

LISPFUN(shell,0,1,norest,nokey,0,NIL)
  { var reg1 object command = popSTACK();
    if (eq(command,unbound))
      { # (EXECUTE shell) ausführen:
        #ifdef UNIX
        pushSTACK(O(user_shell)); # Shell-Name
        #else # MSDOS
        pushSTACK(O(command_shell)); # Shell-Name
        #endif
        funcall(L(execute),1);
      }
      else
      #if defined(MSDOS) || defined(RISCOS)
      # Dem DOS-Kommandointerpreter muß man das Kommando bereits entlang
      # der Leerstellen in einzelne Teile zerlegt übergeben. Die Funktion
      # system() erledigt uns das zum Glück.
      { command = string_to_asciz(command);
        begin_system_call();
        # Programm aufrufen:
       {var reg1 int ergebnis = system(TheAsciz(command));
        end_system_call();
        # Rückgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
        value1 = (ergebnis==0 ? T : NIL); mv_count=1;
      }}
      #else
      { # (EXECUTE shell "-c" command) ausführen:
        pushSTACK(O(command_shell)); # Shell-Name
        pushSTACK(O(command_shell_option)); # Shell-Option "-c"
        #if defined(MSDOS) && defined(EMUNIX)
        # Unter DOS 2.x, 3.x kann das Optionen-Zeichen ein anderes sein!
        if ((_osmode == DOS_MODE) && (_osmajor < 4))
          { var reg2 uintB swchar = _swchar();
            if (swchar) # evtl. "/C" durch etwas anderes ersetzen
              { TheSstring(STACK_0)->data[0] = swchar; } # (destruktiv)
          }
        #endif
        pushSTACK(command);
        funcall(L(execute),3);
      }
      #endif
  }

#endif

#endif

LISPFUNN(savemem,1)
# (SAVEMEM pathname) speichert ein Speicherabbild unter pathname ab.
  { # (OPEN pathname :direction :output) ausführen:
    # pathname als 1. Argument
    pushSTACK(S(Kdirection)); # :DIRECTION als 2. Argument
    pushSTACK(S(Koutput)); # :OUTPUT als 3. Argument
    #ifndef UNIX
    funcall(L(open),3);
    #else
    # Unter Unix mit mmap() darf man existierende .mem-Files nicht einfach
    # überschreiben, weil laufende Lisp-Prozesse dadurch abstürzen würden.
    pushSTACK(S(Kif_exists)); # :IF-EXISTS als 4. Argument
    pushSTACK(S(Krename_and_delete)); # :RENAME-AND-DELETE als 5. Argument
    funcall(L(open),5);
    #endif
    # Speicherabbild in die Datei schreiben:
    # (Den Stream muß die Funktion savemem() schließen, auch im Fehlerfalle.)
    savemem(value1);
    value1 = T; mv_count=1; # 1 Wert T
  }

# ==============================================================================

#ifdef EMUNIX_PORTABEL

# Umgehen eines lästigen ENAMETOOLONG Errors bei Benutzung von langen
# Filenamen auf FAT-Drives unter OS/2:

#undef chdir
#undef access
#undef stat
#undef unlink
#undef rename
#undef __findfirst
#undef mkdir
#undef open
#undef creat
#undef spawnv

# path2 := verkürzte Kopie von path1
local void shorten_path (const char* path1, char* path2)
  { var reg1 const uintB* p1 = path1;
    var reg2 uintB* p2 = path2;
    var reg3 uintB c;
    var reg4 uintC wordlength = 0; # bisherige Länge in Name oder Typ
    var reg5 uintC maxwordlength = 8; # = 8 im Namen, = 3 im Typ
    loop
      { c = *p1++;
        if (c=='\0') { *p2++ = c; break; }
        if ((c=='\\') || (c=='/') || (c==':'))
          { *p2++ = c; wordlength = 0; maxwordlength = 8; }
        elif (c=='.')
          { *p2++ = c; wordlength = 0; maxwordlength = 3; }
        else
          { if (++wordlength <= maxwordlength) { *p2++ = c; } }
  }   }

global int my_chdir(path)
  var reg2 CONST char* path;
  { var reg1 int erg = chdir(path);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg3 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = chdir(shorter_path);
      }
    return erg;
  }

global int my_access(path,amode)
  var reg3 CONST char* path;
  var reg2 int amode;
  { var reg1 int erg = access(path,amode);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = access(shorter_path,amode);
      }
    return erg;
  }

global int my_stat(path,buf)
  var reg3 CONST char* path;
  var reg2 struct stat * buf;
  { var reg1 int erg = stat(path,buf);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = stat(shorter_path,buf);
      }
    return erg;
  }

global int my_unlink(path)
  var reg2 CONST char* path;
  { var reg1 int erg = unlink(path);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg3 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = unlink(shorter_path);
      }
    return erg;
  }

global int my_rename(oldpath,newpath)
  var reg3 CONST char* oldpath;
  var reg2 CONST char* newpath;
  { var reg1 int erg = rename(oldpath,newpath);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg4 char* shorter_oldpath = alloca(asciz_length(oldpath)+1);
        shorten_path(oldpath,shorter_oldpath);
        erg = rename(shorter_oldpath,newpath);
        if ((erg<0) && (errno==ENAMETOOLONG))
          { var reg5 char* shorter_newpath = alloca(asciz_length(newpath)+1);
            shorten_path(newpath,shorter_newpath);
            erg = rename(shorter_oldpath,shorter_newpath);
      }   }
    return erg;
  }

global int my___findfirst(path,attrib,ffblk)
  var reg4 const char* path;
  var reg2 int attrib;
  var reg3 struct ffblk * ffblk;
  { var reg1 int erg = __findfirst(path,attrib,ffblk);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg5 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = __findfirst(shorter_path,attrib,ffblk);
      }
    return erg;
  }

#ifdef EMUNIX_OLD_8e
  #define mkdir(path,attrib) (mkdir)(path)
#endif
global int my_mkdir(path,attrib)
  var reg2 CONST char* path;
  var reg3 long attrib;
  { var reg1 int erg = mkdir(path,attrib);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = mkdir(shorter_path,attrib);
      }
    return erg;
  }

global int my_open(path,flags)
  var reg3 CONST char* path;
  var reg2 int flags;
  { var reg1 int erg = open(path,flags);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = open(shorter_path,flags);
      }
    return erg;
  }

#define creat(path,mode)  open(path,O_RDWR|O_TRUNC|O_CREAT,mode)
global int my_creat(path,pmode)
  var reg3 CONST char* path;
  var reg2 int pmode;
  { var reg1 int erg = creat(path,pmode);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = creat(shorter_path,pmode);
      }
    return erg;
  }

global int my_spawnv(pmode,path,argv)
  var reg2 int pmode;
  var reg4 CONST char* path;
  var reg3 CONST char* CONST * argv;
  { var reg1 int erg = spawnv(pmode,path,argv);
    if ((erg<0) && (errno==ENAMETOOLONG))
      { var reg5 char* shorter_path = alloca(asciz_length(path)+1);
        shorten_path(path,shorter_path);
        erg = spawnv(pmode,shorter_path,argv);
      }
    return erg;
  }

#endif

# ==============================================================================

